diff --git a/.dockerignore b/.dockerignore new file mode 100644 index 0000000000..9b44aabadf --- /dev/null +++ b/.dockerignore @@ -0,0 +1,28 @@ +# .git +**.hi +**.o +*.eventlog +*.eventlog +*.hp +*.prof +*.ps +*.tags +.DS_Store +.ghc.environment* +.stack-work +Dockerfile +Tmp* +chainweb-node +chainweb-node* +chainweb-node-prof* +chainweb-tests* +ci-logs +ci-logs* +dist +dist-newstyle +hie.log +out* +prof-data +tags +tmp +tmp* diff --git a/.github/actions/install-chainweb-from-artifacts/action.yml b/.github/actions/install-chainweb-from-artifacts/action.yml index 6f43f1956b..8e4214402a 100644 --- a/.github/actions/install-chainweb-from-artifacts/action.yml +++ b/.github/actions/install-chainweb-from-artifacts/action.yml @@ -25,8 +25,11 @@ runs: ubuntu-22.04) sudo apt-get install -u libgflags2.2 ;; + ubuntu-24.04) + sudo apt-get install -u libgflags2.2 + ;; mac*) - brew update && brew install gnu-tar || true + brew update && brew install gflags llvm snappy || true ;; *) echo "::error::unsupported operating system ${{ inputs.os }}" diff --git a/.github/workflows/applications.yml b/.github/workflows/applications.yml index 5f9e7b83e4..cb1c1b504c 100644 --- a/.github/workflows/applications.yml +++ b/.github/workflows/applications.yml @@ -88,12 +88,12 @@ jobs: DEBUG_INFO=${{ github.event.inputs.debugInfo }} if [[ -n "$DEBUG_INFO" && "${DEBUG_INFO^^}" = "TRUE" ]] ; then echo "building binaries with dwarf debug symbols" - echo "debug-info=True" >> $GITHUB_OUTPUT + echo "debug-info=2" >> $GITHUB_OUTPUT echo "stripping=False" >> $GITHUB_OUTPUT TAG_SUFFIX+=-dwarf else echo "building binaries without dwarf debug symbols" - echo "debug-info=False" >> $GITHUB_OUTPUT + echo "debug-info=0" >> $GITHUB_OUTPUT echo "stripping=True" >> $GITHUB_OUTPUT fi @@ -140,16 +140,16 @@ jobs: if "${{ github.event_name == 'schedule' }}" == "true"; then MATRIX="$(jq -c '.' <&2 exit 1 fi + - name: Run ea and verify consistency of genesis headers run: | cabal run ea @@ -389,23 +411,22 @@ jobs: - name: Prepare artifacts run: | mkdir -p artifacts/chainweb - cp $(cabal list-bin b64) artifacts/chainweb - cp $(cabal list-bin bench) artifacts/chainweb cp $(cabal list-bin chainweb-node) artifacts/chainweb - cp $(cabal list-bin chainweb-storage-tests) artifacts/chainweb - cp $(cabal list-bin chainweb-tests) artifacts/chainweb + cp $(cabal list-bin test:chainweb-storage-tests) artifacts/chainweb + cp $(cabal list-bin test:chainweb-tests) artifacts/chainweb + cp $(cabal list-bin test:remote-tests) artifacts/chainweb + cp $(cabal list-bin test:blockhistory-migration-tests) artifacts/chainweb + cp $(cabal list-bin test:multi-node-network-tests) artifacts/chainweb + cp $(cabal list-bin bench) artifacts/chainweb + cp $(cabal list-bin evm-genesis) artifacts/chainweb cp $(cabal list-bin compact) artifacts/chainweb - cp $(cabal list-bin compaction-tests) artifacts/chainweb - cp $(cabal list-bin db-checksum) artifacts/chainweb cp $(cabal list-bin ea) artifacts/chainweb cp $(cabal list-bin genconf) artifacts/chainweb - cp $(cabal list-bin header-dump) artifacts/chainweb cp $(cabal list-bin known-graphs) artifacts/chainweb - cp $(cabal list-bin multi-node-network-tests) artifacts/chainweb cp $(cabal list-bin pact-diff) artifacts/chainweb - cp $(cabal list-bin remote-tests) artifacts/chainweb - cp $(cabal list-bin run-nodes) artifacts/chainweb + cp $(cabal list-bin standalone-pruner) artifacts/chainweb cp $(cabal list-bin tx-list) artifacts/chainweb + cp $(cabal list-bin run-nodes) artifacts/chainweb cp README.md artifacts/chainweb cp CHANGELOG.md artifacts/chainweb cp LICENSE artifacts/chainweb @@ -413,6 +434,9 @@ jobs: cp cabal.project artifacts/chainweb cp cabal.project.local artifacts/chainweb cp cabal.project.freeze artifacts/chainweb + # cp $(cabal list-bin header-dump) artifacts/chainweb + # cp $(cabal list-bin compaction-tests) artifacts/chainweb + # cp $(cabal list-bin db-checksum) artifacts/chainweb - name: Create artifacts archive run: | echo "tar -C ./artifacts/ -czf $ARTIFACTS_ARCHIVE chainweb" @@ -455,6 +479,7 @@ jobs: run: remote-tests compaction-tests: + if: false # diabled on the evm branches name: Compaction tests needs: [config, build] runs-on: ${{ matrix.os }} @@ -483,6 +508,8 @@ jobs: compaction-tests multi-node-network-tests: + # disabled for now on the evm branches. 10 nodes with 100 chains probably overwhelms the runners. + if: false name: Multi-node network tests needs: [config, build] runs-on: ${{ matrix.os }} @@ -536,10 +563,41 @@ jobs: timeout-minutes: 2 run: chainweb-storage-tests + blockhistory-migration-tests: + if: false # disabled because it needs databases as input + name: RocksDB library tests + needs: [config, build] + runs-on: ${{ matrix.os }} + env: + ARTIFACTS_NAME: chainweb-applications.${{ matrix.use-freeze-file }}.${{ matrix.ghc }}.${{ matrix.os }} + strategy: + fail-fast: false + matrix: ${{ fromJson(needs.config.outputs.matrix) }} + steps: + - uses: actions/checkout@v4 + - name: Download build artifacts + uses: actions/download-artifact@v4 + with: + name: ${{ env.ARTIFACTS_NAME }} + path: . + - name: Install chainweb from artifacts + uses: ./.github/actions/install-chainweb-from-artifacts + with: + os: ${{ matrix.os }} + ghc: ${{ matrix.ghc }} + use-freeze-file: ${{ matrix.use-freeze-file }} + - name: Run blockhistory-migration-tests tests + timeout-minutes: 2 + run: blockhistory-migration-tests + # ########################################################################## # # Run Benchmarks + # Benchmarks take a long time to run and should run in controlled environment. + # Github runners tent to be noisy. So, we only build but don't run the + # benchmarks on push events. benchmarks: + if: false name: Benchmarks needs: [config, build] strategy: @@ -606,7 +664,12 @@ jobs: timeout-minutes: 10 run: | ulimit -n 10000 - chainweb-tests --hide-successes --results-json test-results.json + grep -q -e '&&' FAILING_TESTS && echo "warning: FAILING_TESTS file is not empty" 1>&2 + chainweb-tests \ + --hide-successes \ + --results-json test-results.json \ + -p "$(tr '\n' ' ' < FAILING_TESTS)" + # Publish test results to S3 - name: Upload test results @@ -665,6 +728,9 @@ jobs: - ghc: "9.10.3" os: "ubuntu-22.04" use-freeze-file: "true" + - ghc: "9.10.3" + os: "ubuntu-22.04" + use-freeze-file: "false" env: OS: ${{ matrix.os }} ARTIFACTS_NAME: chainweb-applications.${{ matrix.use-freeze-file }}.${{ matrix.ghc }}.${{ matrix.os }} diff --git a/.github/workflows/macos.yaml b/.github/workflows/macos.yaml new file mode 100644 index 0000000000..b39dda9ec8 --- /dev/null +++ b/.github/workflows/macos.yaml @@ -0,0 +1,202 @@ +name: Build with MacOS + +on: + workflow_dispatch: + push: + # paths-ignore: + # - '.github/**' + +permissions: + contents: read + +jobs: + + # Note that cabal-cache-action only support arm64 for macos + build: + name: Build + runs-on: ${{ matrix.os }} + strategy: + fail-fast: false + matrix: + ghc: ["9.12.2"] + cabal: ["latest"] + os: ["macos-latest"] + cabalcache: ["true"] + + steps: + # Setup + - name: Checkout repository + uses: actions/checkout@v3 + + - uses: actions/cache/restore@v4 + name: Restore ghc & cabal binaries cache + id: ghc-cabal-cache + env: + key: ${{ runner.os }}-${{ runner.arch }}-ghc-cabal + with: + path: | + /Users/runner/.ghcup + key: ${{ env.key }}-${{ hashFiles('bin/cabal', 'bin/ghc') }} + restore-keys: ${{ env.key }}- + + - uses: actions/cache/restore@v4 + name: Restore dist-newstyle cache + id: cabal-dist-cache + env: + key: ${{ runner.os }}-${{ runner.arch }}-${{ matrix.ghc }}-dist + with: + path: | + ~/.cabal/packages + ~/.cabal/store + dist-newstyle + key: ${{ env.key }}-${{ hashFiles('cabal.*', '*.cabal', 'src/**', 'test/**', 'bench/**', 'tools/**') }} + restore-keys: | + ${{ env.key }} + + - name: Install GHC and Cabal + id: setup + uses: haskell-actions/setup@v2 + with: + ghc-version: ${{ matrix.ghc }} + cabal-version: ${{ matrix.cabal }} + - name: Confirm GHC and Cabal installation + run: | + echo "setup ghc-version: ${{ steps.setup.outputs.ghc-version }}" + echo "setup cabal-version: ${{ steps.setup.outputs.cabal-version }}" + echo "setup cabal-store: ${{ steps.setup.outputs.cabal-store }}" + ghc --version + cabal --version + ghc --version + cabal --version + + - uses: actions/cache/save@v4 + name: Cache ghc & cabal binaries + if: steps.ghc-cabal-cache.outputs.cache-hit != 'true' + with: + path: | + /Users/runner/.ghcup + key: ${{ steps.ghc-cabal-cache.outputs.cache-primary-key }} + + - name: Fix toolchain/SDK mismatch + # Workaround for: ld: tapi error: malformed file ... MacOSX27.0.sdk ... + # unknown architecture arm64e.x1-macos. This happens when clang and ld + # are picked from different toolchains (Xcode vs Command Line Tools). + # Select a consistent toolchain by testing which one can link. + run: | + echo 'int main(void){return 0;}' > /tmp/toolchain-test.c + if ! clang /tmp/toolchain-test.c -o /tmp/toolchain-test 2>/dev/null; then + echo "Default toolchain cannot link; switching to Xcode toolchain" + sudo xcode-select -s /Applications/Xcode.app/Contents/Developer + fi + if ! clang /tmp/toolchain-test.c -o /tmp/toolchain-test 2>/dev/null; then + echo "Xcode toolchain cannot link; switching to Command Line Tools" + sudo xcode-select -s /Library/Developer/CommandLineTools + fi + if ! clang /tmp/toolchain-test.c -o /tmp/toolchain-test 2>/dev/null; then + echo "No working toolchain found" 1>&2 + exit 1 + fi + clang -v + ld -v + - name: Install non-Haskell dependencies (macOS) + run: | + brew install -q gflags llvm snappy || true + - name: Create cabal.project.local + run: | + cat > cabal.project.local <&2 + exit 1 + fi + mv cabal.project.freeze.backup cabal.project.freeze + - name: Run ea and verify consistency of genesis headers + run: | + cabal run ea + mv cabal.project.freeze cabal.project.freeze.backup + git checkout -- cabal.project.freeze || true + if ! git diff --exit-code; then + echo "Inconsistent genesis headers detected. Did you forget to run ea?" 1>&2 + exit 1 + fi + mv cabal.project.freeze.backup cabal.project.freeze + diff --git a/Dockerfile b/Dockerfile index 8b75392a1b..0fd3c1510c 100644 --- a/Dockerfile +++ b/Dockerfile @@ -46,8 +46,8 @@ # support this we would have to define dedicated runtime images and build # images. -ARG UBUNTU_VERSION=22.04 -ARG GHC_VERSION=9.10.1 +ARG UBUNTU_VERSION=24.04 +ARG GHC_VERSION=9.12.2 ARG PROJECT_NAME=chainweb # ############################################################################ # @@ -68,11 +68,12 @@ RUN <&2 ; exit 1 ; } EOF RUN --mount=type=cache,target=/root/.cabal,id=${TARGETPLATFORM} \ --mount=type=cache,target=./dist-newstyle,id=${PROJECT_NAME}-${TARGETPLATFORM},sharing=locked < do - registerVersion RecapDevelopment - registerVersion Development - - defaultMain - [ ApplyCmd.bench rdb - , Checkpointer.bench - , ForkingBench.bench rdb - , JSONEncoding.benchmarks +main = defaultMain + [ JSONEncoding.benchmarks , MempoolBench.bench - , PactService.bench rdb + , CutDBBench.bench ] + +-- main :: IO () +-- main = withTempRocksDb "benchmarks" $ \rdb -> defaultMain +-- [ JSONEncoding.benchmarks +-- , ApplyCmd.bench rdb +-- , Checkpointer.bench +-- , ForkingBench.bench rdb +-- , MempoolBench.bench +-- , PactService.bench rdb +-- ] diff --git a/bench/Chainweb/CutDBBench.hs b/bench/Chainweb/CutDBBench.hs new file mode 100644 index 0000000000..92bc4fc5f1 --- /dev/null +++ b/bench/Chainweb/CutDBBench.hs @@ -0,0 +1,239 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE NumericUnderscores #-} +{-# LANGUAGE OverloadedStrings #-} + +module Chainweb.CutDBBench (bench) where + +import Chainweb.BlockHeader +import Chainweb.BlockHeight (CutHeight) +import Chainweb.Chainweb.Configuration +import Chainweb.Cut +import Chainweb.Cut.CutHashes +import Chainweb.CutDB +import Chainweb.CutDB.RestAPI.Client +import Chainweb.Graph +import Chainweb.HostAddress +import Chainweb.Logger +import Chainweb.Pact.Payload +import Chainweb.Pact.Utils +import Chainweb.PayloadProvider +import Chainweb.RestAPI +import Chainweb.Sync.WebBlockHeaderStore +import Chainweb.Test.Cut +import Chainweb.Test.TestVersions +import Chainweb.Test.Utils +import Chainweb.Time qualified as Time +import Chainweb.Utils +import Chainweb.Utils.Bench +import Chainweb.Version +import Chainweb.WebBlockHeaderDB + +import Control.Concurrent (threadDelay) +import Control.Concurrent.STM qualified as STM +import Control.Exception +import Control.Lens +import Control.Monad +import Control.Monad.IO.Class +import Control.Monad.Trans.Resource (InternalState, ResourceT) +import Control.Monad.Trans.Resource qualified as ResourceT + +import Criterion.Main qualified as C +import Data.Foldable (toList) +import Data.HashMap.Strict qualified as HM +import Network.HTTP.Client qualified as HTTP +import Network.X509.SelfSigned +import P2P.Peer +import Servant.Client +import System.Timeout (timeout) + +-- | The node that has already mined one complete catch-up step. +data Source = Source + { sourceClientEnv :: !ClientEnv + , sourcePeerInfo :: !PeerInfo + } + +newtype Target = Target (CutDb GenericLogger) + +benchmarkVersion :: ChainwebVersion +benchmarkVersion = barebonesTestVersion twentyChainGraph + +-- | Keep a 'ResourceT' allocation alive until Criterion invokes the matching +-- cleanup action. +acquire + :: ResourceT IO a + -> IO (NoopNFData (a, InternalState)) +acquire action = mask $ \restore -> do + state <- ResourceT.createInternalState + result <- restore (ResourceT.runInternalState action state) + `onException` ResourceT.closeInternalState state + return $ NoopNFData (result, state) + +release :: NoopNFData (a, InternalState) -> IO () +release (NoopNFData (_, state)) = ResourceT.closeInternalState state + +-- | Add the given number of microseconds of synthetic latency to every +-- HTTP request issued through the manager, to emulate internetwork +-- conditions. +addLatency :: Int -> HTTP.ManagerSettings -> HTTP.ManagerSettings +addLatency us s = s + { HTTP.managerModifyRequest = + \req -> threadDelay us >> HTTP.managerModifyRequest s req + } + +newCutDb :: HasVersion => Int -> ResourceT IO (CutDb GenericLogger) +newCutDb latencyUs = do + rocksDb <- withRocksResource + webDb <- liftIO $ initWebBlockHeaderDb rocksDb + managerSettings <- liftIO + $ addLatency latencyUs <$> certificateCacheManagerSettings TlsInsecure + httpManager <- liftIO $ HTTP.newManager managerSettings + headerStore <- liftIO $ newWebBlockHeaderStore httpManager webDb noopLogger + Right cutDb <- withCutDb + (defaultCutDbParams 4_125_000) + noopLogger + headerStore + (onAllChains DisabledPayloadProvider) + (cutHashesTable rocksDb) + return cutDb + +-- | Upper bound (in microseconds) on how long to wait for the cut +-- database to accept a cut before declaring the catch-up failed. Must +-- comfortably exceed the cut database's fetch timeout plus the synthetic +-- per-request latency, or slow-but-successful catch-ups would be +-- misreported as failures. +awaitCutTimeoutUs :: Int +awaitCutTimeoutUs = 120_000_000 + +-- | Wait for the cut database to accept a cut of at least the given +-- height. Cuts whose prerequisite headers cannot be fetched within the +-- cut database's fetch timeout are dropped, so acceptance is not +-- guaranteed and an unconditional 'STM.check' would block forever. +awaitCutHeight :: CutDb GenericLogger -> CutHeight -> IO () +awaitCutHeight cutDb height = do + result <- timeout awaitCutTimeoutUs $ STM.atomically $ do + acceptedCut <- _cutStm cutDb + STM.check $ _cutHeight acceptedCut >= height + case result of + Nothing -> throwIO $ userError + $ "cut database did not accept a cut of height " + <> show height + <> " within " + <> show awaitCutTimeoutUs + <> "us" + Just _ -> pure () + +-- | The largest catch-up step the cut database accepts from a single +-- submission: bounded by 'farAheadThreshold' relative to the current +-- cut (cf. 'syncSession' in "Chainweb.CutDB.Sync", which additionally +-- caps this at 'catchupStepSize' = 500). +stepSize :: HasVersion => CutHeight +stepSize = int farAheadThreshold * int (length (toList chainIds)) - 1 + +mineCatchupStep :: HasVersion => CutDb GenericLogger -> IO () +mineCatchupStep cutDb = do + start <- _cut cutDb + void $ foldM mineOne start miningPlan + where + webDb = view cutDbWebBlockHeaderDb cutDb + payloadHash = _payloadWithOutputsPayloadHash emptyPayload + + mineOne !currentCut (nonce, cid) = do + let creationTime = offsetBlockTime Time.second currentCut cid + Right (T2 header nextCut) <- testMineWithPayloadHash + webDb + (Nonce nonce) + creationTime + payloadHash + cid + currentCut + addCutHashes cutDb $ (cutToCutHashes Nothing nextCut) + { _cutHashesHeaders = HM.singleton (view blockHash header) header + } + awaitCutHeight cutDb $ _cutHeight nextCut + return nextCut + + -- All chains advance together in balanced rounds, so the maximum + -- skew between chains remains below 'farAheadThreshold'. + miningPlan = zip [0 ..] + $ take (int stepSize) + $ cycle + $ toList chainIds + +sourceResource :: HasVersion => Int -> ResourceT IO Source +sourceResource latencyUs = do + cutDb <- newCutDb latencyUs + liftIO $ mineCatchupStep cutDb + minedCut <- liftIO $ _cut cutDb + liftIO $ unless (_cutHeight minedCut == stepSize) + $ throwIO + $ userError "mined cut does not span a complete catch-up step" + + let serverDbs :: ChainwebServerDbs GenericLogger () + serverDbs = emptyChainwebServerDbs + { _chainwebServerCutDb = Just cutDb + , _chainwebServerBlockHeaderDbs = + view (cutDbWebBlockHeaderDb . webBlockHeaderDb) cutDb + } + app = chainwebApplication + (defaultChainwebConfiguration implicitVersion) + serverDbs + + port <- withChainwebTestServer DoNotValidateSpec True app + managerSettings <- liftIO + $ addLatency latencyUs <$> certificateCacheManagerSettings TlsInsecure + httpManager <- liftIO $ HTTP.newManager managerSettings + let clientEnv = mkClientEnv httpManager $ BaseUrl Https testHost port "" + originPeer = PeerInfo Nothing $ HostAddress localhost + $ fromJuste + $ portFromInt port + return $ Source clientEnv originPeer + +targetResource :: HasVersion => Int -> ResourceT IO Target +targetResource latencyUs = Target <$> newCutDb latencyUs + +-- | Iteratively pull and apply cuts, mirroring the receive loop of +-- 'syncSession'. A single submission of the full mined step would be +-- discarded as "far ahead" (cf. 'farAheadThreshold'), so the target +-- walks up to the mined height in bounded steps, exactly as a real node +-- does during catch-up. +catchUp :: HasVersion => Source -> Target -> IO () +catchUp source (Target target) = go + where + go = do + cur <- _cut target + let curHeight = _cutHeight cur + limit = curHeight + stepSize + when (curHeight < stepSize) $ do + remoteCut <- either throwIO return =<< runClientM + (cutGetClientLimit $ int limit) + (sourceClientEnv source) + let remoteHeight = _cutHashesHeight remoteCut + unless (remoteHeight > curHeight) + $ throwIO + $ userError "source cut made no progress during catch-up" + addCutHashes target $ remoteCut + { _cutOrigin = Just $ sourcePeerInfo source + } + awaitCutHeight target remoteHeight + go + +bench :: C.Benchmark +bench = withVersion benchmarkVersion + $ C.bgroup "cut-db" + [ variant "local" 0 + , variant "100ms latency" 100_000 + ] + where + variant :: HasVersion => String -> Int -> C.Benchmark + variant label latencyUs = C.envWithCleanup + (acquire $ sourceResource latencyUs) + release + $ \ ~(NoopNFData (source, _)) -> C.bench + (label <> ": catch up one " + <> show (int stepSize :: Int) + <> "-block step from genesis") + $ C.perRunEnvWithCleanup + (acquire $ targetResource latencyUs) + release + $ \ ~(NoopNFData (target, _)) -> catchUp source target diff --git a/bench/Chainweb/MempoolBench.hs b/bench/Chainweb/MempoolBench.hs index 9fdf8f3a1d..585c694b24 100644 --- a/bench/Chainweb/MempoolBench.hs +++ b/bench/Chainweb/MempoolBench.hs @@ -16,29 +16,37 @@ import PropertyMatchers ((?)) import Chainweb.BlockHash import Chainweb.BlockHeight import Chainweb.Graph (singletonChainGraph) -import Chainweb.Mempool.Mempool qualified as Mempool -import Chainweb.Mempool.InMem qualified as InMem -import Chainweb.Mempool.InMemTypes qualified as InMem -import Chainweb.Pact4.Transaction -import Chainweb.Test.Pact4.Utils +import Chainweb.Pact.Mempool.Mempool qualified as Mempool +import Chainweb.Pact.Mempool.InMem qualified as InMem +import Chainweb.Pact.Mempool.InMemTypes qualified as InMem +import Chainweb.Pact.Transaction import Chainweb.Test.TestVersions import Chainweb.Utils import Chainweb.Utils.Bench import Chainweb.Version -import Pact.Types.ChainMeta (getCurrentCreationTime) -import Pact.Types.Command import System.IO.Unsafe (unsafePerformIO) import qualified Data.Set as S import Data.IORef import Data.List (unfoldr) - -txCfg :: Mempool.TransactionConfig UnparsedTransaction -txCfg = Mempool.pact4TransactionConfig - -inmemCfg :: InMem.InMemConfig UnparsedTransaction +import Chainweb.Test.Pact.CmdBuilder +import Chainweb.Time (epoch) +import Chainweb.Pact.Utils (toTxCreationTime) +import Chainweb.PayloadProvider (EvaluationCtx(..)) +import Chainweb.Parent +import Chainweb.MinerReward +import Chainweb.BlockCreationTime +import Chainweb.ForkState (ForkNumber(..)) + +import Pact.Core.Command.Types +import qualified Pact.Core.Gas as Pact + +txCfg :: Mempool.TransactionConfig Transaction +txCfg = Mempool.pactTransactionConfig + +inmemCfg :: InMem.InMemConfig Transaction inmemCfg = InMem.InMemConfig { InMem._inmemTxCfg = txCfg - , InMem._inmemTxBlockSizeLimit = Mempool.GasLimit 150_000 + , InMem._inmemTxBlockSizeLimit = Mempool.GasLimit (Pact.Gas 150_000) , InMem._inmemTxMinGasPrice = Mempool.GasPrice (0.0000000001) , InMem._inmemMaxRecentItems = 2048 , InMem._inmemPreInsertPureChecks = return @@ -47,41 +55,40 @@ inmemCfg = InMem.InMemConfig } v :: ChainwebVersion -v = instantCpmTestVersion singletonChainGraph +v = instantCpmTestVersion False singletonChainGraph -setup :: V.Vector UnparsedTransaction -> IO (NoopNFData (Mempool.MempoolBackend UnparsedTransaction)) +setup :: V.Vector Transaction -> IO (NoopNFData (Mempool.MempoolBackend Transaction)) setup txs = do mp <- InMem.startInMemoryMempoolTest inmemCfg Mempool.mempoolInsert mp Mempool.UncheckedInsert txs return (NoopNFData mp) -cmds :: V.Vector UnparsedTransaction -cmds = unsafePerformIO $ V.generateM 4096 $ \i -> do - now <- getCurrentCreationTime - fmap unparseTransaction - $ buildCwCmd (sshow i) v - $ set cbCreationTime now - $ set cbGasLimit (Mempool.GasLimit 1) - $ defaultCmd +cmds :: V.Vector Transaction +cmds = withVersion v $ unsafePerformIO $ V.generateM 4096 $ \i -> do + buildCwCmd + $ set cbGasLimit (Mempool.GasLimit $ Pact.Gas 1) + $ set cbNonce (Just (sshow i)) + $ defaultCmd (unsafeChainId 0) -txHash :: UnparsedTransaction -> Mempool.TransactionHash +txHash :: Transaction -> Mempool.TransactionHash txHash = Mempool.txHasher txCfg -expiredCmds :: V.Vector UnparsedTransaction -expiredCmds = unsafePerformIO $ V.generateM 4096 $ \i -> do - fmap unparseTransaction - $ buildCwCmd (sshow i) v - $ set cbGasLimit (Mempool.GasLimit 1) - $ defaultCmd +expiredCmds :: V.Vector Transaction +expiredCmds = withVersion v $ unsafePerformIO $ V.generateM 4096 $ \i -> + buildCwCmd + $ set cbGasLimit (Mempool.GasLimit $ Pact.Gas 1) + $ set cbCreationTime (Just $ toTxCreationTime epoch) + $ set cbNonce (Just (sshow i)) + $ defaultCmd (unsafeChainId 0) -setupMakeTxs :: V.Vector UnparsedTransaction -> IO (NoopNFData (Mempool.MempoolBackend UnparsedTransaction, V.Vector UnparsedTransaction)) +setupMakeTxs :: V.Vector Transaction -> IO (NoopNFData (Mempool.MempoolBackend Transaction, V.Vector Transaction)) setupMakeTxs txs = do mp <- InMem.startInMemoryMempoolTest inmemCfg return $ NoopNFData (mp, txs) bfEmpty :: Mempool.BlockFill bfEmpty = Mempool.BlockFill - { Mempool._bfGasLimit = Mempool.GasLimit 150_000 + { Mempool._bfGasLimit = Mempool.GasLimit $ Pact.Gas 150_000 -- ^ Fetch pending transactions up to this limit. , Mempool._bfTxHashes = mempty -- ^ Fetch only transactions not in set. @@ -96,7 +103,8 @@ bfWithNHashes n = bfEmpty mempoolGetBlockBench :: _ => _ mempoolGetBlockBench name p bf n = C.bench name $ C.perRunEnv (setup (V.take n cmds)) $ \(NoopNFData mp) -> do - Mempool.mempoolGetBlock mp bf Mempool.noopMempoolPreBlockCheck (BlockHeight 1) nullBlockHash + Mempool.mempoolGetBlock mp bf Mempool.noopMempoolPreBlockCheck + (EvaluationCtx (Parent $ BlockCreationTime epoch) (Parent nullBlockHash) (Parent $ BlockHeight 0) (ForkNumber 0) (MinerReward 0) ()) >>= p allPendingTxHashes :: Mempool.MempoolBackend t -> IO [Mempool.TransactionHash] @@ -169,7 +177,7 @@ bench = C.bgroup "mempool" $ concat >>= P.alignExact (V.replicate 2000 (P.equals True)) ) $ \(NoopNFData ~(mp, txs)) -> do - Mempool.mempoolAddToBadList mp (Mempool.pact4RequestKeyToTransactionHash . cmdToRequestKey <$> txs) + Mempool.mempoolAddToBadList mp (Mempool.pactRequestKeyToTransactionHash . cmdToRequestKey <$> txs) , C.bench "mempoolPrune" $ C.perRunEnvWithCleanup (setup (V.take 2000 cmds)) (\(NoopNFData mp) -> diff --git a/bench/Chainweb/Pact/Backend/ApplyCmd.hs b/bench/Chainweb/Pact/Backend/ApplyCmd.hs index 58a6bfc80c..3f537b0f5e 100644 --- a/bench/Chainweb/Pact/Backend/ApplyCmd.hs +++ b/bench/Chainweb/Pact/Backend/ApplyCmd.hs @@ -29,173 +29,109 @@ import Chainweb.BlockHeaderDB (BlockHeaderDb) import Chainweb.Graph (singletonChainGraph) import Chainweb.Logger import Chainweb.Miner.Pact (noMiner) -import Chainweb.Pact.Backend.Utils (openSQLiteConnection, closeSQLiteConnection, chainwebPragmas) -import Chainweb.Pact.PactService (initialPayloadState, withPactService) -import Chainweb.Pact.PactService.Checkpointer (readFrom, SomeBlockM(..)) +import Chainweb.Pact.PactService (withPactService) +import Chainweb.Pact.PactService.Checkpointer (readFrom) import Chainweb.Pact.Types -import Chainweb.Pact4.Backend.ChainwebPactDb qualified as Pact4 -import Chainweb.Pact4.Transaction qualified as Pact4 -import Chainweb.Pact4.TransactionExec qualified as Pact4 -import Chainweb.Pact4.Types qualified as Pact4 -import Chainweb.Pact5.Transaction -import Chainweb.Pact5.TransactionExec qualified as Pact5 -import Chainweb.Pact5.Types qualified as Pact5 +import Chainweb.Pact.Transaction +import Chainweb.Pact.TransactionExec qualified as Pact5 +import Chainweb.Pact.Types qualified as Pact5 import Chainweb.Storage.Table.RocksDB -import Chainweb.Test.Cut.TestBlockDb (TestBlockDb(..), mkTestBlockDbIO) -import Chainweb.Test.Pact4.Utils qualified as Pact4 -import Chainweb.Test.Pact5.CmdBuilder qualified as Pact5 +import Chainweb.Test.Cut.TestBlockDb (TestBlockDb(..), mkTestBlockDb) +import Chainweb.Test.Pact.CmdBuilder qualified as Pact5 import Chainweb.Test.TestVersions -import Chainweb.Utils (T2(..), T3(..)) import Chainweb.Utils.Bench -import Chainweb.Pact.Backend.Types (SQLiteEnv) +import Chainweb.Pact.Backend.Types (SQLiteEnv, BlockHandle, throwIfNoHistory) import Chainweb.Version import Chainweb.WebBlockHeaderDB (getWebBlockHeaderDb) -import Control.Concurrent (ThreadId, forkIO, throwTo) -import Control.Concurrent.MVar (newEmptyMVar, putMVar, readMVar) import Control.DeepSeq -import Control.Exception (AsyncException(..)) import Control.Lens hiding (only) -import Control.Monad (void) import Control.Monad.IO.Class -import Control.Monad.Reader import Criterion.Main qualified as C import Data.ByteString (ByteString) -import Data.Functor.Product import Pact.Core.Command.Types qualified as Pact5 import Pact.Core.Errors qualified as Pact5 import Pact.Core.Evaluate qualified as Pact5 import Pact.Core.Gas.Types qualified as Pact5 import Pact.Core.Persistence qualified as Pact5 -import Pact.Core.SPV qualified as Pact5 -import Pact.Types.Command qualified as Pact4 -import Pact.Types.Gas qualified as Pact4 -import Pact.Types.Runtime qualified as Pact4 -import Pact.Types.SPV qualified as Pact4 +import Control.Monad.State.Strict +import Chainweb.Test.Utils (withTempChainSqlite) +import qualified Control.Monad.Trans.Resource as ResourceT +import Data.IORef +import Chainweb.Parent +import Chainweb.Time +import Chainweb.BlockCreationTime bench :: RocksDb -> C.Benchmark bench rdb = C.bgroup "applyCmd" - [ C.bench "Pact5" $ benchApplyCmd pact5Version rdb (SomeBlockM $ Pair (error "Pact4") applyCmd5) - , C.bench "Pact4" $ benchApplyCmd pact4Version rdb (SomeBlockM $ Pair applyCmd4 (error "Pact5")) + [ C.bench "Pact5" $ withVersion pact5Version $ benchApplyCmd rdb applyCmd ] data Env = Env { sqlite :: !SQLiteEnv , testBlockDb :: !TestBlockDb - , testBlockDbRocksDb :: !RocksDb , blockHeaderDb :: !BlockHeaderDb , logger :: !GenericLogger - , pactServiceThreadId :: !ThreadId - , pactServiceEnv :: !(PactServiceEnv GenericLogger RocksDbTable) + , pactServiceEnv :: !(ServiceEnv RocksDbTable) } instance NFData Env where rnf !_ = () -benchApplyCmd :: ChainwebVersion -> RocksDb -> SomeBlockM GenericLogger RocksDbTable a -> C.Benchmarkable -benchApplyCmd ver rdb act = - let setupEnv _ = do - sql <- openSQLiteConnection "" chainwebPragmas - T2 tdb tdbRdb <- mkTestBlockDbIO ver rdb +benchApplyCmd :: HasVersion => RocksDb -> (BlockEnv -> BlockHandle -> IO a) -> C.Benchmarkable +benchApplyCmd rdb act = + let setupEnv _ = ResourceT.runResourceT $ do + (sql, sqlPool) <- withTempChainSqlite chain0 + tdb <- mkTestBlockDb rdb bhdb <- getWebBlockHeaderDb (_bdbWebBlockHeaderDb tdb) chain0 - lgr <- testLogger + lgr <- liftIO testLogger - psEnvVar <- newEmptyMVar - tid <- forkIO $ void $ withPactService ver chain0 lgr Nothing bhdb (_bdbPayloadDb tdb) sql testPactServiceConfig $ do - initialPayloadState ver chain0 - psEnv <- ask - liftIO $ putMVar psEnvVar psEnv - psEnv <- readMVar psEnvVar + serviceEnv <- withPactService chain0 Nothing mempty lgr Nothing (_bdbPayloadDb tdb) sqlPool sql defaultPactServiceConfig GeneratingGenesis - pure $ Env + sRef <- ResourceT.getInternalState + s <- liftIO $ readIORef sRef + liftIO $ writeIORef sRef =<< readIORef =<< ResourceT.createInternalState + pure $ (Env { sqlite = sql , testBlockDb = tdb - , testBlockDbRocksDb = tdbRdb , blockHeaderDb = bhdb , logger = lgr - , pactServiceThreadId = tid - , pactServiceEnv = psEnv - } - - cleanupEnv _ env = do - closeSQLiteConnection env.sqlite - throwTo env.pactServiceThreadId ThreadKilled - deleteNamespaceRocksDb env.testBlockDbRocksDb + , pactServiceEnv = serviceEnv + }, NoopNFData s) + + cleanupEnv _ (_, NoopNFData s) = ResourceT.closeInternalState =<< newIORef s in - C.perBatchEnvWithCleanup setupEnv cleanupEnv $ \ ~env -> do - T2 a _finalPactState <- runPactServiceM (PactServiceState mempty) env.pactServiceEnv $ do - throwIfNoHistory =<< - readFrom - (Just $ ParentHeader (gh ver chain0)) - act + C.perBatchEnvWithCleanup setupEnv cleanupEnv $ \ ~(env, _) -> do + a <- do + (throwIfNoHistory =<<) $ readFrom + env.logger chain0 env.sqlite + (Parent $ BlockCreationTime epoch) (Parent (view rankedBlockHash $ gh chain0)) + act return (NoopNFData a) -applyCmd4 :: Pact4.PactBlockM GenericLogger RocksDbTable (Pact4.CommandResult [Pact4.TxLogJson]) --(CommandResult [TxLog ByteString] (PactError Info)) -applyCmd4 = do - lgr <- view (psServiceEnv . psLogger) - let txCtx = Pact4.TxContext - { Pact4._tcParentHeader = ParentHeader (gh pact4Version chain0) - , Pact4._tcPublicMeta = Pact4.noPublicMeta - , Pact4._tcMiner = noMiner - } - let gasModel = Pact4.getGasModel txCtx - pactDbEnv <- view (psBlockDbEnv . Pact4.cpPactDbEnv) - - cmd <- liftIO $ Pact4.buildCwCmd "fakeNonce" pact4Version - $ set Pact4.cbSigners - [ Pact4.mkEd25519Signer' Pact4.sender00 [] - ] - $ set Pact4.cbChainId chain0 - $ set Pact4.cbRPC (Pact4.mkExec' "(fold + 0 [1 2 3 4 5])") - $ Pact4.defaultCmd - - T3 cmdResult _moduleCache _warnings <- liftIO $ - Pact4.applyCmd - pact4Version - lgr - Nothing - Nothing - pactDbEnv - noMiner - gasModel - txCtx - (TxBlockIdx 0) - Pact4.noSPVSupport - (fmap Pact4.payloadObj cmd) - (Pact4.Gas 1) - mempty -- module cache - ApplySend - - pure cmdResult -{-# noinline applyCmd4 #-} - -applyCmd5 :: Pact5.PactBlockM GenericLogger RocksDbTable (Pact5.CommandResult [Pact5.TxLog ByteString] (Pact5.PactError Pact5.Info)) -applyCmd5 = do - cmd <- liftIO $ Pact5.buildCwCmd pact5Version (Pact5.defaultCmd chain0) +applyCmd :: HasVersion => BlockEnv -> BlockHandle -> IO (Pact5.CommandResult [Pact5.TxLog ByteString] (Pact5.PactError Pact5.Info)) +applyCmd bEnv bHandle = do + cmd <- liftIO $ Pact5.buildCwCmd (Pact5.defaultCmd chain0) { Pact5._cbRPC = Pact5.mkExec' "(fold + 0 [1 2 3 4 5])" , Pact5._cbGasPrice = Pact5.GasPrice 2 , Pact5._cbGasLimit = Pact5.GasLimit (Pact5.Gas 500) -- no caps should be equivalent to the GAS cap , Pact5._cbSigners = [Pact5.mkEd25519Signer' Pact5.sender00 []] } - lgr <- view (psServiceEnv . psLogger) - let txCtx = Pact5.TxContext {Pact5._tcParentHeader = ParentHeader (gh pact5Version chain0), Pact5._tcMiner = noMiner} + lgr <- testLogger - Pact5.pactTransaction Nothing $ \pactDb -> do - r <- Pact5.applyCmd lgr Nothing pactDb txCtx (TxBlockIdx 0) Pact5.noSPVSupport (Pact5.Gas 1) (view payloadObj <$> cmd) + flip evalStateT bHandle $ Pact5.doChainwebPactDbTransaction (bEnv ^. psBlockDbEnv) Nothing $ \pactDb spvSupport -> do + r <- Pact5.applyCmd lgr Nothing pactDb noMiner (_psBlockCtx bEnv) (TxBlockIdx 0) spvSupport (Pact5.Gas 1) (view payloadObj <$> cmd) case r of Left err -> error $ show err Right a -> pure a -{-# noinline applyCmd5 #-} +{-# noinline applyCmd #-} chain0 :: ChainId chain0 = unsafeChainId 0 -gh :: ChainwebVersion -> ChainId -> BlockHeader +gh :: HasVersion => ChainId -> BlockHeader gh = genesisBlockHeader -pact4Version :: ChainwebVersion -pact4Version = instantCpmTestVersion singletonChainGraph - pact5Version :: ChainwebVersion -pact5Version = pact5InstantCpmTestVersion False singletonChainGraph +pact5Version = instantCpmTestVersion False singletonChainGraph diff --git a/bench/Chainweb/Pact/Backend/Bench.hs b/bench/Chainweb/Pact/Backend/Bench.hs index 7089000f8b..14774bb020 100644 --- a/bench/Chainweb/Pact/Backend/Bench.hs +++ b/bench/Chainweb/Pact/Backend/Bench.hs @@ -7,6 +7,7 @@ {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} +{-# LANGUAGE PartialTypeSignatures #-} module Chainweb.Pact.Backend.Bench ( bench ) @@ -61,7 +62,7 @@ import Chainweb.Test.TestVersions import Chainweb.Utils.Bench import Chainweb.Utils (sshow) import Chainweb.Version -import qualified Chainweb.Pact4.Backend.ChainwebPactDb as Pact4 +import qualified Chainweb.Pact4.Backend.ChainwebPactDb as Pact import qualified Pact.Types.Command as Pact testVer :: ChainwebVersion @@ -73,7 +74,8 @@ testChainId = unsafeChainId 0 -- allowing a straightforward list of blocks to be passed to the API, -- and only exposing the PactDbEnv part of the block context cpRestoreAndSave - :: (Monoid q, Logger logger) + :: HasVersion + => (Monoid q, Logger logger) => Checkpointer logger -> Maybe BlockHeader -> [(BlockHeader, PactDbEnv (Pact4.BlockEnv logger) -> IO q)] @@ -82,13 +84,13 @@ cpRestoreAndSave cp pc blks = snd <$> restoreAndSave cp (ParentHeader <$> pc) (traverse Stream.yield [Pact4RunnableBlock $ \dbEnv _ -> (,bh) <$> fun (Pact4._cpPactDbEnv dbEnv) | (bh, fun) <- blks]) -- | fabricate a `BlockHeader` for a block given its hash and its parent. -childOf :: Maybe BlockHeader -> BlockHash -> BlockHeader +childOf :: HasVersion => Maybe BlockHeader -> BlockHash -> BlockHeader childOf m bhsh = case m of Just bh -> bh & blockHash .~ bhsh & blockParent .~ view blockHash bh & blockHeight .~ view blockHeight bh + 1 - Nothing -> genesisBlockHeader testVer testChainId + Nothing -> genesisBlockHeader testChainId & blockHash .~ bhsh bench :: C.Benchmark @@ -139,21 +141,23 @@ pactSqliteWithBench unsafe benchtorun = benchtorun dbEnv ] -cpWithBench :: forall logger. (Logger logger, logger ~ GenericLogger) +cpWithBench + :: forall logger. (Logger logger, logger ~ GenericLogger) => (Checkpointer logger -> C.Benchmark) -> C.Benchmark -cpWithBench torun = +cpWithBench torun = withVersion testVer $ C.envWithCleanup setup teardown $ \ ~(NoopNFData (_,e)) -> C.bgroup name (benches e) where name = "batchedCheckpointer" + setup :: HasVersion => IO (NoopNFData (SQLiteEnv, Checkpointer GenericLogger)) setup = do let dbFile = "" {- temporary SQLite db -} let neverLogger = genericLogger Error (\_ -> return ()) !sqliteEnv <- openSQLiteConnection dbFile chainwebPragmas !cenv <- - initCheckpointerResources defaultModuleCacheLimit sqliteEnv DoNotPersistIntraBlockWrites neverLogger testVer testChainId + initCheckpointerResources defaultModuleCacheLimit sqliteEnv DoNotPersistIntraBlockWrites neverLogger testChainId return $ NoopNFData (sqliteEnv, cenv) teardown (NoopNFData (sqliteEnv, _cenv)) = closeSQLiteConnection sqliteEnv @@ -163,14 +167,16 @@ cpWithBench torun = [ torun cpenv ] cpBenchNoRewindOverBlock :: Logger logger => Int -> Checkpointer logger -> C.Benchmark -cpBenchNoRewindOverBlock transactionCount cp = C.env setup' $ \ ~ut -> +cpBenchNoRewindOverBlock transactionCount cp = withVersion testVer $ C.env setup' $ \ ~ut -> C.bench name $ C.nfIO $ do mv <- newMVar (initbytestring, pc01) go mv ut where name = "noRewind/transactionCount=" ++ show transactionCount + pc01 :: HasVersion => BlockHeader pc01 = childOf Nothing hash01 + setup' :: HasVersion => IO (NoopNFData (Domain RowKey RowData)) setup' = do [usertablename] <- cpRestoreAndSave cp Nothing [(pc01, \db -> fmap (:[]) $ setupUserTable db $ \ut -> writeRow db Insert ut f k 1)] @@ -191,6 +197,9 @@ cpBenchNoRewindOverBlock transactionCount cp = C.env setup' $ \ ~ut -> where inc = B8.replicate 30 '\NUL' <> "\SOH\NUL" + go + :: HasVersion + => MVar (B8.ByteString, BlockHeader) -> NoopNFData (Domain RowKey RowData) -> IO () go mblock (NoopNFData ut) = do (bytestring, pc) <- readMVar mblock let (bytestring', hash') = nextHash bytestring @@ -205,10 +214,11 @@ cpBenchNoRewindOverBlock transactionCount cp = C.env setup' $ \ ~ut -> transaction db = incIntegerAtKey db ut f k 1 cpBenchOverBlock :: Logger logger => Int -> Checkpointer logger -> C.Benchmark -cpBenchOverBlock transactionCount cp = C.env setup' $ \ ~(ut) -> +cpBenchOverBlock transactionCount cp = withVersion testVer $ C.env setup' $ \ ~(ut) -> C.bench benchname $ C.nfIO (go ut) where benchname = "overBlock/transactionCount=" ++ show transactionCount + setup' :: HasVersion => IO (NoopNFData (Domain RowKey RowData)) setup' = do [usertablename] <- cpRestoreAndSave cp Nothing [(pc01, \db -> fmap (:[]) $ setupUserTable db $ \ut -> writeRow db Insert ut f k 1 @@ -220,9 +230,12 @@ cpBenchOverBlock transactionCount cp = C.env setup' $ \ ~(ut) -> hash01 = BlockHash $ unsafeMerkleLogHash "0000000000000000000000000000001a" hash02 = BlockHash $ unsafeMerkleLogHash "0000000000000000000000000000002a" + pc01 :: HasVersion => BlockHeader pc01 = childOf Nothing hash01 + pc02 :: HasVersion => BlockHeader pc02 = childOf (Just pc01) hash02 + go :: HasVersion => NoopNFData (Domain RowKey RowData) -> IO () go (NoopNFData ut) = do cpRestoreAndSave cp (Just pc01) [(pc02, \pactdbenv -> @@ -338,7 +351,7 @@ benchUserTableForKeys numSampleEvents dbEnv = writeRow db Update ut f rowkeyb a -_cpBenchKeys :: Logger logger => Int -> Checkpointer logger -> C.Benchmark +_cpBenchKeys :: HasVersion => Logger logger => Int -> Checkpointer logger -> C.Benchmark _cpBenchKeys numKeys cp = C.env setup' $ \ ~(ut) -> C.bench name $ C.nfIO (go ut) where @@ -372,12 +385,13 @@ _cpBenchKeys numKeys cp = incIntegerAtKey db ut f rowkey 1 cpBenchSampleKeys :: Logger logger => Int -> Checkpointer logger -> C.Benchmark -cpBenchSampleKeys numSampleEvents cp = +cpBenchSampleKeys numSampleEvents cp = withVersion testVer $ C.env setup' $ \ ~(ut) -> C.bench name $ C.nfIO (go ut) where name = "user-table-keys/sampleEvents=" ++ show numSampleEvents numberOfKeys :: Integer numberOfKeys = 10 + setup' :: HasVersion => IO (NoopNFData (Domain RowKey RowData)) setup' = do [usertablename] <- cpRestoreAndSave cp Nothing [(pc01, \db -> @@ -398,11 +412,14 @@ cpBenchSampleKeys numSampleEvents cp = hash01 = BlockHash $ unsafeMerkleLogHash "0000000000000000000000000000001a" hash02 = BlockHash $ unsafeMerkleLogHash "0000000000000000000000000000002a" + pc01 :: HasVersion => BlockHeader pc01 = childOf Nothing hash01 + pc02 :: HasVersion => BlockHeader pc02 = childOf (Just pc01) hash02 f = "f" + go :: HasVersion => NoopNFData (Domain RowKey RowData) -> IO () go (NoopNFData ut) = do cpRestoreAndSave cp (Just pc01) [(pc02, \db@(PactDbEnv pdb e) -> @@ -418,11 +435,12 @@ cpBenchSampleKeys numSampleEvents cp = cpBenchLookupProcessedTx :: Logger logger => Int -> Checkpointer logger -> C.Benchmark -cpBenchLookupProcessedTx transactionCount cp = C.env setup' $ \ ~(ut) -> +cpBenchLookupProcessedTx transactionCount cp = withVersion testVer $ C.env setup' $ \ ~(ut) -> C.bench benchname $ C.nfIO (go ut) where benchname = "lookupProcessedTx/transactionCount=" ++ show transactionCount transaction (NoopNFData ut) db = incIntegerAtKey db ut f k 1 + setup' :: HasVersion => IO (NoopNFData (Domain RowKey RowData)) setup' = do [usertablename] <- cpRestoreAndSave cp Nothing [(pc01, \db -> @@ -441,9 +459,12 @@ cpBenchLookupProcessedTx transactionCount cp = C.env setup' $ \ ~(ut) -> hash01 = BlockHash $ unsafeMerkleLogHash "0000000000000000000000000000001a" hash02 = BlockHash $ unsafeMerkleLogHash "0000000000000000000000000000002a" + pc01 :: HasVersion => BlockHeader pc01 = childOf Nothing hash01 + pc02 :: HasVersion => BlockHeader pc02 = childOf (Just pc01) hash02 + go :: HasVersion => _ go (NoopNFData _) = do readFrom cp (Just (ParentHeader pc02)) Pact4T $ \dbEnv _ -> Pact4._cpLookupProcessedTx dbEnv (V.fromList [Pact.RequestKey (Pact.toUntypedHash $ Pact.TypedHash "") | _ <- [1..transactionCount]]) diff --git a/bench/Chainweb/Pact/Backend/ForkingBench.hs b/bench/Chainweb/Pact/Backend/ForkingBench.hs index 69b1f7b3da..c2e340560b 100644 --- a/bench/Chainweb/Pact/Backend/ForkingBench.hs +++ b/bench/Chainweb/Pact/Backend/ForkingBench.hs @@ -28,7 +28,7 @@ import Chainweb.BlockHeaderDB.Internal import Chainweb.ChainId import Chainweb.Graph import Chainweb.Logger -import Chainweb.Mempool.Mempool +import Chainweb.Pact.Mempool.Mempool import Chainweb.Miner.Pact import Chainweb.Pact.Backend.Types import Chainweb.Pact.Backend.Utils @@ -37,10 +37,10 @@ import Chainweb.Pact.Service.BlockValidation import Chainweb.Pact.Service.PactQueue import Chainweb.Pact.Types import Chainweb.Pact.Utils (toTxCreationTime) -import Chainweb.Pact4.Transaction qualified as Pact4 -import Chainweb.Payload -import Chainweb.Payload.PayloadStore -import Chainweb.Payload.PayloadStore.InMemory +import Chainweb.Pact.Transaction qualified as Pact +import Chainweb.Pact.Payload +import Chainweb.Pact.Payload.PayloadStore +import Chainweb.Pact.Payload.PayloadStore.InMemory import Chainweb.Storage.Table.HashMap hiding (toList) import Chainweb.Storage.Table.RocksDB import Chainweb.Test.TestVersions (slowForkingCpmTestVersion) @@ -103,13 +103,15 @@ bench rdb = C.bgroup "ForkingBench" $ , doubleForkingBench ] where - forkingBench = withResources rdb 10 Quiet PersistIntraBlockWrites + forkingBench = withVersion testVer + $ withResources rdb 10 Quiet PersistIntraBlockWrites $ \mainLineBlocks pdb bhdb nonceCounter pactQueue _ -> C.bench "forkingBench" $ C.whnfIO $ do let (T3 _ join1 _) = mainLineBlocks !! 5 void $ playLine pdb bhdb 5 join1 pactQueue nonceCounter - doubleForkingBench = withResources rdb 10 Quiet PersistIntraBlockWrites + doubleForkingBench = withVersion testVer + $ withResources rdb 10 Quiet PersistIntraBlockWrites $ \mainLineBlocks pdb bhdb nonceCounter pactQueue _ -> C.bench "doubleForkingBench" $ C.whnfIO $ do let (T3 _ join1 _) = mainLineBlocks !! 5 @@ -122,7 +124,8 @@ bench rdb = C.bgroup "ForkingBench" $ -- Benchmark Function playLine - :: PayloadDb HashMapTable + :: HasVersion + => PayloadDb HashMapTable -> BlockHeaderDb -> Word64 -> BlockHeader @@ -149,7 +152,8 @@ playLine pdb bhdb trunkLength startingBlock pactQueue counter = do return ret mineBlock - :: ParentHeader + :: HasVersion + => ParentHeader -> Nonce -> PayloadDb HashMapTable -> BlockHeaderDb @@ -163,7 +167,8 @@ mineBlock parent nonce pdb bhdb pact = do return r createBlock - :: ParentHeader + :: HasVersion + => ParentHeader -> Nonce -> PactQueue -> IO (T3 ParentHeader BlockHeader PayloadWithOutputs) @@ -210,19 +215,20 @@ type RunPactService = -> IORef Int -> C.Benchmark -withResources :: () +withResources + :: HasVersion => RocksDb -> Word64 -> LogLevel - -> IntraBlockPersistence -> RunPactService -> C.Benchmark -withResources rdb trunkLength logLevel p f = C.envWithCleanup create destroy unwrap +withResources rdb trunkLength logLevel f = C.envWithCleanup create destroy unwrap where unwrap ~(NoopNFData (Resources {..})) = f mainTrunkBlocks payloadDb blockHeaderDb nonceCounter (snd pactService) txPerBlock + create :: HasVersion => _ create = do payloadDb <- createPayloadDb blockHeaderDb <- testBlockHeaderDb @@ -233,7 +239,7 @@ withResources rdb trunkLength logLevel p f = C.envWithCleanup create destroy unw (sqlEnv, pactService, mainTrunkBlocks) <- do sqlEnv <- openSQLiteConnection "" {- temporary SQLite db -} chainwebBenchPragmas pactService <- - startPact testVer logger blockHeaderDb payloadDb mp sqlEnv + startPact logger blockHeaderDb payloadDb mp sqlEnv mainTrunkBlocks <- playLine payloadDb blockHeaderDb trunkLength genesisBlock (snd pactService) nonceCounter pure (sqlEnv, pactService, mainTrunkBlocks) @@ -248,9 +254,15 @@ withResources rdb trunkLength logLevel p f = C.envWithCleanup create destroy unw logger = genericLogger logLevel T.putStrLn - startPact version l bhdb pdb mempool sqlEnv = do + startPact l bhdb pdb mempool sqlEnv = do reqQ <- newPactQueue pactQueueSize - a <- async $ runPactService version cid l Nothing reqQ mempool bhdb pdb sqlEnv testPactServiceConfig +-- <<<<<<< Conflict 1 of 1 +-- +++++++ Contents of side #1 +-- a <- async $ runPactService version cid l Nothing reqQ mempool bhdb pdb sqlEnv defaultPactServiceConfig +-- %%%%%%% Changes from base to side #2 +-- - a <- async $ runPactService version cid l Nothing reqQ mempool bhdb pdb sqlEnv testPactServiceConfig +-- + a <- async $ runPactService someChainId l Nothing reqQ mempool bhdb pdb sqlEnv testPactServiceConfig +-- >>>>>>> Conflict 1 of 1 ends { _pactNewBlockGasLimit = 180_000 , _pactPersistIntraBlockWrites = p } @@ -270,7 +282,7 @@ withResources rdb trunkLength logLevel p f = C.envWithCleanup create destroy unw ] genesisBlock :: BlockHeader - genesisBlock = genesisBlockHeader testVer cid + genesisBlock = genesisBlockHeader someChainId -- | Creates an in-memory Payload database that is managed by the garbage -- collector. @@ -290,7 +302,7 @@ withResources rdb trunkLength logLevel p f = C.envWithCleanup create destroy unw -- | Mempool Access -- -testMemPoolAccess :: IORef Int -> MVar (Map Account (NonEmpty (DynKeyPair, [SigCapability]))) -> IO MemPoolAccess +testMemPoolAccess :: HasVersion => IORef Int -> MVar (Map Account (NonEmpty (DynKeyPair, [SigCapability]))) -> IO MemPoolAccess testMemPoolAccess txsPerBlock accounts = do return $ mempty { mpaGetBlock = \bf validate bh hash bct -> do @@ -302,10 +314,10 @@ testMemPoolAccess txsPerBlock accounts = do setTime time pb = pb { _pmCreationTime = toTxCreationTime time } - getTestBlock :: _ -> _ -> MempoolPreBlockCheck Pact4.UnparsedTransaction to -> _ -> _ -> IO (V.Vector to) + getTestBlock :: HasVersion => _ -> _ -> MempoolPreBlockCheck Pact4.UnparsedTransaction to -> _ -> _ -> IO (V.Vector to) getTestBlock mVarAccounts txOrigTime validate bHeight hash | bHeight == 1 = do - meta <- setTime txOrigTime <$> makeMeta cid + meta <- setTime txOrigTime <$> makeMeta someChainId (as, kss, cmds) <- unzip3 . toList <$> createCoinAccounts testVer meta case traverse validateCommand cmds of Left err -> throwM $ userError err @@ -325,7 +337,7 @@ testMemPoolAccess txsPerBlock accounts = do txs <- forM coinReqs $ \req@(TransferRequest (SenderName sn) rcvr amt) -> do let (Account sender, ks) = mkTransferCaps rcvr amt (sn, fromJuste $ M.lookup sn accs) - meta <- setTime txOrigTime <$> makeMetaWithSender sender cid + meta <- setTime txOrigTime <$> makeMetaWithSender sender someChainId eCmd <- validateCommand <$> createTransfer testVer meta ks req case eCmd of Left e -> throwM $ userError e @@ -347,9 +359,6 @@ testMemPoolAccess txsPerBlock accounts = do -- -------------------------------------------------------------------------- -- -- Utils -cid :: ChainId -cid = someChainId testVer - testVer :: ChainwebVersion testVer = slowForkingCpmTestVersion petersenChainGraph diff --git a/bench/Chainweb/Pact/Backend/PactService.hs b/bench/Chainweb/Pact/Backend/PactService.hs index 6818e5d1bc..6eb87106fd 100644 --- a/bench/Chainweb/Pact/Backend/PactService.hs +++ b/bench/Chainweb/Pact/Backend/PactService.hs @@ -1,35 +1,33 @@ -{-# language - BangPatterns - , DataKinds - , FlexibleContexts - , ImpredicativeTypes - , ImportQualifiedPost - , LambdaCase - , NumericUnderscores - , OverloadedRecordDot - , OverloadedStrings - , PackageImports - , ScopedTypeVariables - , TypeApplications - , TemplateHaskell - , RecordWildCards - , TupleSections -#-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE ImpredicativeTypes #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NumericUnderscores #-} +{-# LANGUAGE OverloadedRecordDot #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PackageImports #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeApplications #-} {-# options_ghc -fno-warn-orphans #-} module Chainweb.Pact.Backend.PactService - ( bench - ) where +( bench +) where import Chainweb.BlockHeader import Chainweb.ChainId import Chainweb.Chainweb import Chainweb.Cut import Chainweb.Graph (singletonChainGraph) -import Chainweb.Mempool.Consensus -import Chainweb.Mempool.InMem -import Chainweb.Mempool.Mempool (InsertType (..), MempoolBackend (..)) +import Chainweb.Pact.Mempool.Consensus +import Chainweb.Pact.Mempool.InMem +import Chainweb.Pact.Mempool.Mempool (InsertType (..), MempoolBackend (..)) import Chainweb.Miner.Pact import Chainweb.Pact.Backend.Types (SQLiteEnv) import Chainweb.Pact.Backend.Utils (openSQLiteConnection, closeSQLiteConnection, chainwebPragmas) @@ -39,12 +37,12 @@ import Chainweb.Pact.Service.BlockValidation import Chainweb.Pact.Service.PactInProcApi import Chainweb.Pact.Service.PactQueue import Chainweb.Pact.Types -import Chainweb.Pact4.Transaction qualified as Pact4 -import Chainweb.Payload +import Chainweb.Pact.Transaction qualified as Pact +import Chainweb.Pact.Payload import Chainweb.Storage.Table.RocksDB import Chainweb.Test.Cut.TestBlockDb (TestBlockDb(..), addTestBlockDb, getCutTestBlockDb, setCutTestBlockDb, getParentTestBlockDb, mkTestBlockDbIO) -import Chainweb.Test.Pact5.CmdBuilder -import Chainweb.Test.Pact5.Utils hiding (withTempSQLiteResource) +import Chainweb.Test.Pact.CmdBuilder +import Chainweb.Test.Pact.Utils hiding (withTempSQLiteResource) import Chainweb.Test.TestVersions import Chainweb.Test.Utils import Chainweb.Time @@ -73,7 +71,7 @@ import Pact.Core.Capabilities import Pact.Core.Gas.Types import Pact.Core.Names import Pact.Core.PactValue -import Pact.Types.Gas qualified as Pact4 +import Pact.Types.Gas qualified as Pact import PropertyMatchers qualified as P import Test.Tasty.HUnit (assertEqual) import Text.Printf (printf) @@ -82,39 +80,38 @@ bench :: RocksDb -> C.Benchmark bench rdb = do C.bgroup "PactService" [ C.bgroup "Pact4" - [ C.bench "1 tx" $ oneBlock pact4Version rdb 1 - , C.bench "10 txs" $ oneBlock pact4Version rdb 10 - , C.bench "20 txs" $ oneBlock pact4Version rdb 20 - , C.bench "30 txs" $ oneBlock pact4Version rdb 30 - , C.bench "40 txs" $ oneBlock pact4Version rdb 40 - , C.bench "50 txs" $ oneBlock pact4Version rdb 50 - , C.bench "60 txs" $ oneBlock pact4Version rdb 60 - , C.bench "70 txs" $ oneBlock pact4Version rdb 70 - , C.bench "80 txs" $ oneBlock pact4Version rdb 80 - , C.bench "90 txs" $ oneBlock pact4Version rdb 90 - , C.bench "100 txs" $ oneBlock pact4Version rdb 100 + [ C.bench "1 tx" $ withVersion pact4Version oneBlock rdb 1 + , C.bench "10 txs" $ withVersion pact4Version oneBlock rdb 10 + , C.bench "20 txs" $ withVersion pact4Version oneBlock rdb 20 + , C.bench "30 txs" $ withVersion pact4Version oneBlock rdb 30 + , C.bench "40 txs" $ withVersion pact4Version oneBlock rdb 40 + , C.bench "50 txs" $ withVersion pact4Version oneBlock rdb 50 + , C.bench "60 txs" $ withVersion pact4Version oneBlock rdb 60 + , C.bench "70 txs" $ withVersion pact4Version oneBlock rdb 70 + , C.bench "80 txs" $ withVersion pact4Version oneBlock rdb 80 + , C.bench "90 txs" $ withVersion pact4Version oneBlock rdb 90 + , C.bench "100 txs" $ withVersion pact4Version oneBlock rdb 100 ] , C.bgroup "Pact5" - [ C.bench "1 tx" $ oneBlock pact5Version rdb 1 - , C.bench "10 txs" $ oneBlock pact5Version rdb 10 - , C.bench "20 txs" $ oneBlock pact5Version rdb 20 - , C.bench "30 txs" $ oneBlock pact5Version rdb 30 - , C.bench "40 txs" $ oneBlock pact5Version rdb 40 - , C.bench "50 txs" $ oneBlock pact5Version rdb 50 - , C.bench "60 txs" $ oneBlock pact5Version rdb 60 - , C.bench "70 txs" $ oneBlock pact5Version rdb 70 - , C.bench "80 txs" $ oneBlock pact5Version rdb 80 - , C.bench "90 txs" $ oneBlock pact5Version rdb 90 - , C.bench "100 txs" $ oneBlock pact5Version rdb 100 + [ C.bench "1 tx" $ withVersion pact5Version oneBlock rdb 1 + , C.bench "10 txs" $ withVersion pact5Version oneBlock rdb 10 + , C.bench "20 txs" $ withVersion pact5Version oneBlock rdb 20 + , C.bench "30 txs" $ withVersion pact5Version oneBlock rdb 30 + , C.bench "40 txs" $ withVersion pact5Version oneBlock rdb 40 + , C.bench "50 txs" $ withVersion pact5Version oneBlock rdb 50 + , C.bench "60 txs" $ withVersion pact5Version oneBlock rdb 60 + , C.bench "70 txs" $ withVersion pact5Version oneBlock rdb 70 + , C.bench "80 txs" $ withVersion pact5Version oneBlock rdb 80 + , C.bench "90 txs" $ withVersion pact5Version oneBlock rdb 90 + , C.bench "100 txs" $ withVersion pact5Version oneBlock rdb 100 ] ] data Fixture = Fixture - { _chainwebVersion :: !ChainwebVersion - , _fixtureBlockDb :: !TestBlockDb + { _fixtureBlockDb :: !TestBlockDb , _fixtureBlockDbRocksDb :: !RocksDb - , _fixtureMempools :: !(ChainMap (MempoolBackend Pact4.UnparsedTransaction)) - , _fixturePactQueues :: !(ChainMap PactQueue) + -- , _fixtureMempools :: !(ChainMap (MempoolBackend Pact4.UnparsedTransaction)) + -- , _fixturePactQueues :: !(ChainMap PactQueue) , _fixturePactServiceThreads :: !(ChainMap ThreadId) , _fixturePactServiceSqls :: !(ChainMap SQLiteEnv) } @@ -122,29 +119,28 @@ data Fixture = Fixture instance NFData Fixture where rnf !_ = () -createFixture :: ChainwebVersion -> RocksDb -> PactServiceConfig -> IO Fixture -createFixture v rdb pactServiceConfig = do - T2 tdb tdbRdb <- mkTestBlockDbIO v rdb +createFixture :: HasVersion => RocksDb -> PactServiceConfig -> IO Fixture +createFixture rdb pactServiceConfig = do + T2 tdb tdbRdb <- mkTestBlockDbIO rdb logger <- testLogger - perChain <- iforM (HashSet.toMap (chainIds v)) $ \chain () -> do + perChain <- iforM (HashSet.toMap chainIds) $ \chain () -> do sql <- openSQLiteConnection "" chainwebPragmas bhdb <- liftIO $ getWebBlockHeaderDb (_bdbWebBlockHeaderDb tdb) chain pactQueue <- liftIO $ newPactQueue 2_000 pactExecutionServiceVar <- liftIO $ newMVar (mkPactExecutionService pactQueue) - let mempoolCfg = validatingMempoolConfig chain v (Pact4.GasLimit 150_000) (Pact4.GasPrice 1e-8) pactExecutionServiceVar + let mempoolCfg = validatingMempoolConfig chain (Pact4.GasLimit 150_000) (Pact4.GasPrice 1e-8) pactExecutionServiceVar mempool <- liftIO $ startInMemoryMempoolTest mempoolCfg mempoolConsensus <- liftIO $ mkMempoolConsensus mempool bhdb (Just (_bdbPayloadDb tdb)) let mempoolAccess = pactMemPoolAccess mempoolConsensus logger - tid <- forkIO $ runPactService v chain logger Nothing pactQueue mempoolAccess bhdb (_bdbPayloadDb tdb) sql pactServiceConfig + tid <- forkIO $ runPactService chain logger Nothing pactQueue mempoolAccess bhdb (_bdbPayloadDb tdb) sql pactServiceConfig return (mempool, pactQueue, tid, sql) let fixture = Fixture - { _chainwebVersion = v - , _fixtureBlockDb = tdb + { _fixtureBlockDb = tdb , _fixtureBlockDbRocksDb = tdbRdb - , _fixtureMempools = OnChains $ view _1 <$> perChain - , _fixturePactQueues = OnChains $ view _2 <$> perChain + -- , _fixtureMempools = OnChains $ view _1 <$> perChain + -- , _fixturePactQueues = OnChains $ view _2 <$> perChain , _fixturePactServiceThreads = OnChains $ view _3 <$> perChain , _fixturePactServiceSqls = OnChains $ view _4 <$> perChain } @@ -163,15 +159,15 @@ destroyFixture fx = do closeSQLiteConnection sql deleteNamespaceRocksDb fx._fixtureBlockDbRocksDb -oneBlock :: ChainwebVersion -> RocksDb -> Word -> C.Benchmarkable -oneBlock v rdb numTxs = +oneBlock :: HasVersion => RocksDb -> Word -> C.Benchmarkable +oneBlock rdb numTxs = let cid = unsafeChainId 0 - cfg = testPactServiceConfig + cfg = defaultPactServiceConfig setupEnv _ = do - fx <- createFixture v rdb cfg + fx <- createFixture rdb cfg txs <- forM [1..numTxs] $ \_ -> do - buildCwCmd v (transferCmd cid 1.0) + buildCwCmd (transferCmd cid 1.0) return (fx, txs) cleanupEnv _ (fx, _) = do @@ -195,22 +191,23 @@ oneBlock v rdb numTxs = getCut :: Fixture -> IO Cut getCut Fixture{..} = getCutTestBlockDb _fixtureBlockDb -revert :: Fixture -> Cut -> IO () +revert :: HasVersion => Fixture -> Cut -> IO () revert Fixture{..} c = do setCutTestBlockDb _fixtureBlockDb c - forM_ (HashSet.toList (chainIds _chainwebVersion)) $ \chain -> do + forM_ (HashSet.toList chainIds) $ \chain -> do ph <- getParentTestBlockDb _fixtureBlockDb chain pactSyncToBlock ph (_fixturePactQueues ^?! atChain chain) -- this mines a block on *all chains*. if you don't specify a payload on a chain, -- it adds empty blocks! -advanceAllChains :: () +advanceAllChains + :: HasVersion => Fixture -> ChainMap (BlockHeader -> PactQueue -> MempoolBackend Pact4.UnparsedTransaction -> IO PayloadWithOutputs) -> IO (ChainMap (Vector TestPact5CommandResult)) advanceAllChains Fixture{..} blocks = do commandResults <- - forConcurrently (HashSet.toList (chainIds _chainwebVersion)) $ \c -> do + forConcurrently (HashSet.toList chainIds) $ \c -> do ph <- getParentTestBlockDb _fixtureBlockDb c creationTime <- getCurrentTimeIntegral let pactQueue = _fixturePactQueues ^?! atChain c @@ -263,7 +260,7 @@ transferCmd chain transferAmount = (defaultCmd chain) } pact4Version :: ChainwebVersion -pact4Version = instantCpmTestVersion singletonChainGraph +pact4Version = instantCpmTestVersion False singletonChainGraph pact5Version :: ChainwebVersion pact5Version = pact5InstantCpmTestVersion False singletonChainGraph diff --git a/bench/Chainweb/Utils/Bench.hs b/bench/Chainweb/Utils/Bench.hs index b4f9d4a2a3..5e3e6417f2 100644 --- a/bench/Chainweb/Utils/Bench.hs +++ b/bench/Chainweb/Utils/Bench.hs @@ -17,14 +17,13 @@ module Chainweb.Utils.Bench import Chainweb.Logger import Pact.Core.Errors import Chainweb.Test.Cut.TestBlockDb (TestBlockDb) -import Chainweb.Test.Pact5.Utils (getTestLogLevel) +import Chainweb.Test.Pact.Utils (getTestLogLevel) import Chainweb.Test.Utils () import Database.SQLite3.Direct (Database(..)) import Chainweb.WebBlockHeaderDB (WebBlockHeaderDb) -import Chainweb.Pact.Types (PactServiceEnv) +import Chainweb.Pact.Types (ServiceEnv) import Control.DeepSeq (NFData(..)) -import Chainweb.Mempool.Mempool (MempoolBackend) -import Chainweb.Pact.Service.PactQueue (PactQueue) +import Chainweb.Pact.Mempool.Mempool (MempoolBackend) import Control.Monad.IO.Class (liftIO) import Data.Text.IO qualified as Text @@ -49,7 +48,7 @@ instance NFData (NoopNFData a) where deriving newtype instance NFData Database -instance NFData (PactServiceEnv logger tbl) where +instance NFData (ServiceEnv tbl) where rnf !_ = () instance NFData WebBlockHeaderDb where @@ -61,9 +60,6 @@ instance NFData TestBlockDb where instance NFData (MempoolBackend a) where rnf !_ = () -instance NFData PactQueue where - rnf !_ = () - instance NFData LegacyPactErrorType where rnf !_ = () diff --git a/bench/JSONEncoding.hs b/bench/JSONEncoding.hs index f0c07c2732..53db7d078f 100644 --- a/bench/JSONEncoding.hs +++ b/bench/JSONEncoding.hs @@ -40,11 +40,12 @@ import Test.QuickCheck import Chainweb.BlockHash import Chainweb.BlockHeader import Chainweb.Chainweb.Configuration -import Chainweb.Payload +import Chainweb.Pact.Payload import Chainweb.RestAPI.NodeInfo import Chainweb.Test.Orphans.Internal import Chainweb.Utils.Paging import Chainweb.Version.Mainnet +import Chainweb.Version -- -------------------------------------------------------------------------- -- -- Main @@ -60,7 +61,7 @@ benchmarks = bgroup "JSONEncoding" , group "1000" (payloadPage 1000) , group "5000" (payloadPage 5000) ] - , bgroup "header page" + , withVersion mainnet $ bgroup "header page" [ group "5" (headerPage 5) , group "10" (headerPage 10) , group "50" (headerPage 50) @@ -69,7 +70,7 @@ benchmarks = bgroup "JSONEncoding" , group "1000" (headerPage 1000) , group "5000" (headerPage 5000) ] - , bgroup "object encoded header page" + , withVersion mainnet $ bgroup "object encoded header page" [ group "5" (objHeaderPage 5) , group "10" (objHeaderPage 10) , group "50" (objHeaderPage 50) @@ -140,11 +141,11 @@ config :: ChainwebConfiguration config = defaultChainwebConfiguration Mainnet01 {-# NOINLINE config #-} -headerPage :: Natural -> Page BlockHash BlockHeader +headerPage :: HasVersion => Natural -> Page BlockHash BlockHeader headerPage n = unsafePerformIO $ generate $ arbitraryPage n {-# NOINLINE headerPage #-} -objHeaderPage :: Natural -> Page BlockHash (ObjectEncoded BlockHeader) +objHeaderPage :: HasVersion => Natural -> Page BlockHash (ObjectEncoded BlockHeader) objHeaderPage n = pageItems %~ fmap ObjectEncoded $ unsafePerformIO $ generate $ arbitraryPage n {-# NOINLINE objHeaderPage #-} @@ -152,4 +153,3 @@ objHeaderPage n = pageItems %~ fmap ObjectEncoded $ unsafePerformIO payloadPage :: Natural -> Page BlockHash PayloadWithOutputs payloadPage n = unsafePerformIO $ generate $ arbitraryPage n {-# NOINLINE payloadPage #-} - diff --git a/cabal.project b/cabal.project index f5a73a451d..eac7d5a531 100644 --- a/cabal.project +++ b/cabal.project @@ -105,7 +105,7 @@ source-repository-package source-repository-package type: git location: https://github.com/kda-community/merkle-log - tag: c502176643de644dec624001096342b1f0cd0f45 + tag: 864f21c366afe2004c1b70f1a2e781b0ffa18e53 source-repository-package type: git @@ -131,6 +131,13 @@ source-repository-package tag: 65ea176c9ba5717dd8c208219e40095a3bf27466 --sha256: 04dqqkgqj4ydxn6xwxf852r1snzdwrz19iz5by6vpkyr2v691qvs + +source-repository-package + type: git + location: https://github.com/larskuhtz/hs-hashes.git + tag: 141ffcf37ae57472c148d47f334672681e9d7508 + --sha256: 1az7jcggcj275djnfsvhdg3n7hjrj6vp8rj137fxrg4hazh0hyz0 + -- Required for backward compatibility: -- ixset-typed add difference operator (https://github.com/well-typed/ixset-typed/pull/24) @@ -147,6 +154,11 @@ source-repository-package tag: 90247042ab3b8662809210af2a78e6dee0f9b4ac --sha256: 0dqsrjxm0cm35xcihm49dhwdvmz79vsv4sd5qs2izc4sbnd0d8n6 +source-repository-package + type: git + location: https://github.com/pcapriotti/optparse-applicative/ + tag: 7861d08b5d0ae542c82dfc109ca85e61745dc4eb + -- -------------------------------------------------------------------------- -- -- Relaxed Bounds diff --git a/cabal.project.freeze b/cabal.project.freeze deleted file mode 100644 index d75da4415f..0000000000 --- a/cabal.project.freeze +++ /dev/null @@ -1,537 +0,0 @@ -active-repositories: hackage.haskell.org:merge -constraints: any.Cabal ==3.12.1.0 || ==3.14.2.0, - any.Cabal-syntax ==3.12.1.0 || ==3.14.2.0, - any.Decimal ==0.5.2, - any.Diff ==1.0.2, - any.Glob ==0.10.2, - any.HUnit ==1.6.2.0, - any.JuicyPixels ==3.3.9, - JuicyPixels -mmap, - any.OneTuple ==0.4.3, - OneTuple +base-ge-4-15 +base-ge-4-16, - any.Only ==0.1, - any.QuickCheck ==2.18.0.0, - QuickCheck -old-random +templatehaskell, - any.SHA ==1.6.4.4, - SHA -exe, - any.StateVar ==1.2.2, - any.adjunctions ==4.4.4, - any.aeson ==2.2.5.1, - aeson +ordered-keymap, - any.aeson-pretty ==0.8.11, - aeson-pretty -lib-only, - any.alex ==3.5.4.2, - any.ansi-terminal ==1.1.5, - ansi-terminal -example, - any.ansi-terminal-types ==1.1.3, - any.ap-normalize ==0.1.0.1, - ap-normalize -test-with-clang, - any.appar ==0.1.8, - any.array ==0.5.8.0, - any.asciidoc ==0.1.1.1, - any.asn1-encoding ==0.9.6, - any.asn1-types ==0.3.4, - any.assoc ==1.1.1, - assoc -tagged, - any.async ==2.2.6, - async -bench -debug-auto-label, - any.atomic-primops ==0.8.8, - atomic-primops -debug, - any.attoparsec ==0.14.4, - attoparsec -developer, - any.attoparsec-aeson ==2.2.2.0, - any.auto-update ==0.2.8, - any.barbies ==2.1.1.0, - any.base ==4.20.2.0, - any.base-compat ==0.15.0, - any.base-compat-batteries ==0.15.0, - any.base-orphans ==0.9.4, - any.base-unicode-symbols ==0.2.4.2, - base-unicode-symbols +base-4-8 -old-base, - any.base16 ==1.0, - any.base16-bytestring ==1.0.2.0, - any.base64 ==2.0, - base64 -simd, - any.base64-bytestring ==1.2.1.0, - any.base64-bytestring-kadena ==0.1, - any.basement ==0.0.16, - any.bifunctors ==5.6.3, - bifunctors +tagged, - any.binary ==0.8.9.3, - any.binary-orphans ==1.0.6, - binary-orphans +base-ge-4-16 +base-ge-4-17, - any.bitvec ==1.1.6.0, - bitvec +simd, - any.blaze-builder ==0.4.4.1, - any.blaze-html ==0.9.2.0, - any.blaze-markup ==0.8.3.0, - any.boring ==0.2.2.1, - boring +tagged, - any.bound ==2.0.7, - bound +template-haskell, - any.bsb-http-chunked ==0.0.0.4, - any.bytebuild ==0.3.17.0, - bytebuild -checked, - any.byteorder ==1.0.4, - any.bytes ==0.17.5, - any.byteslice ==0.2.15.0, - byteslice +avoid-rawmemchr, - any.bytesmith ==0.3.14.0, - any.bytestring ==0.12.2.0, - any.bytestring-builder ==0.10.8.2.0, - bytestring-builder +bytestring_has_builder, - any.cabal-doctest ==1.0.13, - any.cache ==0.1.3.0, - any.call-stack ==0.4.0, - any.case-insensitive ==1.2.1.0, - any.cassava ==0.5.4.1, - any.cborg ==0.2.10.0, - cborg +optimize-gmp, - any.cereal ==0.5.8.3, - cereal -bytestring-builder, - chainweb -debug -ed25519 -ghc-flags, - chainweb-node -debug -ed25519 -ghc-flags, - any.character-ps ==0.1, - any.charset ==0.3.12, - any.chronos ==1.1.7.0, - any.citeproc ==0.14.1, - citeproc -executable -icu, - any.clock ==0.8.4, - clock -llvm, - any.cmdargs ==0.10.22, - cmdargs +quotation -testprog, - any.co-log-core ==0.3.2.7, - any.code-page ==0.2.1, - any.colour ==2.3.7, - any.commonmark ==0.3.1, - any.commonmark-extensions ==0.2.7.3, - any.commonmark-pandoc ==0.3.0.2, - any.comonad ==5.0.10, - comonad +containers +distributive +indexed-traversable, - any.concurrent-output ==1.10.21, - any.conduit ==1.3.6.1, - any.conduit-extra ==1.3.8, - any.configuration-tools ==0.7.1, - configuration-tools -remote-configs, - any.constraints ==0.14.4, - any.containers ==0.7, - any.contiguous ==0.6.4.2, - any.contravariant ==1.5.6, - contravariant +statevar, - any.cookie ==0.5.1, - any.criterion ==1.6.5.0, - criterion -embed-data-files -fast, - any.criterion-measurement ==0.2.5.0, - criterion-measurement -fast, - any.crypto-token ==0.2.0, - any.cryptohash-md5 ==0.11.101.0, - any.cryptohash-sha1 ==0.11.101.0, - any.crypton ==2.0.1, - crypton -check_alignment +integer-gmp -old_toolchain_inliner +support_aesni +support_deepseq +support_pclmuldq +support_rdrand -support_sse +use_target_attributes, - any.crypton-asn1-encoding ==0.10.0, - any.crypton-asn1-parse ==0.10.0, - any.crypton-asn1-types ==0.4.1, - any.crypton-connection ==0.4.6, - any.crypton-pem ==0.3.0, - any.crypton-socks ==0.6.2, - crypton-socks -example +network-3-0-0-0, - any.crypton-x509 ==1.9.2, - any.crypton-x509-store ==1.9.0, - any.crypton-x509-system ==1.9.0, - any.crypton-x509-validation ==1.9.1, - any.cuckoo ==0.3.1, - cuckoo -mwc-random -pcg-random, - cwtools -debug -ed25519 -ghc-flags -remote-db, - any.data-bword ==0.1.0.2, - any.data-default ==0.8.0.2, - any.data-default-class ==0.2.0.0, - any.data-dword ==0.3.2.1, - any.data-fix ==0.3.4, - any.data-ordlist ==0.4.7.0, - any.dec ==0.0.6, - any.deepseq ==1.5.0.0, - any.dense-linear-algebra ==0.1.0.0, - any.deriving-compat ==0.6.8, - any.digest ==0.0.2.1, - digest -have_arm64_crc32c -have_builtin_prefetch -have_mm_prefetch -have_sse42 -have_strong_getauxval -have_weak_getauxval +pkg-config, - any.digraph ==0.3.2, - any.direct-sqlite ==2.3.29, - direct-sqlite +dbstat +fulltextsearch +haveusleep +json1 -mathfunctions -systemlib +urifilenames, - any.directory ==1.3.8.5, - any.distributive ==0.6.3, - distributive +tagged, - any.djot ==0.1.4.3, - any.dlist ==1.0, - dlist -werror, - any.doclayout ==0.6, - any.doctemplates ==0.11.1, - any.easy-file ==0.2.5, - any.ech-config ==0.0.1, - ech-config -devel, - any.emojis ==0.1.5, - any.enclosed-exceptions ==1.0.3, - any.entropy ==0.4.1.11, - entropy -donotgetentropy, - any.erf ==2.0.0.0, - any.errors ==2.3.0, - any.ethereum ==0.1.1, - ethereum -ethhash -openssl-use-pkg-config, - any.exceptions ==0.10.9, - any.extra ==1.8.1, - any.fast-logger ==3.2.8, - any.file-embed ==0.0.16.0, - any.filepath ==1.5.4.0, - any.fingertree ==0.1.6.3, - any.finite-typelits ==0.2.1.0, - any.free ==5.2, - any.generic-arbitrary ==1.0.1.2, - any.generic-data ==1.1.0.2, - generic-data -enable-inspect, - any.generic-lens ==2.3.0.0, - any.generic-lens-core ==2.3.0.0, - any.generics-sop ==0.5.1.4, - any.ghc-bignum ==1.3, - any.ghc-boot-th ==9.10.3, - any.ghc-compact ==0.1.0.0, - any.ghc-heap ==9.10.3, - any.ghc-internal ==9.1003.0, - any.ghc-prim ==0.12.0, - any.gridtables ==0.1.1.0, - any.groups ==0.5.3, - any.growable-vector ==0.1, - any.haddock-library ==1.11.0, - any.half ==0.3.3, - any.happy ==2.2, - any.happy-lib ==2.2, - any.hashable ==1.5.1.0, - hashable -arch-native -random-initial-seed, - any.hashes ==0.3.0.1, - hashes -benchmark-cryptonite -openssl-use-pkg-config -test-cryptonite +with-openssl, - any.haskeline ==0.8.2.1, - any.haskell-lexer ==1.2.1, - any.haskell-src-exts ==1.24.0, - any.haskell-src-meta ==0.8.16, - any.heaps ==0.4.1, - any.hedgehog ==1.7, - any.hourglass ==0.2.12, - any.hpke ==0.2.1, - any.hsc2hs ==0.68.10, - hsc2hs -in-ghc-tree, - any.http-api-data ==0.7, - http-api-data -use-text-show, - any.http-client ==0.7.19, - http-client +network-uri, - any.http-client-tls ==0.4.0, - any.http-date ==0.0.11, - any.http-media ==0.8.1.1, - any.http-semantics ==0.4.1, - any.http-types ==0.12.6, - any.http2 ==5.4.9, - http2 -devel -h2spec, - any.indexed-list-literals ==0.2.1.3, - any.indexed-profunctors ==0.1.1.1, - any.indexed-traversable ==0.1.5, - indexed-traversable +base-ge-4-18, - any.indexed-traversable-instances ==0.1.2.1, - any.integer-conversion ==0.1.1, - any.integer-gmp ==1.1, - any.integer-logarithms ==1.0.5, - integer-logarithms -check-bounds +integer-gmp, - any.invariant ==0.6.5, - any.iproute ==1.7.15, - any.ipynb ==0.2, - any.ixset-typed ==0.5.1.0, - any.jira-wiki-markup ==1.5.1, - any.js-chart ==2.9.4.1, - any.kan-extensions ==5.2.8, - any.lens ==5.3.6, - lens -benchmark-uniplate -dump-splices +inlining -j +test-hunit +test-properties +test-templates +trustworthy, - any.lens-aeson ==1.2.3, - any.libyaml ==0.1.4, - libyaml -no-unicode -system-libyaml, - any.libyaml-clib ==0.2.5, - any.lifted-async ==0.11.0, - any.lifted-base ==0.2.3.12, - any.loglevel ==0.1.0.0, - any.lrucaching ==0.3.5, - any.lsp ==2.8.0.0, - lsp -demo, - any.lsp-types ==2.4.0.0, - lsp-types -force-ospath, - any.managed ==1.0.11, - any.massiv ==1.0.5.0, - massiv -unsafe-checks, - any.math-functions ==0.3.4.4, - math-functions +system-erf +system-expm1, - any.megaparsec ==9.8.3, - megaparsec -dev, - any.memory ==0.18.0, - memory +support_bytestring +support_deepseq, - any.merkle-log ==0.2.1, - any.microlens ==0.5.0.0, - any.microstache ==1.0.3.1, - any.mime-types ==0.1.2.2, - any.mlkem ==0.2.3.0, - mlkem +use_crypton, - any.mmorph ==1.2.2, - any.mod ==0.2.2.0, - mod +semirings +vector, - any.monad-control ==1.0.3.1, - any.mono-traversable ==1.0.21.0, - any.mtl ==2.3.1, - any.mtl-compat ==0.2.2, - mtl-compat -two-point-one -two-point-two, - any.mwc-probability ==2.3.1, - any.mwc-random ==0.15.3.0, - mwc-random -benchpapi, - any.natural-arithmetic ==0.2.4.0, - any.neat-interpolation ==0.5.1.4, - any.network ==3.2.9.0, - network -devel, - any.network-byte-order ==0.1.8, - any.network-control ==0.1.7, - any.network-info ==0.2.1, - any.network-uri ==2.6.4.2, - any.nothunks ==0.3.2, - nothunks +bytestring +text +vector, - any.old-locale ==1.0.0.7, - any.old-time ==1.1.1.0, - any.optparse-applicative ==0.19.0.0, - optparse-applicative +process, - any.ordered-containers ==0.2.4, - any.os-string ==2.0.7, - any.pact ==4.13.2, - pact -build-tool +cryptonite-ed25519 -tests-in-lib, - any.pact-json ==0.1.0.0, - any.pact-time ==0.3.0.1, - pact-time -with-time, - any.pact-tng ==5.4.1, - pact-tng +with-crypto +with-funcall-tracing +with-native-tracing, - any.pandoc ==3.12.1, - pandoc +embed_data_files +http, - any.pandoc-types ==1.23.1.2, - any.parallel ==3.3.0.0, - any.parsec ==3.1.18.0, - any.parser-combinators ==1.3.1, - parser-combinators -dev, - any.parsers ==0.12.12, - parsers +attoparsec +binary +parsec, - any.patience ==0.3, - any.pem ==0.2.4, - any.poly ==0.5.1.0, - poly +sparse, - any.pretty ==1.1.3.6, - any.pretty-show ==1.10, - any.pretty-simple ==4.1.4.0, - pretty-simple -buildexample +buildexe, - any.prettyprinter ==1.7.2, - prettyprinter -buildreadme +text, - any.prettyprinter-ansi-terminal ==1.1.4, - prettyprinter-ansi-terminal +text, - any.primitive ==0.9.1.0, - any.primitive-addr ==0.1.0.3, - any.primitive-offset ==0.2.0.1, - any.primitive-unlifted ==2.1.0.0, - any.process ==1.6.26.1, - any.profunctors ==5.6.3, - any.property-matchers ==0.7.0.0, - any.psqueues ==0.2.8.3, - any.pvar ==1.0.0.0, - any.quickcheck-instances ==0.4, - any.ralist ==0.4.1.0, - any.ram ==0.22.1, - any.random ==1.3.1, - any.recover-rtti ==0.5.3, - any.recv ==0.1.2, - any.reducers ==3.12.5, - any.reflection ==2.1.9, - reflection -slow +template-haskell, - any.regex ==1.1.0.2, - any.regex-base ==0.94.0.3, - any.regex-pcre-builtin ==0.95.2.3.8.44, - any.regex-tdfa ==1.3.2.6, - regex-tdfa +doctest -force-o2, - any.resource-pool ==0.5.1.0, - any.resourcet ==1.3.0, - any.retry ==0.9.3.1, - retry -lib-werror, - any.rocksdb-haskell-kadena ==1.1.0, - rocksdb-haskell-kadena -with-tbb, - any.row-types ==1.0.1.2, - any.rts ==1.0.2, - any.run-st ==0.1.3.3, - any.safe ==0.3.21, - any.safe-exceptions ==0.1.7.4, - any.safecopy ==0.10.4.3, - any.scheduler ==2.0.1.0, - any.scientific ==0.3.9.0, - scientific -integer-simple, - any.selective ==0.7.0.1, - any.semialign ==1.4, - semialign +semigroupoids, - any.semigroupoids ==6.0.2, - semigroupoids +comonad +containers +contravariant +tagged +unordered-containers, - any.semigroups ==0.20.1, - any.semirings ==0.7, - semirings +containers +unordered-containers, - any.serialise ==0.2.6.1, - serialise +newtime15, - any.servant ==0.20.3.0, - any.servant-client ==0.20.3.0, - any.servant-client-core ==0.20.3.0, - any.servant-server ==0.20.3.0, - any.sha-validation ==0.1.0.1, - any.show-combinators ==0.2.0.0, - any.simple-sendfile ==0.2.32, - simple-sendfile +allow-bsd -fallback, - any.singleton-bool ==0.1.8, - any.skylighting ==0.15, - skylighting -executable, - any.skylighting-core ==0.15, - skylighting-core -executable, - any.skylighting-format-ansi ==0.1, - any.skylighting-format-blaze-html ==0.1.2.2, - any.skylighting-format-context ==0.1.0.2, - any.skylighting-format-latex ==0.1, - any.skylighting-format-typst ==0.1, - any.some ==1.0.6, - some +newtype-unsafe, - any.sop-core ==0.5.0.2, - any.sorted-list ==0.3.1.0, - any.split ==0.2.5.1, - any.splitmix ==0.1.3.2, - splitmix -optimised-mixer, - any.statistics ==0.16.5.0, - statistics -benchpapi, - any.stm ==2.5.3.1, - any.stm-chans ==3.0.0.11, - any.stopwatch ==0.1.0.7, - stopwatch -test_delay_upper_bound -test_threaded, - any.streaming ==0.2.4.0, - any.streaming-commons ==0.2.3.1, - streaming-commons -use-bytestring-builder, - any.strict ==0.5.1, - any.strict-concurrency ==0.2.4.3, - any.syb ==0.7.4, - any.tagged ==0.8.11, - tagged +deepseq +template-haskell, - any.tagsoup ==0.14.8, - any.tasty ==1.5.4, - tasty +unix, - any.tasty-golden ==2.3.6, - tasty-golden -build-example, - any.tasty-hedgehog ==1.4.0.2, - any.tasty-hunit ==0.10.2, - any.tasty-json ==0.1.0.0, - any.tasty-quickcheck ==0.11.1, - any.template-haskell ==2.22.0.0, - any.temporary ==1.3, - any.terminal-progress-bar ==0.4.2, - any.terminal-size ==0.3.4, - any.terminfo ==0.4.1.7, - any.texmath ==0.13.3.1, - texmath -executable -server, - any.text ==2.1.3, - any.text-builder ==1.0.0.5, - any.text-builder-core ==0.1.1.3, - any.text-conversions ==0.3.1.1, - any.text-iso8601 ==0.1.1.2, - any.text-rope ==0.3, - text-rope -debug, - any.text-short ==0.1.6.1, - text-short -asserts, - any.th-abstraction ==0.7.2.0, - any.th-compat ==0.1.7, - any.th-expand-syns ==0.4.12.0, - any.th-lift ==0.8.7, - any.th-lift-instances ==0.1.20, - any.th-orphans ==0.13.17, - any.th-reify-many ==0.1.10, - any.these ==1.2.1, - any.time ==1.12.2, - any.time-compat ==1.9.9, - any.time-hourglass ==0.3.0, - any.time-locale-compat ==0.1.1.5, - time-locale-compat +old-locale, - any.time-manager ==0.4.0, - any.tls ==2.4.6, - tls -devel, - any.tls-session-manager ==0.1.0, - any.token-bucket ==0.1.0.1, - token-bucket +use-cbits, - any.toml-parser ==2.0.2.0, - any.torsor ==0.1.0.1, - any.transformers ==0.6.1.1, - any.transformers-base ==0.4.6.1, - transformers-base +orphaninstances, - any.transformers-compat ==0.7.2, - transformers-compat -five +five-three -four +generic-deriving +mtl -three -two, - any.trifecta ==2.1.4, - any.tuples ==0.1.0.0, - any.typed-process ==0.2.13.0, - any.typst ==0.12, - typst -executable, - any.typst-symbols ==0.3, - any.unicode-collation ==0.1.3.7, - unicode-collation -doctests -executable -icu-benchmark, - any.unicode-data ==0.9.0, - unicode-data -dev-has-icu, - any.unicode-transforms ==0.4.0.1, - unicode-transforms -bench-show -dev -has-icu -has-llvm -use-gauge, - any.uniplate ==1.6.13, - any.unix ==2.8.7.0, - any.unix-compat ==0.7.4.1, - any.unix-time ==0.5.0, - any.unlifted ==0.2.4.0, - any.unliftio ==0.2.25.1, - any.unliftio-core ==0.2.1.0, - any.unordered-containers ==0.2.21, - unordered-containers -debug, - any.utf8-string ==1.0.2, - any.uuid ==1.3.16.1, - any.uuid-types ==1.0.6.1, - any.validation ==1.1.5, - any.vault ==0.3.2.0, - vault +useghc, - any.vector ==0.13.2.0, - vector +boundschecks -internalchecks -unsafechecks -wall, - any.vector-algorithms ==0.9.1.0, - vector-algorithms +bench +boundschecks -internalchecks -llvm -unsafechecks, - any.vector-binary-instances ==0.2.5.2, - any.vector-sized ==1.6.1, - any.vector-stream ==0.1.0.1, - any.vector-th-unbox ==0.2.2, - any.void ==0.7.4, - void -safe, - any.wai ==3.2.5, - any.wai-app-static ==3.2.1, - wai-app-static -print, - any.wai-cors ==0.2.7, - any.wai-extra ==3.1.18, - wai-extra -build-example, - any.wai-logger ==2.5.0, - any.wai-middleware-throttle ==0.3.0.1, - any.wai-middleware-validation ==0.1.0.2, - any.warp ==3.4.16, - warp +allow-sendfilefd +include-warp-version -network-bytestring -warp-debug +x509, - any.warp-tls ==3.4.14, - any.websockets ==0.13.0.0, - websockets -example, - any.wherefrom-compat ==0.2.0.0, - any.wide-word ==0.1.9.0, - any.witherable ==0.5, - any.wl-pprint-annotated ==0.1.0.2, - any.word8 ==0.1.3, - any.xml ==1.3.14, - any.xml-conduit ==1.10.1.0, - any.xml-types ==0.3.8, - any.yaml ==0.11.11.2, - yaml +no-examples +no-exe, - any.yet-another-logger ==0.4.2, - yet-another-logger -tbmqueue, - any.zigzag ==0.1.0.0, - any.zip-archive ==0.5, - zip-archive -executable, - any.zlib ==0.7.1.1, - zlib -bundled-c-zlib +non-blocking-ffi +pkg-config -index-state: hackage.haskell.org 2026-10-18T08:35:38Z diff --git a/chain-specs/evm-development-singleton/chain-spec-20.json b/chain-specs/evm-development-singleton/chain-spec-20.json new file mode 100644 index 0000000000..449e61bfe5 --- /dev/null +++ b/chain-specs/evm-development-singleton/chain-spec-20.json @@ -0,0 +1 @@ +{"alloc":{"0x03e95Af0fC4971EdCa12E6d2d1540c28314d15d5":{"balance":"0xd3c21bcecceda1000000"},"0x28f2d8ef4e0fe6B2E945cF5C33a0118a30a62354":{"balance":"0xd3c21bcecceda1000000"},"0x33018A42499f10B54d9dBCeBB71831C805D64cE3":{"balance":"0xd3c21bcecceda1000000"},"0x3492DA004098d728201fD82657f1207a6E5426bd":{"balance":"0xd3c21bcecceda1000000"},"0x47fAE86F6416e6115a80635238AFd2F18D69926B":{"balance":"0xd3c21bcecceda1000000"},"0x7e99c2f1731D3750b74A2a0623C1F1DcB8cCa45e":{"balance":"0xd3c21bcecceda1000000"},"0x87466A8266b9DFB3Dc9180a9c43946c4AB2c2cb2":{"balance":"0xd3c21bcecceda1000000"},"0x8849BAbdDcfC1327Ad199877861B577cEBd8A7b6":{"balance":"0xd3c21bcecceda1000000"},"0x99b832eb3F76ac3277b00beADC1e487C594ffb4c":{"balance":"0xd3c21bcecceda1000000"},"0x9b02c3e2df42533e0fd166798b5a616f59dbd2cc":{"balance":"0x0","code":"0x6080604052348015600f57600080fd5b506004361060285760003560e01c8063973e55d414602d575b600080fd5b600054603c9063ffffffff1681565b60405163ffffffff909116815260200160405180910390f3fea2646970667358221220b716cf70992d0b5a77124b3da9b37629f5625bf265c121cfb76f9714f249119b64736f6c634300081c0033","storage":{"0x0000000000000000000000000000000000000000000000000000000000000000":"0x0000000000000000000000000000000000000000000000000000000000000014"}},"0xA310Df9740eb6CC2F5E41C59C87e339142834eA4":{"balance":"0xd3c21bcecceda1000000"},"0xD4EECE51cf451b60F59b271c5a748A8a9F16bC01":{"balance":"0xd3c21bcecceda1000000"},"0xE08643a1C4786b573d739625FD268732dBB3d033":{"balance":"0xd3c21bcecceda1000000"},"0xEE2722c39db6014Eacc5FBe43601136825b00977":{"balance":"0xd3c21bcecceda1000000"},"0xFB8Fb7f9bdc8951040a6D195764905138F7462Ed":{"balance":"0xd3c21bcecceda1000000"},"0xFd70Bef78778Ce8554e79D97521b69183960C574":{"balance":"0xd3c21bcecceda1000000"},"0xa24a79678c9fffEF3E9A1f3cb7e51f88F173B3D5":{"balance":"0xd3c21bcecceda1000000"},"0xa3659D39C901d5985450eE18a63B5b0811fDa521":{"balance":"0xd3c21bcecceda1000000"},"0xc201d4A5E6De676938533A0997802634E859e78b":{"balance":"0xd3c21bcecceda1000000"},"0xda1380825f827C6Ea92DFB547EF0a341Cbe21d77":{"balance":"0xd3c21bcecceda1000000"},"0xeDD5a9185F9F1C04a011117ad61564415057bf8F":{"balance":"0xd3c21bcecceda1000000"}},"coinbase":"0x0000000000000000000000000000000000000000","config":{"arrowGlacierBlock":0,"berlinBlock":0,"byzantiumBlock":0,"cancunTime":0,"chainId":1789,"constantinopleBlock":0,"daoForkBlock":0,"daoForkSupport":true,"eip150Block":0,"eip155Block":0,"eip158Block":0,"graphGlacierBlock":0,"homesteadBlock":0,"istanbulBlock":0,"londonBlock":0,"mergeForkBlock":0,"mergeNetsplitBlock":0,"muirGlacierBlock":0,"petersburgBlock":0,"pragueTime":0,"shanghaiTime":0,"terminalTotalDifficulty":0,"terminalTotalDifficultyPassed":true},"difficulty":"0x0","extraData":"0x","gasLimit":"0x1c9c380","mixHash":"0x0000000000000000000000000000000000000000000000000000000000000000","nonce":"0x0","number":"0x0","timestamp":"0x6490fdd2"} \ No newline at end of file diff --git a/chainweb.cabal b/chainweb.cabal index d552800538..95bde3e314 100644 --- a/chainweb.cabal +++ b/chainweb.cabal @@ -95,8 +95,8 @@ common debugging-flags common warning-flags ghc-options: + -Wwarn -Wall - -Werror -Wcompat -Wpartial-fields -Wincomplete-record-updates @@ -106,16 +106,13 @@ common warning-flags -fmax-relevant-binds=0 -Wno-gadt-mono-local-binds - -- This needed because -Werror and missing-home-modules causes - -- problems with ghci. - -Wno-missing-home-modules - -- -------------------------------------------------------------------------- -- -- Chainweb Library -- -------------------------------------------------------------------------- -- library import: warning-flags, debugging-flags + ghc-options: -ddump-simpl -dsuppress-all -ddump-to-file -dno-suppress-type-signatures default-language: Haskell2010 hs-source-dirs: src other-modules: @@ -126,7 +123,7 @@ library cc-options: -DSQLITE_CORE exposed-modules: , Chainweb.Backup - , Chainweb.Block + , Chainweb.Pact.Block , Chainweb.BlockCreationTime , Chainweb.BlockHash , Chainweb.BlockHeader @@ -183,7 +180,8 @@ library , Chainweb.Chainweb.MempoolSyncClient , Chainweb.Chainweb.MinerResources , Chainweb.Chainweb.PeerResources - , Chainweb.Chainweb.PruneChainDatabase + , Chainweb.Core.Brief + , Chainweb.Core.CryptoHash , Chainweb.Counter , Chainweb.Crypto.MerkleLog , Chainweb.Cut @@ -201,15 +199,15 @@ library , Chainweb.Logger , Chainweb.Logging.Config , Chainweb.Logging.Miner - , Chainweb.Mempool.Consensus - , Chainweb.Mempool.CurrentTxs - , Chainweb.Mempool.InMem - , Chainweb.Mempool.InMemTypes - , Chainweb.Mempool.Mempool - , Chainweb.Mempool.P2pConfig - , Chainweb.Mempool.RestAPI - , Chainweb.Mempool.RestAPI.Client - , Chainweb.Mempool.RestAPI.Server + , Chainweb.Pact.Mempool.CurrentTxs + , Chainweb.Pact.Mempool.InMem + , Chainweb.Pact.Mempool.InMem.ValidatingConfig + , Chainweb.Pact.Mempool.InMemTypes + , Chainweb.Pact.Mempool.Mempool + , Chainweb.Pact.Mempool.P2pConfig + , Chainweb.Pact.Mempool.RestAPI + , Chainweb.Pact.Mempool.RestAPI.Client + , Chainweb.Pact.Mempool.RestAPI.Server , Chainweb.MerkleLogHash , Chainweb.MerkleUniverse , Chainweb.Miner.Config @@ -217,19 +215,47 @@ library , Chainweb.Miner.Core , Chainweb.Miner.Miners , Chainweb.Miner.Pact + , Chainweb.Miner.PayloadCache , Chainweb.Miner.RestAPI , Chainweb.Miner.RestAPI.Client , Chainweb.Miner.RestAPI.Server , Chainweb.MinerReward , Chainweb.NodeVersion , Chainweb.OpenAPIValidation - , Chainweb.Payload - , Chainweb.Payload.PayloadStore - , Chainweb.Payload.PayloadStore.InMemory - , Chainweb.Payload.PayloadStore.RocksDB - , Chainweb.Payload.RestAPI - , Chainweb.Payload.RestAPI.Server - , Chainweb.Payload.RestAPI.Client + , Chainweb.Parent + , Chainweb.Pact.Payload + , Chainweb.Pact.Payload.PayloadStore + , Chainweb.Pact.Payload.PayloadStore.InMemory + , Chainweb.Pact.Payload.PayloadStore.RocksDB + , Chainweb.Pact.Payload.RestAPI + , Chainweb.Pact.Payload.RestAPI.Server + , Chainweb.Pact.Payload.RestAPI.Client + , Chainweb.PayloadProvider + , Chainweb.PayloadProvider.EVM + , Chainweb.PayloadProvider.EVM.EngineAPI + , Chainweb.PayloadProvider.EVM.EthRpcAPI + , Chainweb.PayloadProvider.EVM.ExecutionPayload + , Chainweb.PayloadProvider.EVM.Genesis + , Chainweb.PayloadProvider.EVM.Header + , Chainweb.PayloadProvider.EVM.HeaderDB + , Chainweb.PayloadProvider.EVM.JsonRPC + , Chainweb.PayloadProvider.EVM.PayloadDB + , Chainweb.PayloadProvider.EVM.Receipt + , Chainweb.PayloadProvider.EVM.SPV + , Chainweb.PayloadProvider.EVM.Utils + , Chainweb.PayloadProvider.Initialization + , Chainweb.PayloadProvider.Minimal + , Chainweb.PayloadProvider.Minimal.Payload + , Chainweb.PayloadProvider.Minimal.PayloadDB + , Chainweb.PayloadProvider.Pact + , Chainweb.PayloadProvider.Pact.Configuration + , Chainweb.PayloadProvider.Pact.Genesis + , Chainweb.PayloadProvider.Pact.BlockHistoryMigration + , Chainweb.PayloadProvider.P2P + , Chainweb.PayloadProvider.P2P.RestAPI + , Chainweb.PayloadProvider.P2P.RestAPI.Client + , Chainweb.PayloadProvider.P2P.RestAPI.Server + , Chainweb.PayloadProvider.SPV , Chainweb.PowHash , Chainweb.Ranked , Chainweb.RestAPI @@ -241,6 +267,7 @@ library , Chainweb.RestAPI.Orphans , Chainweb.RestAPI.Utils , Chainweb.SPV + , Chainweb.SPV.Argument , Chainweb.SPV.CreateProof , Chainweb.SPV.EventProof , Chainweb.SPV.OutputProof @@ -249,16 +276,19 @@ library , Chainweb.SPV.RestAPI , Chainweb.SPV.RestAPI.Server , Chainweb.SPV.RestAPI.Client + , Chainweb.Sync.ForkInfo , Chainweb.Sync.WebBlockHeaderStore , Chainweb.Time - , Chainweb.Pact4.Transaction - , Chainweb.Pact5.Transaction , Chainweb.TreeDB + , Chainweb.Scheduler , Chainweb.Utils , Chainweb.Utils.Paging , Chainweb.Utils.RequestLog + , Chainweb.Utils.Resource , Chainweb.Utils.Rule , Chainweb.Utils.Serialization + , Chainweb.Utils.Tuple + , Chainweb.Utils.UnitPrefixes , Chainweb.VerifierPlugin , Chainweb.VerifierPlugin.Allow , Chainweb.VerifierPlugin.Hyperlane.Announcement @@ -270,6 +300,9 @@ library , Chainweb.VerifierPlugin.SignedList , Chainweb.Version , Chainweb.Version.Development + , Chainweb.Version.EvmDevelopment + , Chainweb.Version.EvmDevelopmentSingleton + , Chainweb.Version.EvmTestnet , Chainweb.Version.Guards , Chainweb.Version.Mainnet , Chainweb.Version.RecapDevelopment @@ -278,7 +311,6 @@ library , Chainweb.Version.Testnet06 , Chainweb.Version.Utils , Chainweb.WebBlockHeaderDB - , Chainweb.WebPactExecutionService , Data.IVar , Data.LogMessage @@ -300,10 +332,10 @@ library , P2P.Peer , P2P.Session , P2P.TaskQueue + , P2P.Utils -- pact - , Chainweb.Pact4.Backend.ChainwebPactDb - , Chainweb.Pact5.Backend.ChainwebPactDb + , Chainweb.Pact.Backend.ChainwebPactDb , Chainweb.Pact.Backend.DbCache , Chainweb.Pact.Backend.Compaction , Chainweb.Pact.Backend.PactState @@ -322,36 +354,55 @@ library , Chainweb.Pact.Conversion , Chainweb.Pact.PactService , Chainweb.Pact.PactService.Checkpointer - , Chainweb.Pact.PactService.Checkpointer.Internal - , Chainweb.Pact.PactService.Pact4.ExecBlock - , Chainweb.Pact.PactService.Pact5.ExecBlock + , Chainweb.Pact.PactService.ExecBlock , Chainweb.Pact.RestAPI , Chainweb.Pact.RestAPI.Client , Chainweb.Pact.RestAPI.EthSpv , Chainweb.Pact.RestAPI.SPV , Chainweb.Pact.RestAPI.Server - , Chainweb.Pact4.SPV - , Chainweb.Pact5.SPV - , Chainweb.Pact.Service.BlockValidation - , Chainweb.Pact.Service.PactInProcApi - , Chainweb.Pact.Service.PactQueue + , Chainweb.Pact.NoCoinbase + , Chainweb.Pact.SPV + , Chainweb.Pact.Templates + , Chainweb.Pact.Transaction + , Chainweb.Pact.TransactionExec + -- , Chainweb.Pact4.SPV + -- , Chainweb.Pact5.SPV + -- , Chainweb.Pact.Service.BlockValidation + -- , Chainweb.Pact.Service.PactInProcApi + -- , Chainweb.Pact.Service.PactQueue + -- , Chainweb.Pact4.ModuleCache + -- , Chainweb.Pact4.NoCoinbase + -- , Chainweb.Pact4.Templates + -- , Chainweb.Pact4.TransactionExec + -- , Chainweb.Pact4.Types + -- , Chainweb.Pact4.Validations + -- , Chainweb.Pact5.NoCoinbase + -- , Chainweb.Pact5.Templates + -- , Chainweb.Pact5.TransactionExec + -- , Chainweb.Pact5.Validations + , Chainweb.Pact.InitialGasModel + , Chainweb.Pact.Transactions.FungibleV2Transactions + , Chainweb.Pact.Transactions.CoinV3Transactions + , Chainweb.Pact.Transactions.CoinV4Transactions + , Chainweb.Pact.Transactions.CoinV5Transactions + , Chainweb.Pact.Transactions.CoinV6Transactions + , Chainweb.Pact.Transactions.MainnetKADTransactions + , Chainweb.Pact.Transactions.OtherTransactions + , Chainweb.Pact.Transactions.RecapDevelopmentTransactions + , Chainweb.Pact.Types + , Chainweb.Pact.Validations + , Chainweb.Pact.Utils + -- pact 4 + , Chainweb.Pact4.Backend.ChainwebPactDb , Chainweb.Pact4.ModuleCache , Chainweb.Pact4.NoCoinbase + , Chainweb.Pact.PactService.Pact4.ExecBlock + , Chainweb.Pact4.SPV , Chainweb.Pact4.Templates + , Chainweb.Pact4.Transaction , Chainweb.Pact4.TransactionExec , Chainweb.Pact4.Types , Chainweb.Pact4.Validations - , Chainweb.Pact5.NoCoinbase - , Chainweb.Pact5.Templates - , Chainweb.Pact5.TransactionExec - , Chainweb.Pact5.Types - , Chainweb.Pact5.Validations - , Chainweb.Pact5.InitialGasModel - , Chainweb.Pact.Transactions.FungibleV2Transactions - , Chainweb.Pact.Transactions.CoinV3Transactions - , Chainweb.Pact.Transactions.CoinV4Transactions - , Chainweb.Pact.Transactions.CoinV5Transactions - , Chainweb.Pact.Transactions.CoinV6Transactions , Chainweb.Pact.Transactions.Mainnet0Transactions , Chainweb.Pact.Transactions.Mainnet1Transactions , Chainweb.Pact.Transactions.Mainnet2Transactions @@ -362,11 +413,6 @@ library , Chainweb.Pact.Transactions.Mainnet7Transactions , Chainweb.Pact.Transactions.Mainnet8Transactions , Chainweb.Pact.Transactions.Mainnet9Transactions - , Chainweb.Pact.Transactions.MainnetKADTransactions - , Chainweb.Pact.Transactions.OtherTransactions - , Chainweb.Pact.Transactions.RecapDevelopmentTransactions - , Chainweb.Pact.Types - , Chainweb.Pact.Utils -- utils , Utils.Logging @@ -379,7 +425,7 @@ library , async >= 2.2 , attoparsec >= 0.13 , base >= 4.12 && < 5 - , base16-bytestring >= 0.1 + , base16-bytestring >= 1.0 , base64-bytestring-kadena == 0.1 , binary >= 0.8 , bytestring >= 0.10.12 @@ -397,21 +443,19 @@ library , crypton-x509 >= 1.8 , crypton-x509-system >=1.6 , crypton-x509-validation >=1.6 - , cuckoo >= 0.3 , data-dword >= 0.3 , deepseq >= 1.4 , digraph >= 0.3.2 , direct-sqlite >= 2.3.27 , directory >= 1.3 , dlist >= 0.8 - , errors >= 2.3 , ethereum:{ethereum, secp256k1} >= 0.1 , exceptions >= 0.8 , file-embed >= 0.0 , filepath >= 1.4 , ghc-compact >= 0.1 - , growable-vector >= 0.1 , hashable >= 1.4 + , hashes >=0.2.2.0 , heaps >= 0.3 , time-hourglass >=0.2 , http2 >= 5.2.1 @@ -431,6 +475,7 @@ library , mwc-probability >= 2.0 , mwc-random >= 0.13 , network >= 3.1.2 + , network-uri >= 2.6 , optparse-applicative >= 0.14 , pact >= 4.2.0.1 , pact-json >= 0.1 @@ -442,6 +487,8 @@ library , pem >=0.2 , primitive >= 0.7.1.0 , random >= 1.3 + , resourcet >= 1.3 + , resource-pool >= 0.4 , rocksdb-haskell-kadena >= 1.1.0 , safe-exceptions >= 0.1 , scheduler >= 1.4 @@ -449,6 +496,7 @@ library , semigroupoids >= 5.3.7 , servant >= 0.20.1 , servant-client >= 0.20 + , servant-client-core >= 0.20.3.0 , servant-server >= 0.20 , stm >= 2.4 , stopwatch >= 0.1 @@ -465,7 +513,7 @@ library , trifecta >= 2.1 , unliftio >= 0.2 , unordered-containers >= 0.2.20 - , uuid >= 1.3.16 + , validation , vector >= 0.12.2 , vector-algorithms >= 0.7 , wai >= 3.2.2.1 @@ -503,14 +551,10 @@ library chainweb-test-utils Chainweb.Test.HostAddress Chainweb.Test.MultiNode Chainweb.Test.P2P.Peer.BootstrapConfig + Chainweb.Test.Pact.CmdBuilder + Chainweb.Test.Pact.Utils Chainweb.Test.Pact4.Utils - Chainweb.Test.Pact4.VerifierPluginTest.Transaction - Chainweb.Test.Pact4.VerifierPluginTest.Transaction.Message.After225 - Chainweb.Test.Pact4.VerifierPluginTest.Transaction.Message.Before225 - Chainweb.Test.Pact4.VerifierPluginTest.Transaction.Utils Chainweb.Test.Pact4.VerifierPluginTest.Unit - Chainweb.Test.Pact5.CmdBuilder - Chainweb.Test.Pact5.Utils Chainweb.Test.RestAPI.Client_ Chainweb.Test.RestAPI.Utils Chainweb.Test.TestVersions @@ -521,7 +565,6 @@ library chainweb-test-utils -- Orphan Modules Chainweb.Test.Orphans.Internal - Chainweb.Test.Orphans.Pact Chainweb.Test.Orphans.Time P2P.Test.Orphans @@ -538,11 +581,10 @@ library chainweb-test-utils , aeson >= 2.2 , async >= 2.2 , base >= 4.12 && < 5 - , base16-bytestring >= 0.1 + , base16-bytestring >= 1.0 , bytestring >= 0.10.12 , case-insensitive >= 1.2 , chainweb-storage >= 0.1 - , chronos >= 1.1 , containers >= 0.5 , crypton >= 1.1.2 , crypton-connection >=0.4 @@ -571,6 +613,7 @@ library chainweb-test-utils , quickcheck-instances >= 0.3 , random >= 1.3 , resourcet >= 1.3 + , resource-pool >= 0.4 , retry >= 0.7 , rocksdb-haskell-kadena >= 1.1.0 , safe-exceptions >= 0.1 @@ -635,47 +678,40 @@ test-suite chainweb-tests Chainweb.Test.CutDB Chainweb.Test.Difficulty Chainweb.Test.Mempool - Chainweb.Test.Mempool.Consensus + -- Chainweb.Test.Mempool.Consensus Chainweb.Test.Mempool.InMem Chainweb.Test.Mempool.RestAPI Chainweb.Test.Mempool.Sync Chainweb.Test.MinerReward Chainweb.Test.Mining Chainweb.Test.Misc - Chainweb.Test.Pact4.Checkpointer + Chainweb.Test.Pact.CheckpointerTest + Chainweb.Test.Pact.BlockHistoryMigrationTest + Chainweb.Test.Pact.CutFixture + Chainweb.Test.Pact.HyperlanePluginTests + Chainweb.Test.Pact.PactServiceTest + Chainweb.Test.Pact.RemotePactTest + -- Chainweb.Test.Pact.SPVTest + Chainweb.Test.Pact.TransactionExecTest + Chainweb.Test.Pact.TransactionTests Chainweb.Test.Pact4.DbCacheTest Chainweb.Test.Pact4.GrandHash - Chainweb.Test.Pact4.ModuleCacheOnRestart Chainweb.Test.Pact4.NoCoinbase - Chainweb.Test.Pact4.PactExec - Chainweb.Test.Pact4.PactMultiChainTest - Chainweb.Test.Pact4.PactReplay - Chainweb.Test.Pact4.PactSingleChainTest - Chainweb.Test.Pact4.RemotePactTest Chainweb.Test.Pact4.RewardsTest - Chainweb.Test.Pact4.SPV Chainweb.Test.Pact4.SQLite - Chainweb.Test.Pact4.TTL Chainweb.Test.Pact4.TransactionTests Chainweb.Test.Pact4.VerifierPluginTest - Chainweb.Test.Pact5.CheckpointerTest - Chainweb.Test.Pact5.CutFixture - Chainweb.Test.Pact5.HyperlanePluginTests - Chainweb.Test.Pact5.SignedListPluginTests - Chainweb.Test.Pact5.PactServiceTest - Chainweb.Test.Pact5.RemotePactTest - Chainweb.Test.Pact5.SPVTest - Chainweb.Test.Pact5.TransactionExecTest - Chainweb.Test.Pact5.TransactionTests + Chainweb.Test.Pact.SignedListPluginTests Chainweb.Test.ResponseSizeLimiter Chainweb.Test.RestAPI Chainweb.Test.Roundtrips - Chainweb.Test.SPV - Chainweb.Test.SPV.EventProof + -- Chainweb.Test.SPV + -- Chainweb.Test.SPV.EventProof Chainweb.Test.Sync.WebBlockHeaderStore Chainweb.Test.TreeDB Chainweb.Test.TreeDB.RemoteDB Chainweb.Test.Version + Test.Chainweb.SPV.Argument -- Data Data.Test.PQueue @@ -696,7 +732,7 @@ test-suite chainweb-tests , aeson >= 2.2 , async >= 2.2 , base >= 4.12 && < 5 - , base16-bytestring >= 0.1 + , base16-bytestring >= 1.0 , base64-bytestring-kadena == 0.1 , byteslice >= 0.2.12 , bytesmith >= 0.3.10 @@ -708,9 +744,7 @@ test-suite chainweb-tests , crypton-connection >=0.4 , data-dword >= 0.3 , data-ordlist >= 0.4.7 - , deepseq >= 1.4 , direct-sqlite >= 2.3.27 - , ethereum , exceptions , ghc-compact >= 0.1 , hashable >= 1.3 @@ -739,16 +773,16 @@ test-suite chainweb-tests , pretty-show , quickcheck-instances >= 0.3 , random >= 1.3 + , random-shuffle >= 0.0.4 + , raw-strings-qq >=1.1 , resource-pool >= 0.4 , resourcet >= 1.3 , safe-exceptions >= 0.1 , scheduler >= 1.4 , servant-client >= 0.18.2 , sha-validation >=0.1 - , statistics >= 0.15 , stm , streaming >= 0.2.2 - , strict-concurrency >= 0.2 , tasty >= 1.0 , tasty-hedgehog >= 1.4.0.2 , tasty-hunit >= 0.9 @@ -764,12 +798,37 @@ test-suite chainweb-tests , wai-extra >= 3.1 , warp >= 3.3.6 , warp-tls >= 3.4 - , yaml >= 0.11 + if flag(ed25519) + cpp-options: -DWITH_ED25519=1 + +test-suite blockhistory-migration-tests + default-language: Haskell2010 + type: exitcode-stdio-1.0 + hs-source-dirs: test/blockhistory-migration + main-is: BlockHistoryMigrationTests.hs + + build-depends: + -- internal + , chainweb + , chainweb:chainweb-test-utils + + -- external + , base >= 4.12 && < 5 + , chainweb-storage >= 0.1 + , temporary >= 1.3 + , filepath + , directory + , resourcet + , streaming + , HUnit + , lens + if flag(ed25519) cpp-options: -DWITH_ED25519=1 test-suite compaction-tests import: warning-flags, debugging-flags + buildable: False default-language: Haskell2010 type: exitcode-stdio-1.0 ghc-options: @@ -871,11 +930,12 @@ benchmark bench main-is: Bench.hs type: exitcode-stdio-1.0 other-modules: + Chainweb.CutDBBench Chainweb.MempoolBench - Chainweb.Pact.Backend.ApplyCmd - Chainweb.Pact.Backend.Bench - Chainweb.Pact.Backend.ForkingBench - Chainweb.Pact.Backend.PactService + -- Chainweb.Pact.Backend.ApplyCmd + -- Chainweb.Pact.Backend.Bench + -- Chainweb.Pact.Backend.ForkingBench + -- Chainweb.Pact.Backend.PactService Chainweb.Utils.Bench JSONEncoding @@ -885,31 +945,50 @@ benchmark bench , chainweb:chainweb-test-utils -- external - , Decimal >= 0.4.2 + , QuickCheck >= 2.14 , aeson >= 2.2 - , async >= 2.2 , base >= 4.12 && < 5 , bytestring >= 0.10.12 - , chainweb-storage >= 0.1 , containers >= 0.5 , criterion , deepseq >= 1.4 , direct-sqlite - , exceptions >= 0.8 - , file-embed >= 0.0 + , http-client >= 0.5 , lens >= 4.17 - , loglevel >= 0.1 - , mtl >= 2.3 - , pact , pact-tng , pact-tng:pact-request-api , property-matchers >= 0.7 , random >= 1.3 + , resourcet >= 1.3 , safe-exceptions + , servant-client >= 0.18.2 + , stm , streaming , tasty-hunit , text >= 2.0 - , unordered-containers + , unordered-containers >= 0.2.20 , vector >= 0.12.2 , yaml >= 0.11 + + -- The build of all Pact related benchmarks is currently broken in the + -- evm branch and the build of the respective modules is disable. The + -- following dependencies are used by those disabled modules. See the + -- module bench/Bench.hs for details of what is currently working. + + -- , Decimal >= 0.4.2 + -- , async >= 2.2 + -- , chainweb-storage >= 0.1 + -- , exceptions >= 0.8 + -- , file-embed >= 0.0 + -- , loglevel >= 0.1 + -- , mtl >= 2.3 + -- , pact + -- , random >= 1.3 + -- , resource-pool >= 0.4 + -- , resourcet >= 1.3 + -- , safe-exceptions + -- , streaming + -- , tasty-hunit + -- , unordered-containers + -- , yaml >= 0.11 diff --git a/cwtools/cwtools.cabal b/cwtools/cwtools.cabal index 82e7e597cf..2e54e7aad0 100644 --- a/cwtools/cwtools.cabal +++ b/cwtools/cwtools.cabal @@ -59,7 +59,6 @@ common debugging-flags common warning-flags ghc-options: -Wall - -Werror -Wcompat -Wpartial-fields -Wincomplete-record-updates @@ -68,10 +67,6 @@ common warning-flags -funclutter-valid-hole-fits -fmax-relevant-binds=0 - -- This needed because -Werror and missing-home-modules causes - -- problems with ghci. - -Wno-missing-home-modules - executable b64 import: warning-flags, debugging-flags default-language: Haskell2010 @@ -91,6 +86,28 @@ executable b64 , optparse-applicative , text +executable standalone-pruner + import: warning-flags, debugging-flags + default-language: Haskell2010 + ghc-options: + -threaded + hs-source-dirs: standalone-pruner + main-is: Main.hs + build-depends: + -- internal + , chainweb + , chainweb-storage + + -- external + , base >= 4.12 && < 5 + , lens + , lens-aeson + , loglevel + , optparse-applicative + , resourcet + , text + , time + -- Compact pact state and RocksDB. executable compact import: warning-flags, debugging-flags @@ -111,6 +128,7 @@ executable compact executable db-checksum import: warning-flags, debugging-flags default-language: Haskell2010 + buildable: False ghc-options: -threaded -rtsopts @@ -132,7 +150,7 @@ executable db-checksum , directory , ram >=0.2.2 , mtl - , pact + , pact-tng , safe-exceptions , text , unordered-containers @@ -160,9 +178,14 @@ executable ea , async , base , chainweb-storage + , filepath , lens , loglevel - , pact + , pact-json + , pact-tng:pact-request-api + , pact-tng + , resource-pool + , resourcet , temporary , text , vector @@ -191,6 +214,7 @@ executable genconf executable header-dump import: warning-flags, debugging-flags default-language: Haskell2010 + buildable: False ghc-options: -threaded -rtsopts @@ -318,3 +342,24 @@ executable tx-list , text , unordered-containers , yet-another-logger + +executable evm-genesis + import: warning-flags, debugging-flags + default-language: Haskell2010 + ghc-options: + -threaded + -rtsopts + hs-source-dirs: evm-genesis + main-is: Main.hs + build-depends: + , chainweb + , ethereum + , bytestring + , aeson + , text + , base + , network-uri + , http-client + , process + , directory + , retry diff --git a/cwtools/ea/Ea.hs b/cwtools/ea/Ea.hs index fb182dcbf9..df7218ee5f 100644 --- a/cwtools/ea/Ea.hs +++ b/cwtools/ea/Ea.hs @@ -2,9 +2,6 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE ImportQualifiedPost #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE TypeOperators #-} -- | -- Module: Ea @@ -28,32 +25,28 @@ -- module Main (main) where -import Chainweb.BlockHeaderDB +import Chainweb.ChainId qualified as Chainweb import Chainweb.Logger (genericLogger) -import Chainweb.Miner.Pact (noMiner) import Chainweb.Pact.Backend.Utils import Chainweb.Pact.PactService -import Chainweb.Pact.Types (testPactServiceConfig) +import Chainweb.Pact.Payload +import Chainweb.Pact.Payload.PayloadStore.InMemory +import Chainweb.Pact.Transaction qualified as Pact +import Chainweb.Pact.Types (defaultPactServiceConfig, GenesisConfig(..)) import Chainweb.Pact.Utils (toTxCreationTime) -import Chainweb.Pact4.Transaction qualified as Pact4 -import Chainweb.Pact4.Validations (defaultMaxTTL) -import Chainweb.Payload -import Chainweb.Payload.PayloadStore.InMemory -import Chainweb.Storage.Table.RocksDB +import Chainweb.Pact.Validations (defaultMaxTTLSeconds) import Chainweb.Time import Chainweb.Utils import Chainweb.Version -import Chainweb.Version.Development (pattern Development) -import Chainweb.Version.RecapDevelopment (pattern RecapDevelopment) -import Chainweb.Version.Registry (registerVersion) import Control.Concurrent.Async import Control.Exception import Control.Lens -import Data.Aeson qualified as Aeson +import Control.Monad.IO.Class +import Control.Monad.Trans.Resource import Data.Foldable -import Data.Functor import Data.Text (Text) import Data.Text qualified as T +import Data.Text.Encoding qualified as T import Data.Text.IO qualified as TIO import Data.Text.Lazy qualified as TL import Data.Text.Lazy.Builder qualified as TB @@ -61,68 +54,36 @@ import Data.Traversable import Data.Vector qualified as V import Ea.Genesis import GHC.Exts(the) -import Pact.ApiReq -import Pact.Types.ChainMeta -import Pact.Types.Command hiding (Payload) -import System.LogLevel +import GHC.Stack +import Pact.Core.ChainData +import Pact.Core.Command.Client +import Pact.Core.Command.Types +import Pact.Core.Command.Types qualified as Pact +import Pact.Core.StableEncoding +import Pact.JSON.Encode qualified as J import System.IO.Temp -import Text.Printf +import System.LogLevel --- main :: IO () main = do - registerVersion RecapDevelopment - registerVersion Development mapConcurrently_ id - [ recapDevnet - , devnet - , fastnet + [ devnet + -- , fastnet , instantnet - , pact5Instantnet - , pact53Transitionnet - , quirkedPact5Instantnet - , testnet04 - , testnet06 - , mainnet - , genTxModules - , genCoinV3Payloads - , genCoinV4Payloads - , genCoinV5Payloads - , genCoinV6Payloads + , quirkedGasInstantnet ] putStrLn "Done." where - recapDevnet = mkPayloads - [ recapDevelopment0 - , recapDevelopmentN - , recapDevelopmentKAD - ] devnet = mkPayloads [ fastDevelopment0 , fastDevelopmentN ] - fastnet = mkPayloads [fastTimedCPM0, fastTimedCPMN] + -- fastnet = mkPayloads [fastTimedCPM0, fastTimedCPMN] instantnet = mkPayloads [instantCPM0, instantCPMN] - pact5Instantnet = mkPayloads [pact5InstantCPM0, pact5InstantCPMN] - pact53Transitionnet = mkPayloads [pact53TransitionCPM0, pact53TransitionCPMN] - quirkedPact5Instantnet = mkPayloads [quirkedPact5InstantCPM0, quirkedPact5InstantCPMN] - testnet04 = mkPayloads [testnet040, testnet04N] - testnet06 = mkPayloads [testnet060, testnet06N] - mainnet = mkPayloads - [ mainnet0 - , mainnet1 - , mainnet2 - , mainnet3 - , mainnet4 - , mainnet5 - , mainnet6 - , mainnet7 - , mainnet8 - , mainnet9 - , mainnetKAD - ] + quirkedGasInstantnet = mkPayloads [quirkedGasInstantCPM0, quirkedGasInstantCPMN] show_ :: ChainIdRange -> String show_ (ChainIdRange n n') @@ -134,7 +95,7 @@ fullGenesisTag (Genesis _ tag cidr _ _ _ _ _) = tag <> T.pack (chainIdRangeTag c -- | Generate payloads for a traversable of txs -- -mkPayloads :: Traversable t => t Genesis -> IO () +mkPayloads :: HasCallStack => Traversable t => t Genesis -> IO () mkPayloads = traverse_ (\g -> writePayload g =<< mkPayload g) writePayload :: Genesis -> Text -> IO () @@ -144,11 +105,11 @@ writePayload gen payload = do -- | Generate a payload for a given list of genesis transactions -- -mkPayload :: Genesis -> IO Text -mkPayload gen@(Genesis v _ cidr@(ChainIdRange l u) c k a ns cc) = do - printf ("Generating Genesis Payload for %s on " <> show_ cidr <> "...\n") $ show v +mkPayload :: HasCallStack => Genesis -> IO Text +mkPayload gen@(Genesis v _ (ChainIdRange l u) c k a ns cc) = do + -- printf ("Generating Genesis Payload for %s on " <> show_ cidr <> "...\n") $ show v payloadModules <- for [l..u] $ \cid -> - genPayloadModule v (fullGenesisTag gen) (unsafeChainId cid) =<< mkChainwebTxs txs + withVersion v $ genPayloadModule (fullGenesisTag gen) (unsafeChainId cid) =<< mkChainwebTxs txs -- checks that the modules on each chain are the same evaluate $ the payloadModules where @@ -157,57 +118,37 @@ mkPayload gen@(Genesis v _ cidr@(ChainIdRange l u) c k a ns cc) = do txs :: [FilePath] txs = cc <> toList ns <> toList k <> toList a <> toList c -genCoinV3Payloads :: IO () -genCoinV3Payloads = genTxModule "CoinV3" [coinContractV3] - -genCoinV4Payloads :: IO () -genCoinV4Payloads = genTxModule "CoinV4" - [ fungibleXChainV1 - , coinContractV4 - ] - -genCoinV5Payloads :: IO () -genCoinV5Payloads = genTxModule "CoinV5" - [ coinContractV5 - ] - -genCoinV6Payloads :: IO () -genCoinV6Payloads = genTxModule "CoinV6" - [ coinContractV6 - ] - --------------------- -- Payload Generation --------------------- -genPayloadModule :: ChainwebVersion -> Text -> ChainId -> [Pact4.UnparsedTransaction] -> IO Text -genPayloadModule v tag cid cwTxs = - withTempRocksDb "chainweb-ea" $ \rocks -> - withBlockHeaderDb rocks v cid $ \bhdb -> do - let logger = genericLogger Warn TIO.putStrLn - pdb <- newPayloadDb - withSystemTempDirectory "ea-pact-db" $ \pactDbDir -> do - T2 payloadWO _ <- withSqliteDb cid logger pactDbDir False $ \env -> - withPactService v cid logger Nothing bhdb pdb env testPactServiceConfig $ - execNewGenesisBlock noMiner (V.fromList cwTxs) - return $ TL.toStrict $ TB.toLazyText $ payloadModuleCode tag payloadWO - -mkChainwebTxs :: [FilePath] -> IO [Pact4.UnparsedTransaction] +genPayloadModule :: HasCallStack => HasVersion => Text -> Chainweb.ChainId -> [Pact.Transaction] -> IO Text +genPayloadModule tag cid cwTxs = do + let logger = genericLogger Warn TIO.putStrLn + pdb <- newPayloadDb + withSystemTempDirectory "ea-pact-db" $ \pactDbDir -> runResourceT $ do + readWriteSql <- withSqliteDb cid logger pactDbDir False + roPool <- withReadSqlitePool cid pactDbDir + serviceEnv <- withPactService cid Nothing mempty logger Nothing pdb roPool readWriteSql defaultPactServiceConfig GeneratingGenesis + payloadWO <- liftIO $ execNewGenesisBlock logger serviceEnv (V.fromList cwTxs) + return $ TL.toStrict $ TB.toLazyText $ payloadModuleCode tag payloadWO + +mkChainwebTxs :: [FilePath] -> IO [Pact.Transaction] mkChainwebTxs txFiles = mkChainwebTxs' =<< traverse mkTx txFiles -mkChainwebTxs' :: [Command Text] -> IO [Pact4.UnparsedTransaction] +mkChainwebTxs' :: [Command Text] -> IO [Pact.Transaction] mkChainwebTxs' rawTxs = forM rawTxs $ \cmd -> do - let parsedCmd = - traverse Aeson.eitherDecodeStrictText cmd - case parsedCmd of - Left err -> error err - Right unparsedTx -> do - let t = toTxCreationTime (Time (TimeSpan 0)) - return $! Pact4.mkPayloadWithTextOldUnparsed <$> (unparsedTx & setTxTime t & setTTL defaultMaxTTL) - where - setTxTime = set (cmdPayload . pMeta . pmCreationTime) - setTTL = set (cmdPayload . pMeta . pmTTL) + let parsedTx = either (error . sshow) (cmdPayload . pMeta %~ _stableEncoding) $ Pact.unsafeParseCommand (T.encodeUtf8 <$> cmd) + -- TODO: why is this always the tx creation time? different versions + -- have different block creation times + let epochCreationTime = toTxCreationTime (Time (TimeSpan 0)) + let tx' = parsedTx + & set (cmdPayload . pMeta . pmCreationTime) epochCreationTime + & set (cmdPayload . pMeta . pmTTL) (TTLSeconds defaultMaxTTLSeconds) + return $! Pact.unsafeMkPayloadWithText + (tx' ^. cmdPayload) + (J.encodeStrict $ (tx' ^. cmdPayload) & pMeta %~ StableEncoding & fmap _pcCode) <$ parsedTx mkTx :: FilePath -> IO (Command Text) mkTx yamlFile = snd <$> mkApiReq yamlFile @@ -227,7 +168,7 @@ payloadModuleCode t p = foldMap (<> "\n") , "import qualified Data.Vector as V" , "import GHC.Stack" , "" - , "import Chainweb.Payload" + , "import Chainweb.Pact.Payload" , "import Chainweb.Utils (unsafeFromText, toText)" , "" , "payloadBlock :: HasCallStack => PayloadWithOutputs" @@ -278,66 +219,3 @@ sep s f = go . toList ------------------------------------------------------ -- Transaction Generation for coin v2 and remediations ------------------------------------------------------ - -genTxModules :: IO () -genTxModules = void $ do - genDevTxs - genMainnetTxs - genOtherTxs - gen20ChainRemeds - putStrLn "Done." - where - gen tag remeds = genTxModule tag $ upgrades <> remeds - genOtherTxs = gen "Other" [] - genDevTxs = gen "RecapDevelopment" - ["pact/coin-contract/remediations/devother/remediations.yaml"] - - genMain :: Int -> IO () - genMain chain = gen ("Mainnet" <> sshow chain) - ["pact/coin-contract/remediations/mainnet/remediations" <> show chain <> ".yaml"] - - genMainnetTxs = mapM_ genMain [0..9] - - gen20ChainRemeds = genTxModule "MainnetKAD" - ["pact/coin-contract/remediations/mainnet/remediations20chain.yaml"] - - upgrades = [fungibleAssetV2, coinContractV2] - -genTxModule :: Text -> [FilePath] -> IO () -genTxModule tag txFiles = do - putStrLn $ "Generating tx module for " ++ show tag - cwTxs <- mkChainwebTxs txFiles - - let encTxs = map quoteTx cwTxs - quoteTx tx = " \"" <> encTx tx <> "\"" - encTx = encodeB64UrlNoPaddingText . codecEncode Pact4.rawCommandCodec - modl = T.unlines $ startTxModule tag <> [T.intercalate "\n ,\n" encTxs] <> endTxModule - fileName = "src/Chainweb/Pact/Transactions/" <> tag <> "Transactions.hs" - - TIO.writeFile (T.unpack fileName) modl - -startTxModule :: Text -> [Text] -startTxModule tag = - [ "{-# LANGUAGE OverloadedStrings #-}" - , "" - , "-- This module is auto-generated. DO NOT EDIT IT MANUALLY." - , "" - , "module Chainweb.Pact.Transactions." <> tag <> "Transactions ( transactions ) where" - , "" - , "import Data.Bifunctor (first)" - , "import System.IO.Unsafe" - , "" - , "import qualified Chainweb.Pact4.Transaction as Pact4" - , "import Chainweb.Utils" - , "" - , "transactions :: [Pact4.Transaction]" - , "transactions =" - , " let decodeTx t =" - , " fromEitherM . (first (userError . show)) . codecDecode (Pact4.payloadCodec maxBound) =<< decodeB64UrlNoPaddingText t" - , " in unsafePerformIO $ mapM decodeTx [" - ] - -endTxModule :: [Text] -endTxModule = - [ " ]" - ] diff --git a/cwtools/ea/Ea/Genesis.hs b/cwtools/ea/Ea/Genesis.hs index 920020137b..f2079a0fd1 100644 --- a/cwtools/ea/Ea/Genesis.hs +++ b/cwtools/ea/Ea/Genesis.hs @@ -14,23 +14,18 @@ module Ea.Genesis , chainIdRangeTag -- * Devnet Genesis Txs -, recapDevelopment0 -, recapDevelopmentN -, recapDevelopmentKAD , fastDevelopment0 , fastDevelopmentN -- * Testing Genesis Txs -, fastTimedCPM0 -, fastTimedCPMN +-- , fastTimedCPM0 +-- , fastTimedCPMN , instantCPM0 , instantCPMN -, pact5InstantCPM0 -, pact5InstantCPMN -, pact53TransitionCPM0 -, pact53TransitionCPMN -, quirkedPact5InstantCPM0 -, quirkedPact5InstantCPMN +-- , pact5InstantCPM0 +-- , pact5InstantCPMN +, quirkedGasInstantCPM0 +, quirkedGasInstantCPMN -- * Testnet Genesis txs , testnet040 @@ -78,7 +73,6 @@ import Chainweb.Graph import Chainweb.Test.TestVersions import Chainweb.Version import Chainweb.Version.Development -import Chainweb.Version.RecapDevelopment import Chainweb.Version.Mainnet import Chainweb.Version.Testnet04 import Chainweb.Version.Testnet06 @@ -128,7 +122,7 @@ data Genesis = Genesis , _coinContract :: [FilePath] } deriving (Eq, Ord) -makeLensesFor [("_" <> fn, fn) | fn <- ["txChainIds", "coinbase", "keysets", "allocations", "namespaces", "coinContract"]] ''Genesis +makeLensesFor [("_" <> fn, fn) | fn <- ["txChainIds", "coinbase", "allocations"]] ''Genesis -- ---------------------------------------------------------------------- -- -- Coin Contract Essentials @@ -169,35 +163,6 @@ fungibleAssetV2 = "pact/coin-contract/v2/load-fungible-asset-v2.yaml" fungibleXChainV1 :: FilePath fungibleXChainV1 = "pact/coin-contract/v4/load-fungible-xchain-v1.yaml" --- ---------------------------------------------------------------------- -- --- Devnet - RecapDevelopment - -recapDevelopment0 :: Genesis -recapDevelopment0 = Genesis - { _version = RecapDevelopment - , _tag = "RecapDevelopment" - , _txChainIds = onlyChainId 0 - , _coinbase = Just dev0Grants - , _keysets = Just devKeysets - , _allocations = Just devAllocations - , _namespaces = Just devNs - , _coinContract = [fungibleAssetV1, coinContractV1, gasPayer] - } - -recapDevelopmentN :: Genesis -recapDevelopmentN = recapDevelopment0 - & txChainIds .~ mkChainIdRange 1 9 - & coinbase ?~ devNGrants - -recapDevelopmentKAD :: Genesis -recapDevelopmentKAD = recapDevelopment0 - & txChainIds .~ mkChainIdRange 10 19 - & coinbase ?~ devnetKadOps - & keysets .~ Nothing - & allocations .~ Nothing - & namespaces ?~ devNs - & coinContract .~ [fungibleAssetV1, fungibleAssetV2, coinContractV2Install, gasPayer] - -- ---------------------------------------------------------------------- -- -- Devnet - Development @@ -221,8 +186,8 @@ fastDevelopmentN = fastDevelopment0 devNs2 :: FilePath devNs2 = "pact/genesis/ns-v2.yaml" -devNs :: FilePath -devNs = "pact/genesis/ns-v1.yaml" +-- devNs :: FilePath +-- devNs = "pact/genesis/ns-v1.yaml" devKeysets :: FilePath devKeysets = "pact/genesis/devnet/keysets.yaml" @@ -236,15 +201,15 @@ devNGrants = "pact/genesis/devnet/grantsN.yaml" devAllocations :: FilePath devAllocations = "pact/genesis/devnet/allocations.yaml" -devnetKadOps :: FilePath -devnetKadOps = "pact/genesis/devnet/kad-ops-grants.yaml" +-- devnetKadOps :: FilePath +-- devnetKadOps = "pact/genesis/devnet/kad-ops-grants.yaml" -- ---------------------------------------------------------------------- -- -- CPM test versions instantCPM0 :: Genesis instantCPM0 = Genesis - { _version = instantCpmTestVersion petersenChainGraph + { _version = instantCpmTestVersion False petersenChainGraph , _tag = "InstantTimedCPM" , _txChainIds = onlyChainId 0 , _coinbase = Just fast0Grants @@ -259,27 +224,10 @@ instantCPMN = instantCPM0 & txChainIds .~ mkChainIdRange 1 9 & coinbase ?~ fastNGrants -pact5InstantCPM0 :: Genesis -pact5InstantCPM0 = Genesis - { _version = pact5InstantCpmTestVersion False petersenChainGraph - , _tag = "Pact5InstantTimedCPM" - , _txChainIds = onlyChainId 0 - , _coinbase = Just fast0Grants - , _keysets = Just fastKeysets - , _allocations = Just fastAllocations - , _namespaces = Just devNs2 - , _coinContract = [fungibleAssetV1, fungibleXChainV1, fungibleAssetV2, installCoinContractV6, gasPayer] - } - -pact5InstantCPMN :: Genesis -pact5InstantCPMN = pact5InstantCPM0 - & txChainIds .~ mkChainIdRange 1 9 - & coinbase ?~ fastNGrants - -pact53TransitionCPM0 :: Genesis -pact53TransitionCPM0 = Genesis - { _version = pact53TransitionCpmTestVersion petersenChainGraph - , _tag = "Pact53TransitionTimedCPM" +quirkedGasInstantCPM0 :: Genesis +quirkedGasInstantCPM0 = Genesis + { _version = quirkedGasInstantCpmTestVersion petersenChainGraph + , _tag = "QuirkedGasInstantTimedCPM" , _txChainIds = onlyChainId 0 , _coinbase = Just fast0Grants , _keysets = Just fastKeysets @@ -288,47 +236,30 @@ pact53TransitionCPM0 = Genesis , _coinContract = [fungibleAssetV1, fungibleXChainV1, fungibleAssetV2, installCoinContractV6, gasPayer] } -pact53TransitionCPMN :: Genesis -pact53TransitionCPMN = pact53TransitionCPM0 +quirkedGasInstantCPMN :: Genesis +quirkedGasInstantCPMN = quirkedGasInstantCPM0 & txChainIds .~ mkChainIdRange 1 9 & coinbase ?~ fastNGrants -quirkedPact5InstantCPM0 :: Genesis -quirkedPact5InstantCPM0 = Genesis - { _version = quirkedGasPact5InstantCpmTestVersion petersenChainGraph - , _tag = "QuirkedGasPact5InstantTimedCPM" - , _txChainIds = onlyChainId 0 - , _coinbase = Just fast0Grants - , _keysets = Just fastKeysets - , _allocations = Just fastAllocations - , _namespaces = Just devNs2 - , _coinContract = [fungibleAssetV1, fungibleXChainV1, fungibleAssetV2, installCoinContractV6, gasPayer] - } - -quirkedPact5InstantCPMN :: Genesis -quirkedPact5InstantCPMN = quirkedPact5InstantCPM0 - & txChainIds .~ mkChainIdRange 1 9 - & coinbase ?~ fastNGrants - -fastTimedCPM0 :: Genesis -fastTimedCPM0 = Genesis - { _version = fastForkingCpmTestVersion petersenChainGraph - , _tag = "FastTimedCPM" - , _txChainIds = onlyChainId 0 - , _coinbase = Just fast0Grants - , _keysets = Just fastKeysets - , _allocations = Just fastAllocations - , _namespaces = Just fastNs - , _coinContract = [fungibleAssetV1, coinContractV1, gasPayer] - } - -fastTimedCPMN :: Genesis -fastTimedCPMN = fastTimedCPM0 - & txChainIds .~ mkChainIdRange 1 9 - & coinbase ?~ fastNGrants - -fastNs :: FilePath -fastNs = "pact/genesis/ns-v1.yaml" +-- fastTimedCPM0 :: Genesis +-- fastTimedCPM0 = Genesis +-- { _version = fastForkingCpmTestVersion petersenChainGraph +-- , _tag = "FastTimedCPM" +-- , _txChainIds = onlyChainId 0 +-- , _coinbase = Just fast0Grants +-- , _keysets = Just fastKeysets +-- , _allocations = Just fastAllocations +-- , _namespaces = Just fastNs +-- , _coinContract = [fungibleAssetV1, coinContractV1, gasPayer] +-- } + +-- fastTimedCPMN :: Genesis +-- fastTimedCPMN = fastTimedCPM0 +-- & txChainIds .~ mkChainIdRange 1 9 +-- & coinbase ?~ fastNGrants + +-- fastNs :: FilePath +-- fastNs = "pact/genesis/ns-v1.yaml" fastKeysets :: FilePath fastKeysets = "pact/genesis/devnet/keysets.yaml" diff --git a/cwtools/evm-genesis/Main.hs b/cwtools/evm-genesis/Main.hs new file mode 100644 index 0000000000..c02def2b1c --- /dev/null +++ b/cwtools/evm-genesis/Main.hs @@ -0,0 +1,476 @@ +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE NumericUnderscores #-} +{-# LANGUAGE OverloadedStrings #-} + +-- | +-- Module: evm-genesis.Main +-- Copyright: Copyright © 2025 Kadena LLC. +-- License: MIT +-- Maintainer: Lars Kuhtz +-- Stability: experimental +-- +module Main +( main +) where + +import Chainweb.PayloadProvider.EVM.EngineAPI qualified as E +import Chainweb.PayloadProvider.EVM.EthRpcAPI qualified as E +import Chainweb.PayloadProvider.EVM.Header qualified as E +import Chainweb.PayloadProvider.EVM.JsonRPC qualified as E +import Chainweb.Utils +import Control.Monad +import Data.Aeson +import Data.String +import Data.Text qualified as T +import Ethereum.Misc qualified as E +import Ethereum.RLP qualified as E +import Network.HTTP.Client qualified as HTTP +import Network.URI +import Numeric.Natural +import System.Directory +import System.Environment +import System.IO +import System.Process +import Text.Printf +import Control.Retry + +-- -------------------------------------------------------------------------- -- +-- Main + +-- | This program generates chain-spec files, genesis blocks, and the respective +-- block hashes for EVMs on Chainweb networks. +-- +-- The results can be used to define the genesis information for the respective +-- networks in the chainweb-node code basis. +-- +main :: IO () +main = do + + -- parse command line + (n, cids, spec) <- getArgs >>= \case + [] -> error "No argument for the chainweb version provided. The version must be one of: 'mainnet', 'testnet', 'evm-testnet', or 'evm-development'." + ["mainnet"] -> do + let cids = [20..24] + return ("mainnet", cids, mainnetSpecFile) + ["testnet"] -> do + let cids = [20..24] + return ("testnet", cids, testnetSpecFile) + ["evm-testnet"] -> do + let cids = [20..24] + return ("evm-testnet", cids, evmTestnetSpecFile) + ["evm-development"] -> do + let cids = [20..24] + return ("evm-development", cids, evmDevnetSpecFile 20) + ["evm-development-singleton"] -> do + let cids = [0] + return ("evm-development-singleton", cids, evmDevnetSpecFile 0) + ["evm-development-pair"] -> do + let cids = [1] + return ("evm-development-pair", cids, evmDevnetSpecFile 1) + _ -> error "Invalid argument for the chainweb version provided. The version must be one of: 'mainnet', 'testnet', 'evm-testnet', or 'evm-development'." + + let specFileDir = "./chain-specs/" <> n + createDirectoryIfMissing True specFileDir + hdrs <- forM cids $ \cid -> do + let specFileName = specFileDir <> "/chain-spec-" <> show cid <> ".json" + encodeFile specFileName $ spec cid + hdr <- queryNode cid specFileName + return (cid, hdr) + + let payloadFileName = specFileDir <> "/payloads.json" + encodeFile payloadFileName $ + [ object + [ "chainId" .= cid + , "blockPayloadHash" .= E._hdrPayloadHash hdr + , "blockPayload" .= encodeB64UrlNoPaddingText (E.putRlpByteString hdr) + , "evmPayloadHeader" .= hdr + ] + | (cid, hdr) <- hdrs + ] + +-- -------------------------------------------------------------------------- -- +-- Querying the Node + +queryNode :: Natural -> FilePath -> IO E.Header +queryNode cid spec = withRethNode cid spec $ \uri -> do + ctx <- mkRpcCtx uri + getBlockAtNumber ctx 0 + +-- | Run reth node with chain-spec file at default port 8545 and execute an +-- action with the node URI. +-- +withRethNode :: Natural -> FilePath -> (URI -> IO a) -> IO a +withRethNode cid specfile act = + withCreateProcess runProc $ \_stdin _stdout _stderr _ph -> do + recoverAll policy $ \_ -> do + hPutStrLn stderr $ "Waiting for reth node for chain " <> show cid <> " to start..." + uri <- fromTextM (fromString ("http://localhost:" <> rethPort)) + r <- act uri + hFlush stdout + return r + where + policy = constantDelay 500_000 <> limitRetries 20 + runProc = proc cmd (dockerArgs <> rethArgs) + cmd = "docker" + dockerArgs = + [ "run" + , "--rm" + , "-t" + , "-p", rethPort <> ":" <> rethPort + , "--volume=" <> specfile <> ":/spec.json" + , "ghcr.io/kadena-io/kadena-reth:latest" + ] + rethArgs = + [ "-q" + , "node" + , "--chain=/spec.json" + , "--http" + , "--http.addr=0.0.0.0" + , "--http.port=" <> rethPort + , "--http.api=eth,rpc" + ] + -- we use different ports for each reth to avoid conflicts when ports are + -- not becoming available again fast enough + rethPort = show (8545 + cid) + +getBlockAtNumber + :: E.JsonRpcHttpCtx + -> E.BlockNumber + -> IO E.Header +getBlockAtNumber ctx n = do + r <- E.callMethodHttp + @E.Eth_GetBlockByNumber ctx (E.DefaultBlockNumber n, False) + case r of + Just h -> return h + Nothing -> error $ "Block not found: " <> show (E.DefaultBlockNumber n) + +mkRpcCtx :: URI -> IO E.JsonRpcHttpCtx +mkRpcCtx u = do + mgr <- HTTP.newManager HTTP.defaultManagerSettings + return $ E.JsonRpcHttpCtx + { E._jsonRpcHttpCtxManager = mgr + , E._jsonRpcHttpCtxURI = u + , E._jsonRpcHttpCtxMakeBearerToken = Nothing + } + +-- -------------------------------------------------------------------------- -- +-- Spec file settings + +-- | +-- +-- Chainweb System contract addresses: +-- +-- * Chainweb-chainId system contract: +-- 0x9b02c3e2dF42533e0FD166798B5A616f59DBd2cc +-- Keccak256("/Chainweb/Chain/Id/") +-- +-- * Native X-Chan redeem system contract: +-- 0x49eed2ac33f09e931bd660f0168417b9614485b6 (needs update) +-- Keccack256("/Chainweb/XChan/Redeem/") +-- +-- For existing Kadena EVM chains (evm-testnet), the respective account is +-- founded via a withdrawal that is injected by a consensus fork. +-- +-- * Create2 factory contract: +-- 0x4e59b44847b379578588920ca78fbf26c0b4956c +-- (cf. https://github.com/Arachnid/deterministic-deployment-proxy) +-- +-- Obsolete: +-- +-- * ERC-20 x-chain SPV Precompile address from KIP-34 (EthDenver 2025 demo): +-- 48c3b4d2757447601776837b6a85f31ef88a87bf +-- Keccak256("/Chainweb/KIP-34/VERIFY/SVP/") +-- (This is a precompile in kadena-reth and not included in the genesis +-- allocations) +-- +-- Ethereum System contracts: +-- +-- * EIP-4788 BeaconRoot Oracle. Included in Cancun fork. +-- * EIP-2935 Historical Block Hashes. Included in the Prague fork. +-- * EIP-7002 EL Triggered Withdrawal Requests. Included in Prague fork. +-- Not available on Kadena EVM networks +-- * EIP-7251 EL triggered Consolidations. Included in Prague fork. +-- Not available on Kadena EVM networks +-- +-- +baseSpecFile + :: Natural + -- ^ Ethereum network id offset + -> Natural + -- ^ offset for the chainweb chain id + -> Natural + -- ^ numeric chainweb chain id + -> Natural + -- ^ unix timestamp of the genesis block in textual hex encoding + -> [(Key, Value)] + -- ^ Allocations + -> Value +baseSpecFile netId offset cid genesisTime allocs = object + [ "config" .= object + [ "chainId" .= (netId + cid - offset) + , "daoForkSupport" .= True + , "terminalTotalDifficultyPassed" .= True + , "terminalTotalDifficulty" .= i 0 + , "daoForkBlock" .= i 0 + , "homesteadBlock" .= i 0 + , "eip150Block" .= i 0 + , "eip155Block" .= i 0 + , "eip158Block" .= i 0 + , "byzantiumBlock" .= i 0 + , "constantinopleBlock" .= i 0 + , "petersburgBlock" .= i 0 + , "istanbulBlock" .= i 0 + , "muirGlacierBlock" .= i 0 + , "berlinBlock" .= i 0 + , "londonBlock" .= i 0 + , "arrowGlacierBlock" .= i 0 + , "graphGlacierBlock" .= i 0 + , "mergeForkBlock" .= i 0 + , "mergeNetsplitBlock" .= i 0 + , "shanghaiTime" .= i 0 + , "cancunTime" .= i 0 + , "pragueTime" .= i 0 + , "blobSchedule" .= object + [ "cancun" .= object + [ "target" .= i 0 + , "max" .= i 0 + , "baseFeeUpdateFraction" .= i 3338477 + ] + , "prague" .= object + [ "target" .= i 0 + , "max" .= i 0 + , "baseFeeUpdateFraction" .= i 5007716 + ] + ] + ] + , "timestamp" .= printf @(Natural -> String) "0x%x" genesisTime + , "extraData" .= t "0x" + , "gasLimit" .= t "0x1c9c380" + , "alloc" .= object + ( chainwebChainIdAlloc + : eip4788Alloc + : eip2935Alloc + : allocs + ) + , "number" .= t "0x0" + , "nonce" .= t "0x0" + , "difficulty" .= t "0x0" + , "mixHash" .= zero32 @T.Text + , "coinbase" .= zero20 @T.Text + ] + where + i :: Natural -> Natural + i = id + + -- Chainweb System Contracts + + -- Chainweb Chain Id + -- Address: Keccak256("/Chainweb/Chain/Id/") + chainwebChainIdAlloc = "0x9b02c3e2df42533e0fd166798b5a616f59dbd2cc" .= object + [ "balance" .= t "0x0" + , "code" .= t "0x5f545f526004601cf3" + , "storage" .= object [ zero32 .= (printf "0x%064x" cid :: String) ] + ] + + -- Native X-Chan Redeem + -- Address: Keccack256("/Chainweb/XChan/Redeem/") + -- See below + + -- Official Ethreum System Contracts: + + -- EIP-4788 BeaconRoot Oracle. Included in Cancun fork + eip4788Alloc = "0x000F3df6D732807Ef1319fB7B8bB8522d0Beac02" .= object + [ "balance" .= t "0x0" + , "code" .= t "0x3373fffffffffffffffffffffffffffffffffffffffe14604d57602036146024575f5ffd5b5f35801560495762001fff810690815414603c575f5ffd5b62001fff01545f5260205ff35b5f5ffd5b62001fff42064281555f359062001fff015500" + ] + + -- EIP-2935 Historical Block Hashes. Included in the Prague fork + eip2935Alloc = "0x0000F90827F1C53a10cb7A02335B175320002935" .= object + [ "balance" .= t "0x0" + , "code" .= t "0x3373fffffffffffffffffffffffffffffffffffffffe14604657602036036042575f35600143038111604257611fff81430311604257611fff9006545f5260205ff35b5f5ffd5b5f35611fff60014303065500" + ] + + -- EIP-7002 EL Triggered Withdrawal Requests. Included in Prague fork + -- Not available on Kadena EVM networks + + -- EIP-7251 EL triggered Consolidations. Included in Prague fork + -- Not available on Kadena EVM networks + +zero32 :: IsString s => s +zero32 = "0x0000000000000000000000000000000000000000000000000000000000000000" + +zero20 :: IsString s => s +zero20 = "0x0000000000000000000000000000000000000000" + +t :: T.Text -> T.Text +t = id + +-- -------------------------------------------------------------------------- -- +-- Spec File For EVM Devnet + +-- | Intended only for local development and testing. It is not intended for use +-- with public networks. +-- +-- The keys for all allocations are publicly known. +-- +-- The Ethereum network chain ids are not officially registered and overlap with +-- the chain ids of other networks. +-- +-- The configuration of the network may change at any time. +-- +-- EVMs are available at block height 0. +-- +evmDevnetSpecFile + :: Natural + -- ^ offset for the chain id + -> Natural + -- numeric chainweb chain id + -> Value +evmDevnetSpecFile offset cid = baseSpecFile 1789 offset cid 0x684c5d2a + [ "0x8849BAbdDcfC1327Ad199877861B577cEBd8A7b6" .= object + [ "balance" .= t "0xd3c21bcecceda1000000" ] + , "0xFB8Fb7f9bdc8951040a6D195764905138F7462Ed" .= object + [ "balance" .= t "0xd3c21bcecceda1000000" ] + , "0x28f2d8ef4e0fe6B2E945cF5C33a0118a30a62354" .= object + [ "balance" .= t "0xd3c21bcecceda1000000" ] + , "0xa24a79678c9fffEF3E9A1f3cb7e51f88F173B3D5" .= object + [ "balance" .= t "0xd3c21bcecceda1000000" ] + , "0x47fAE86F6416e6115a80635238AFd2F18D69926B" .= object + [ "balance" .= t "0xd3c21bcecceda1000000" ] + , "0x87466A8266b9DFB3Dc9180a9c43946c4AB2c2cb2" .= object + [ "balance" .= t "0xd3c21bcecceda1000000" ] + , "0xA310Df9740eb6CC2F5E41C59C87e339142834eA4" .= object + [ "balance" .= t "0xd3c21bcecceda1000000" ] + , "0xD4EECE51cf451b60F59b271c5a748A8a9F16bC01" .= object + [ "balance" .= t "0xd3c21bcecceda1000000" ] + , "0xE08643a1C4786b573d739625FD268732dBB3d033" .= object + [ "balance" .= t "0xd3c21bcecceda1000000" ] + , "0x33018A42499f10B54d9dBCeBB71831C805D64cE3" .= object + [ "balance" .= t "0xd3c21bcecceda1000000" ] + , "0xa3659D39C901d5985450eE18a63B5b0811fDa521" .= object + [ "balance" .= t "0xd3c21bcecceda1000000" ] + , "0x7e99c2f1731D3750b74A2a0623C1F1DcB8cCa45e" .= object + [ "balance" .= t "0xd3c21bcecceda1000000" ] + , "0xFd70Bef78778Ce8554e79D97521b69183960C574" .= object + [ "balance" .= t "0xd3c21bcecceda1000000" ] + , "0xEE2722c39db6014Eacc5FBe43601136825b00977" .= object + [ "balance" .= t "0xd3c21bcecceda1000000" ] + , "0xeDD5a9185F9F1C04a011117ad61564415057bf8F" .= object + [ "balance" .= t "0xd3c21bcecceda1000000" ] + , "0x99b832eb3F76ac3277b00beADC1e487C594ffb4c" .= object + [ "balance" .= t "0xd3c21bcecceda1000000" ] + , "0xda1380825f827C6Ea92DFB547EF0a341Cbe21d77" .= object + [ "balance" .= t "0xd3c21bcecceda1000000" ] + , "0xc201d4A5E6De676938533A0997802634E859e78b" .= object + [ "balance" .= t "0xd3c21bcecceda1000000" ] + , "0x03e95Af0fC4971EdCa12E6d2d1540c28314d15d5" .= object + [ "balance" .= t "0xd3c21bcecceda1000000" ] + , "0x3492DA004098d728201fD82657f1207a6E5426bd" .= object + [ "balance" .= t "0xd3c21bcecceda1000000" ] + + -- Native X-Chan Redeem + -- Address: Keccack256("/Chainweb/XChan/Redeem/") + -- Redeem key address: 0xaD9923C37370BCbCF00ed194506D895084895696 + -- Redeem public key: 0x02d33118ef4a40a2bd797daf61e71488d465b1174c11ae582abfd2ce1c77d0a2a4 + , "0x49eed2ac33f09e931bd660f0168417b9614485b6" .= object + [ "balance" .= t "0xffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff" + , "code" .= t "0x346101535773ad9923c37370bcbcf00ed194506d8950848956965f9060209160c060e091610140946101609061018091609a9660e3360361014c575f359860203560f01c9360223560ea1c9860263560601c9a603a3599605a359b607a359a5f60db3560c01c9a03610145576004815f80739b02c3e2df42533e0fd166798b5a616f59dbd2cc5afa1561013e5751036101375760408593602060018580896080985f869c372086528181601f8601370191013760015afa1561013057510361012957602083918193720f3df6d732807ef1319fb7b8bb8522d0beac029082525afa1561012257510361011b5781548091038411610114575f84819482948284950190555af11561010d575f80f35b600a610157565b6009610157565b6008610157565b6007610157565b6006610157565b6005610157565b6004610157565b6003610157565b6002610157565b6001610157565b5f80fd5b5f5260205ffd" + ] + + -- Create2 factory contract + -- https://github.com/Arachnid/deterministic-deployment-proxy + , "0x4e59b44847b379578588920ca78fbf26c0b4956c" .= object + [ "balance" .= t "0x0" + , "code" .= t "0x7fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffe03601600081602082378035828234f58015156039578182fd5b8082525050506014600cf3" + ] + ] + +-- -------------------------------------------------------------------------- -- +-- Spec File For EVM Testnet + +-- | Used with the public Kadena EVM testnet. This is a temporary feature +-- testnet in preparation for the launch of EVM chains on the Kadena mainet and +-- the regular permanent Kadena testnet. +-- +-- The network is expected to be decommissioned after EVM chains have been +-- launched on the Kadena mainnet. +-- +-- Funds on the network have no economic value. +-- +-- The keys for the genesis allocations are held by the Kadena team. +-- +-- The EVM chains are available at block height 0. +-- +evmTestnetSpecFile + :: Natural + -- numeric chainweb chain id + -> Value +evmTestnetSpecFile cid = baseSpecFile 5920 20 cid 0x684c5d2a + -- faucet deployer address that corresponds to the DEPLOYER_PRIVATE_KEY + [ "0x9440d8ff19D278F401f49080BEfdDEFbE54F0eF2" .= object + [ "balance" .= t "0x422ca8b0a00a425000000" ] + -- is the faucet wallet address that correspondesds to the FAUCET_PRIVATE_KEY + , "0xE482e4F590D4155B51F4Fc21d64823f4d7854397" .= object + [ "balance" .= t "0x422ca8b0a00a425000000" ] + -- additional platform funds that are separate from the faucet accounts + , "0x8cb33Ecc40C31B79aE414a3D958B1b094B8993ce" .= object + [ "balance" .= t "0x422ca8b0a00a425000000" ] + + -- Native X-Chan Redeem + -- Address: Keccack256("/Chainweb/XChan/Redeem/") + -- Redeem key address: 0xcFc539fe84a4Dd6a50070CEFD638B869c745C58D + -- Redeem public key: 0x02afe12e765568cc0ca395e3aad1f42108afa63cdf08562c062afc94aeecc47eb5 + , "0x49eed2ac33f09e931bd660f0168417b9614485b6" .= object + [ "balance" .= t "0xffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff" + , "code" .= t "0x346101535773cfc539fe84a4dd6a50070cefd638b869c745c58d5f9060209160c060e091610140946101609061018091609a9660e3360361014c575f359860203560f01c9360223560ea1c9860263560601c9a603a3599605a359b607a359a5f60db3560c01c9a03610145576004815f80739b02c3e2df42533e0fd166798b5a616f59dbd2cc5afa1561013e5751036101375760408593602060018580896080985f869c372086528181601f8601370191013760015afa1561013057510361012957602083918193720f3df6d732807ef1319fb7b8bb8522d0beac029082525afa1561012257510361011b5781548091038411610114575f84819482948284950190555af11561010d575f80f35b600a610157565b6009610157565b6008610157565b6007610157565b6006610157565b6005610157565b6004610157565b6003610157565b6002610157565b6001610157565b5f80fd5b5f5260205ffd" + ] + ] + +-- -------------------------------------------------------------------------- -- +-- Spec File For Kadena Testnet + +-- | Used with the public Kadena testnet. This is a permament testnet that +-- has the same features and properties of the Kadena mainnet. It has the +-- purpose to facilitate testing of services and applications under the same +-- conditions as on the Kadena mainnet. +-- +-- Funds on the network have no economic value. +-- +-- The keys for the genesis allocations are held by the Kadena team. +-- +-- The EVM chains are launched at block height TODO. +-- +-- TODO: update genesis timestamp and block number +-- +testnetSpecFile + :: Natural + -- numeric chainweb chain id + -> Value +testnetSpecFile cid = baseSpecFile 5910 20 cid 0x684c5d2a + [ + error "testnetSpecFile: the EVM genesis allocations for mainnet are TBD" + ] + +-- -------------------------------------------------------------------------- -- +-- Spec File For Kadena Mainnet + +-- | Used with the public Kadena Mainnet. +-- +-- Allocations are funded out of the platform share of the Kadena mainnet. +-- The keys for the Allocations are not publicly known. +-- +-- The EVM chains are launched at block height TODO. +-- +-- TODO: update genesis timestamp and block number +-- +mainnetSpecFile + :: Natural + -- numeric chainweb chain id + -> Value +mainnetSpecFile cid = baseSpecFile 5900 20 cid 0x684c5d2a + [ + error "mainnetSpecFile: the EVM genesis allocations for mainnet are TBD" + ] + diff --git a/cwtools/header-dump/Main.hs b/cwtools/header-dump/Main.hs index 3a23e6943b..b80a704a49 100644 --- a/cwtools/header-dump/Main.hs +++ b/cwtools/header-dump/Main.hs @@ -32,9 +32,9 @@ import Chainweb.BlockHeight import Chainweb.ChainValue import Chainweb.Logger import Chainweb.Miner.Pact -import Chainweb.Payload -import Chainweb.Payload.PayloadStore -import Chainweb.Payload.PayloadStore.RocksDB +import Chainweb.Pact.Payload +import Chainweb.Pact.Payload.PayloadStore +import Chainweb.Pact.Payload.PayloadStore.RocksDB import Chainweb.Storage.Table.RocksDB import Chainweb.Time import Chainweb.TreeDB hiding (key) @@ -246,9 +246,9 @@ validateConfig o = do checkIfValidChain (_configChainId o) mapM_ (validateDirectory "database") (_configDatabasePath o) when (_configValidate o && isJust (_configChainId o)) - $ throwError $ "validation (--validate) can only be used if no particular chain is selected" + $ throwError "validation (--validate) can only be used if no particular chain is selected" where - chains = chainIds $ _configChainwebVersion o + chains = withVersion (_configChainwebVersion o) chainIds checkIfValidChain Nothing = return () checkIfValidChain (Just cid) = unless (HS.member cid chains) diff --git a/cwtools/known-graphs/Main.hs b/cwtools/known-graphs/Main.hs index df8b8559fb..40c0f4f87e 100644 --- a/cwtools/known-graphs/Main.hs +++ b/cwtools/known-graphs/Main.hs @@ -24,7 +24,7 @@ import System.Environment main :: IO () main = do args <- getArgs - graphs <- traverse (fromText . T.pack) args + graphs <- traverse (fromTextM . T.pack) args BL8.putStrLn $ encode $ knownChainGraph <$> graphs instance ToJSON KnownGraph where diff --git a/cwtools/run-nodes/Main.hs b/cwtools/run-nodes/Main.hs index 7d5c652d9c..148a905bcb 100644 --- a/cwtools/run-nodes/Main.hs +++ b/cwtools/run-nodes/Main.hs @@ -43,7 +43,7 @@ pNodes = option auto pVersion :: Parser ChainwebVersion pVersion = option (findKnownVersion =<< textReader) (long "chainweb-version" <> metavar "CHAINWEB_VERSION" - <> value (fastForkingCpmTestVersion petersenChainGraph) + <> value (barebonesTestVersion petersenChainGraph) <> help "Chainweb Version to run the Nodes with (default: timedCPM-petersen)") pConfig :: Parser FilePath diff --git a/cwtools/standalone-pruner/Main.hs b/cwtools/standalone-pruner/Main.hs new file mode 100644 index 0000000000..16e63bac57 --- /dev/null +++ b/cwtools/standalone-pruner/Main.hs @@ -0,0 +1,46 @@ +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE ApplicativeDo #-} + +module Main where + +import Options.Applicative + +import Control.Monad +import Data.Text.IO qualified as T +import System.LogLevel + +import Chainweb.BlockHeaderDB.PruneForks qualified as PruneForks +import Chainweb.Cut (unsafeMkCut) +import Chainweb.CutDB (readHighestCutHeaders, cutHashesTable) +import Chainweb.Logger +import Chainweb.Storage.Table.RocksDB (withRocksDb, modernDefaultOptions) +import Chainweb.Utils +import Chainweb.Version +import Chainweb.Version.Registry +import Chainweb.WebBlockHeaderDB + +main :: IO () +main = join $ + execParser $ info + (parser <**> helper) + (fullDesc + <> progDesc "Prune a chainweb-node block header database (rocksdb)" + <> header "standalone-pruner") + +parser :: Parser (IO ()) +parser = do + version <- option (findKnownVersion =<< textReader) (long "chainweb-version" <> short 'v') + dbDir <- textOption (long "rocksdb-path") + logLevel <- flag' Debug (long "verbose") <|> flag' Warn (long "quiet") <|> pure Info + doPrune <- + flag' PruneForks.ForcePrune (long "force") + <|> flag' PruneForks.PruneDryRun (long "dry-run") + <|> pure PruneForks.Prune + return $ withVersion version $ do + withRocksDb dbDir modernDefaultOptions $ \rdb -> do + let logger = genericLogger logLevel T.putStrLn + wbhdb <- initWebBlockHeaderDb rdb + let cutHashesStore = cutHashesTable rdb + initialCut <- unsafeMkCut <$> readHighestCutHeaders (logFunctionText logger) wbhdb cutHashesStore + PruneForks.pruneForks logger initialCut wbhdb doPrune (int PruneForks.safeDepth) + return () diff --git a/cwtools/txstream/Main.hs b/cwtools/txstream/Main.hs index 7c0d18ade2..93ad112d78 100644 --- a/cwtools/txstream/Main.hs +++ b/cwtools/txstream/Main.hs @@ -26,6 +26,7 @@ -- module Main (main) where +import Chainweb.BlockHash import Chainweb.BlockHeader import Chainweb.BlockHeaderDB.RemoteDB import Chainweb.BlockHeight @@ -33,8 +34,8 @@ import Chainweb.Cut.CutHashes import Chainweb.CutDB.RestAPI.Client import Chainweb.HostAddress import Chainweb.Logger -import Chainweb.Payload -import Chainweb.Payload.RestAPI.Client +import Chainweb.Pact.Payload +import Chainweb.Pact.Payload.RestAPI.Client import Chainweb.TreeDB import Chainweb.Utils import Chainweb.Version @@ -85,7 +86,7 @@ defaultConfig = Config { _configLogHandle = Y.StdOut , _configLogLevel = Y.Info , _configChainwebVersion = RecapDevelopment - , _configChainId = someChainId RecapDevelopment + , _configChainId = withVersion RecapDevelopment someChainId , _configNode = HostAddress (unsafeHostnameFromText "us1.tn1.chainweb.com") 443 , _configPretty = True , _configOutputs = True @@ -151,7 +152,6 @@ hostAddressBaseUrl h = BaseUrl devNetDb :: Config -> Manager -> LogFunction -> IO RemoteDb devNetDb c mgr l = mkDb - (_configChainwebVersion c) (_configChainId c) mgr l @@ -160,25 +160,22 @@ devNetDb c mgr l = mkDb -- TreeDB mkDb - :: HasChainwebVersion v - => HasChainId cid - => v - -> cid + :: HasChainId cid + => cid -> Manager -> LogFunction -> HostAddress -> IO RemoteDb -mkDb v c mgr logg h = do +mkDb c mgr logg h = do return $ RemoteDb (env mgr h) (ALogFunction logg) - (_chainwebVersion v) (_chainId c) -- -------------------------------------------------------------------------- -- -- Payload Data -run :: Config -> LogFunction -> IO () +run :: HasVersion => Config -> LogFunction -> IO () run config logg = do mgr <- newTlsManager txStream config mgr logg @@ -215,11 +212,12 @@ prettyCommand p (bh, c) = T.decodeUtf8 , "payload" .= either (const $ String $ _cmdPayload c) (id @Value) - (eitherDecodeStrict' $ T.encodeUtf8 $ _cmdPayload $ c) + (eitherDecodeStrict' $ T.encodeUtf8 $ _cmdPayload c) ] txStream - :: Config + :: HasVersion + => Config -> Manager -> LogFunction -> S.Stream (Of (BlockHeight, Command T.Text)) IO () @@ -227,7 +225,7 @@ txStream config mgr logg = do hdb <- liftIO $ devNetDb config mgr logg c <- liftIO $ devNetCut config mgr - let h = _bhwhHash $ _cutHashes c ^?! ix (_configChainId config) + let h = _rankedBlockHashHash $ _cutHashes c ^?! ix (_configChainId config) getBranch hdb mempty (HS.singleton (UpperBound h)) & S.chain (logg @T.Text Debug . sshow) @@ -243,7 +241,7 @@ txStream config mgr logg = do -- -------------------------------------------------------------------------- -- -- PayloadWithOutputs -runOutputs :: Config -> LogFunction -> IO () +runOutputs :: HasVersion => Config -> LogFunction -> IO () runOutputs config logg = do mgr <- newTlsManager txOutputsStream config mgr logg @@ -269,12 +267,13 @@ prettyCommandWithOutputs p (bh, c, o) = T.decodeUtf8 , "payload" .= either (const $ String $ _cmdPayload c) (id @Value) - (eitherDecodeStrict' $ T.encodeUtf8 $ _cmdPayload $ c) + (eitherDecodeStrict' $ T.encodeUtf8 $ _cmdPayload c) , "output" .= J.toJsonViaEncode o ] txOutputsStream - :: Config + :: HasVersion + => Config -> Manager -> LogFunction -> S.Stream (Of (BlockHeight, Command T.Text, CommandResult T.Text)) IO () @@ -282,7 +281,7 @@ txOutputsStream config mgr logg = do hdb <- liftIO $ devNetDb config mgr logg cut <- liftIO $ devNetCut config mgr - let h = _bhwhHash $ _cutHashes cut ^?! ix (_configChainId config) + let h = _rankedBlockHashHash $ _cutHashes cut ^?! ix (_configChainId config) getBranch hdb mempty (HS.singleton (UpperBound h)) & S.chain (logg @T.Text Debug . sshow) @@ -303,55 +302,64 @@ txOutputsStream config mgr logg = do -- -------------------------------------------------------------------------- -- -- Cut -devNetCut :: Config -> Manager -> IO CutHashes -devNetCut config mgr = runClientM (cutGetClient ver) (env mgr node) >>= \case +devNetCut :: HasVersion => Config -> Manager -> IO CutHashes +devNetCut config mgr = runClientM cutGetClient (env mgr node) >>= \case Left e -> error (show e) Right x -> return x where - ver = _configChainwebVersion config node = _configNode config -- -------------------------------------------------------------------------- -- -- Payloads -devNetPayload :: Config -> Manager -> BlockHeight -> BlockPayloadHash -> IO PayloadData -devNetPayload config mgr h x = runClientM (payloadClient ver cid x (Just h)) (env mgr node) >>= \case +devNetPayload + :: HasVersion + => Config + -> Manager + -> BlockHeight + -> BlockPayloadHash + -> IO PayloadData +devNetPayload config mgr h x = runClientM (payloadClient cid x (Just h)) (env mgr node) >>= \case Left e -> error (show e) Right a -> return a where cid = _configChainId config - ver = _configChainwebVersion config node = _configNode config -devNetPayloadWithOutput :: Config -> Manager -> BlockHeight -> BlockPayloadHash -> IO PayloadWithOutputs +devNetPayloadWithOutput + :: HasVersion + => Config + -> Manager + -> BlockHeight + -> BlockPayloadHash + -> IO PayloadWithOutputs devNetPayloadWithOutput config mgr h x - = runClientM (outputsClient ver cid x (Just h)) (env mgr node) >>= \case + = runClientM (outputsClient cid x (Just h)) (env mgr node) >>= \case Left e -> error (show e) Right a -> return a where cid = _configChainId config - ver = _configChainwebVersion config node = _configNode config -- -------------------------------------------------------------------------- -- -- Main mainWithConfig :: Config -> IO () -mainWithConfig config = withLog $ \logger -> do +mainWithConfig config = withLog $ \logger -> withVersion ver $ do let logg :: LogFunction logg = logFunction $ logger & addLabel ("host", toText $ _configNode config) & addLabel ("version", toText $ _versionName $ _configChainwebVersion config) & addLabel ("chain", toText $ _configChainId config) liftIO $ do - registerVersion (_configChainwebVersion config) if _configOutputs config then runOutputs config logg else run config logg where + ver = _configChainwebVersion config logconfig = Y.defaultLogConfig - & Y.logConfigLogger . Y.loggerConfigThreshold .~ (_configLogLevel config) + & Y.logConfigLogger . Y.loggerConfigThreshold .~ _configLogLevel config & Y.logConfigBackend . Y.handleBackendConfigHandle .~ _configLogHandle config withLog inner = Y.withHandleBackend_ logText (logconfig ^. Y.logConfigBackend) $ \backend -> Y.withLogger (logconfig ^. Y.logConfigLogger) backend inner diff --git a/libs/chainweb-storage/chainweb-storage.cabal b/libs/chainweb-storage/chainweb-storage.cabal index bb40642032..097924f08e 100644 --- a/libs/chainweb-storage/chainweb-storage.cabal +++ b/libs/chainweb-storage/chainweb-storage.cabal @@ -31,6 +31,7 @@ library Chainweb.Storage.Table Chainweb.Storage.Table.Forgetful Chainweb.Storage.Table.HashMap + Chainweb.Storage.Table.Map Chainweb.Storage.Table.RocksDB Chainweb.Storage.DedupStore build-depends: diff --git a/libs/chainweb-storage/src/Chainweb/Storage/Table.hs b/libs/chainweb-storage/src/Chainweb/Storage/Table.hs index 1efc7fe37e..1c613decd5 100644 --- a/libs/chainweb-storage/src/Chainweb/Storage/Table.hs +++ b/libs/chainweb-storage/src/Chainweb/Storage/Table.hs @@ -49,6 +49,7 @@ module Chainweb.Storage.Table , tableLookupM , casLookupM , TableException (..) + , NullCas(..) ) where @@ -76,6 +77,9 @@ class Eq (CasKeyType v) => IsCasValue v where type CasKeyType v casKey :: v -> CasKeyType v +-- -------------------------------------------------------------------------- -- +-- Readble Stores + -- | Read-Only View of a Key-Value Store -- class ReadableTable t k v | t -> k v where @@ -94,12 +98,19 @@ type ReadableTable1 t = forall k v. ReadableTable (t k v) k v class ReadableTable t k v => Table t k v | t -> k v where tableInsert :: t -> k -> v -> IO () tableInsertBatch :: t -> [(k, v)] -> IO () - tableInsertBatch t kvs = traverse_ (uncurry (tableInsert t)) kvs + tableInsertBatch t = traverse_ (uncurry (tableInsert t)) tableDelete :: t -> k -> IO () tableDeleteBatch :: t -> [k] -> IO () - tableDeleteBatch t ks = traverse_ (tableDelete t) ks + tableDeleteBatch t = traverse_ (tableDelete t) type Table1 t = forall k v. Table (t k v) k v +data NullCas k v = NullCas +instance ReadableTable (NullCas k v) k v where + tableLookup _ _ = return Nothing + +-- -------------------------------------------------------------------------- -- +-- Writeable Stores + type Cas t v = Table t (CasKeyType v) v casInsert :: (IsCasValue v, Cas t v) => t -> v -> IO () @@ -114,6 +125,9 @@ casDelete t = tableDelete t . casKey casDeleteBatch :: (IsCasValue v, Cas t v) => t -> [v] -> IO () casDeleteBatch t = tableDeleteBatch t . fmap casKey +-- -------------------------------------------------------------------------- -- +-- Iterable Stores + class (Table t k v, Iterator i k v) => IterableTable t i k v | t -> i k v where -- the created iterator must be positioned at the start of the table. withTableIterator :: t -> (i -> IO a) -> IO a @@ -132,15 +146,18 @@ class Iterator i k v | i -> k v where iterPrev :: i -> IO () iterEntry :: i -> IO (Maybe (Entry k v)) iterKey :: i -> IO (Maybe k) - iterKey i = (fmap . fmap) (\(Entry k _) -> k) $ iterEntry i + iterKey i = fmap (\(Entry k _) -> k) <$> iterEntry i iterValue :: i -> IO (Maybe v) - iterValue i = (fmap . fmap) (\(Entry _ v) -> v) $ iterEntry i + iterValue i = fmap (\(Entry _ v) -> v) <$> iterEntry i iterValid :: i -> IO Bool iterValid i = isJust <$> iterKey i type Iterator1 i = forall k v. Iterator (i k v) k v type CasIterator i v = Iterator i (CasKeyType v) v +-- -------------------------------------------------------------------------- -- +-- Utils + -- | A newtype wrapper that takes only a single type constructor. This useful in -- situations where a Higher Order type constructor for a CAS is required. A -- type synonym doesn't work in this situation because type synonyms must be diff --git a/libs/chainweb-storage/src/Chainweb/Storage/Table/Map.hs b/libs/chainweb-storage/src/Chainweb/Storage/Table/Map.hs new file mode 100644 index 0000000000..047a037962 --- /dev/null +++ b/libs/chainweb-storage/src/Chainweb/Storage/Table/Map.hs @@ -0,0 +1,74 @@ +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE ImportQualifiedPost #-} + +-- | +-- Module: Chainweb.Storage.Table.HashMap +-- Copyright: Copyright © 2019 Kadena LLC. +-- License: MIT +-- Maintainer: Lars Kuhtz +-- Stability: experimental +-- Description: +-- +-- A thread-safe in-memory 'Table' implementation based on 'M.HashMap'. +-- +module Chainweb.Storage.Table.Map +( MapTable +, emptyTable +, toList +, size +, deleteLt +, deleteLe +) where + +import Chainweb.Storage.Table +import Control.Concurrent.STM.TVar +import Control.Monad ((<$!>)) +import Control.Monad.STM +import Data.Map.Strict qualified as M + +-- | An 'IsTable' implementation that is base on 'M.HashMap'. +-- +newtype MapTable k v = MapTable (TVar (M.Map k v)) + +instance (Ord k, Eq k) => ReadableTable (MapTable k v) k v where + tableLookup (MapTable var) k = M.lookup k <$!> readTVarIO var + tableMember (MapTable var) k = + M.member k <$> readTVarIO var + +instance (Ord k, Eq k) => Table (MapTable k v) k v where + tableInsert (MapTable var) k v = + atomically $ modifyTVar' var (M.insert k v) + tableDelete (MapTable var) k = + atomically $ modifyTVar' var (M.delete k) + +-- | Create new empty CAS +-- +emptyTable :: (Ord k, Eq k) => IO (MapTable k v) +emptyTable = MapTable <$> newTVarIO mempty + +-- | Return all entries of CAS as List +-- +toList :: MapTable k v -> IO [v] +toList (MapTable var) = M.elems <$!> readTVarIO var + +-- | The number of items in the CAS +-- +size :: MapTable k v -> IO Int +size (MapTable var) = M.size <$!> readTVarIO var + +-- | Delete all keys that are strictly smaller than the given key +-- +deleteLt :: Ord k => MapTable k v -> k -> IO () +deleteLt (MapTable var) k = + atomically $ modifyTVar' var $ M.dropWhileAntitone (< k) + +-- | Delete all keys that are smaller or equal than the given key +-- +deleteLe :: Ord k => MapTable k v -> k -> IO () +deleteLe (MapTable var) k = + atomically $ modifyTVar' var $ M.dropWhileAntitone (<= k) diff --git a/lol b/lol new file mode 100644 index 0000000000..e69de29bb2 diff --git a/node/chainweb-node.cabal b/node/chainweb-node.cabal index ee19babd42..1f9666882b 100644 --- a/node/chainweb-node.cabal +++ b/node/chainweb-node.cabal @@ -114,6 +114,7 @@ executable chainweb-node , lens >= 4.17 , loglevel >= 0.1 , managed >= 1.0 + , resourcet >= 1.2 , streaming >= 0.2 , text >= 2.0 , time >= 1.12.2 diff --git a/node/src/ChainwebNode.hs b/node/src/ChainwebNode.hs index d07ee9cced..5dbc40d940 100644 --- a/node/src/ChainwebNode.hs +++ b/node/src/ChainwebNode.hs @@ -46,59 +46,64 @@ module Main , main ) where +import Configuration.Utils hiding (Error) +import Configuration.Utils.Validation (validateFilePath) + +import Control.Concurrent +import Control.Concurrent.Async +import Control.DeepSeq +import Control.Exception +import Control.Lens hiding ((.=)) +import Control.Monad +import Control.Monad.Managed +import Control.Monad.Trans.Resource (runResourceT) + +import Data.Maybe +import Data.Text (Text) +import Data.Typeable + +import GHC.Generics hiding (from) +import GHC.Stack +import GHC.Stats + +import qualified Network.HTTP.Client as HTTP +import qualified Network.HTTP.Client.TLS as HTTPS + +import System.Directory +import System.FilePath +import System.IO +import qualified System.Logger as L +import System.LogLevel +import System.Mem + +-- internal modules + import Chainweb.BlockHeader +import Chainweb.BlockHeaderDB.PruneForks (PruneStats(..)) import Chainweb.Chainweb import Chainweb.Chainweb.Configuration import Chainweb.Chainweb.CutResources import Chainweb.Counter import Chainweb.Cut.CutHashes import Chainweb.CutDB -import Chainweb.Difficulty import Chainweb.Logger import Chainweb.Logging.Config import Chainweb.Logging.Miner -import Chainweb.Mempool.Consensus (ReintroducedTxsLog) -import Chainweb.Mempool.InMemTypes (MempoolStats(..)) -import Chainweb.Miner.Coordinator (MiningStats) +import Chainweb.Pact.Mempool.InMemTypes (MempoolStats(..)) import Chainweb.Pact.Backend.DbCache (DbCacheStats) import Chainweb.Pact.RestAPI.Server (PactCmdLog(..)) -import Chainweb.Pact.Service.PactQueue (PactQueueStats) import Chainweb.Pact.Types -import Chainweb.Payload -import Chainweb.Payload.PayloadStore -import Chainweb.Storage.Table.RocksDB +import Chainweb.Scheduler (Scheduler, scheduleEvery, withScheduler) import Chainweb.Time import Chainweb.Utils import Chainweb.Utils.RequestLog import Chainweb.Version import Chainweb.Version.Mainnet -import Chainweb.Version.Registry -import Configuration.Utils hiding (Error) -import Configuration.Utils.Validation (validateFilePath) -import Control.Concurrent -import Control.Concurrent.Async -import Control.DeepSeq -import Control.Exception -import Control.Lens hiding ((.=)) -import Control.Monad -import Control.Monad.Managed + +import Chainweb.Storage.Table.RocksDB import Data.LogMessage -import Data.Text (Text) -import Data.Typeable -import GHC.Generics hiding (from) -import GHC.Stack -import GHC.Stats -import Network.HTTP.Client qualified as HTTP -import Network.HTTP.Client.TLS qualified as HTTPS import P2P.Node import PkgInfo -import Streaming.Prelude qualified as S -import System.Directory -import System.FilePath -import System.IO -import System.LogLevel -import System.Logger qualified as L -import System.Mem import Utils.CheckRLimits import Utils.InstallSignalHandlers import Utils.Logging @@ -112,7 +117,6 @@ data ChainwebNodeConfiguration = ChainwebNodeConfiguration { _nodeConfigChainweb :: !ChainwebConfiguration , _nodeConfigLog :: !LogConfig , _nodeConfigDatabaseDirectory :: !(Maybe FilePath) - , _nodeConfigResetChainDbs :: !Bool } deriving (Show, Eq, Generic) @@ -124,7 +128,6 @@ defaultChainwebNodeConfiguration = ChainwebNodeConfiguration , _nodeConfigLog = defaultLogConfig & logConfigLogger . L.loggerConfigThreshold .~ level , _nodeConfigDatabaseDirectory = Nothing - , _nodeConfigResetChainDbs = False } where level = L.Info @@ -140,7 +143,6 @@ instance ToJSON ChainwebNodeConfiguration where [ "chainweb" .= _nodeConfigChainweb o , "logging" .= _nodeConfigLog o , "databaseDirectory" .= _nodeConfigDatabaseDirectory o - , "resetChainDatabases" .= _nodeConfigResetChainDbs o ] instance FromJSON (ChainwebNodeConfiguration -> ChainwebNodeConfiguration) where @@ -148,18 +150,14 @@ instance FromJSON (ChainwebNodeConfiguration -> ChainwebNodeConfiguration) where <$< nodeConfigChainweb %.: "chainweb" % o <*< nodeConfigLog %.: "logging" % o <*< nodeConfigDatabaseDirectory ..: "databaseDirectory" % o - <*< nodeConfigResetChainDbs ..: "resetChainDatabases" % o pChainwebNodeConfiguration :: MParser ChainwebNodeConfiguration pChainwebNodeConfiguration = id <$< nodeConfigChainweb %:: pChainwebConfiguration - <*< nodeConfigLog %:: pLogConfig + <*< parserOptionGroup "Logging" (nodeConfigLog %:: pLogConfig) <*< nodeConfigDatabaseDirectory .:: fmap Just % textOption % long "database-directory" <> help "directory where the databases are persisted" - <*< nodeConfigResetChainDbs .:: enableDisableFlag - % long "reset-chain-databases" - <> help "Reset the chain databases for all chains on startup" getRocksDbDir :: HasCallStack => ChainwebNodeConfiguration -> IO FilePath getRocksDbDir conf = (\base -> base "0" "rocksDb") <$> getDbBaseDir conf @@ -181,26 +179,20 @@ getDbBaseDir conf = case _nodeConfigDatabaseDirectory conf of -- -------------------------------------------------------------------------- -- -- Monitors --- | Run a monitor function with a logger forever. If the monitor function exist --- or fails the event is logged and the function is restarted. --- --- In order to prevent the function to spin in case of a persistent failure --- cause, only 10 immediate restart are allowed. After that restart is throttled --- to at most one restart every 10 seconds. +-- | Schedule a monitor action on the shared background job scheduler. The +-- first run happens one interval after the node started. -- -runMonitorLoop :: Logger logger => Text -> logger -> IO () -> IO () -runMonitorLoop actionLabel logger = runForeverThrottled - (logFunction logger) - actionLabel - 10 -- 10 bursts in case of failure - (10 * mega) -- allow restart every 10 seconds in case of failure - -runCutMonitor :: Logger logger => logger -> CutDb tbl -> IO () -runCutMonitor logger db = L.withLoggerLabel ("component", "cut-monitor") logger $ \l -> - runMonitorLoop "ChainwebNode.runCutMonitor" l $ do +runCutMonitor + :: HasVersion + => Logger logger + => Scheduler + -> logger + -> CutDb logger + -> IO () +runCutMonitor sched logger db = L.withLoggerLabel ("component", "cut-monitor") logger $ \l -> + scheduleEvery sched "ChainwebNode.runCutMonitor" 15_000_000 $ do logFunctionJson l Info . cutToCutHashes Nothing =<< _cut db - threadDelay 15_000_000 data BlockUpdate = BlockUpdate { _blockUpdateBlockHeader :: !(ObjectEncoded BlockHeader) @@ -210,7 +202,7 @@ data BlockUpdate = BlockUpdate } deriving (Show, Eq, Ord, Generic, NFData) -instance ToJSON BlockUpdate where +instance HasVersion => ToJSON BlockUpdate where toEncoding o = pairs $ "header" .= _blockUpdateBlockHeader o <> "orphaned" .= _blockUpdateOrphaned o @@ -226,33 +218,24 @@ instance ToJSON BlockUpdate where {-# INLINE toEncoding #-} {-# INLINE toJSON #-} -runBlockUpdateMonitor :: CanReadablePayloadCas tbl => Logger logger => logger -> CutDb tbl -> IO () -runBlockUpdateMonitor logger db = L.withLoggerLabel ("component", "block-update-monitor") logger $ \l -> - runMonitorLoop "ChainwebNode.runBlockUpdateMonitor" l $ do - blockDiffStream db - & S.mapM toUpdate - & S.mapM_ (logFunctionJson l Info) - where - payloadDb = view cutDbPayloadDb db - - txCount :: BlockHeader -> IO Int - txCount bh = do - bp <- lookupPayloadDataWithHeight payloadDb (Just $ view blockHeight bh) (view blockPayloadHash bh) >>= \case - Nothing -> error "block payload not found" - Just x -> return x - return $ length $ view payloadDataTransactions bp - - toUpdate :: Either BlockHeader BlockHeader -> IO BlockUpdate - toUpdate (Right bh) = BlockUpdate - <$> pure (ObjectEncoded bh) -- _blockUpdateBlockHeader - <*> pure False -- _blockUpdateOrphaned - <*> txCount bh -- _blockUpdateTxCount - <*> pure (difficultyToDouble (targetToDifficulty (view blockTarget bh))) -- _blockUpdateDifficultyDouble - toUpdate (Left bh) = BlockUpdate - <$> pure (ObjectEncoded bh) -- _blockUpdateBlockHeader - <*> pure True -- _blockUpdateOrphaned - <*> ((0 -) <$> txCount bh) -- _blockUpdateTxCount - <*> pure (difficultyToDouble (targetToDifficulty (view blockTarget bh))) -- _blockUpdateDifficultyDouble +-- runBlockUpdateMonitor :: Logger logger => logger -> CutDb -> IO () +-- runBlockUpdateMonitor logger db = L.withLoggerLabel ("component", "block-update-monitor") logger $ \l -> +-- runMonitorLoop "ChainwebNode.runBlockUpdateMonitor" l $ do +-- blockDiffStream db +-- & S.mapM toUpdate +-- & S.mapM_ (logFunctionJson l Info) +-- where +-- toUpdate :: Either BlockHeader BlockHeader -> IO BlockUpdate +-- toUpdate (Right bh) = BlockUpdate +-- <$> pure (ObjectEncoded bh) -- _blockUpdateBlockHeader +-- <*> pure False -- _blockUpdateOrphaned +-- <*> txCount bh -- _blockUpdateTxCount +-- <*> pure (difficultyToDouble (targetToDifficulty (view blockTarget bh))) -- _blockUpdateDifficultyDouble +-- toUpdate (Left bh) = BlockUpdate +-- <$> pure (ObjectEncoded bh) -- _blockUpdateBlockHeader +-- <*> pure True -- _blockUpdateOrphaned +-- <*> ((0 -) <$> txCount bh) -- _blockUpdateTxCount +-- <*> pure (difficultyToDouble (targetToDifficulty (view blockTarget bh))) -- _blockUpdateDifficultyDouble -- type CutLog = HM.HashMap ChainId (ObjectEncoded BlockHeader) @@ -264,43 +247,40 @@ deriving instance NFData RTSStats deriving instance ToJSON GCDetails deriving instance ToJSON RTSStats -runRtsMonitor :: Logger logger => logger -> IO () -runRtsMonitor logger = L.withLoggerLabel ("component", "rts-monitor") logger go +runRtsMonitor :: Logger logger => Scheduler -> logger -> IO () +runRtsMonitor sched logger = L.withLoggerLabel ("component", "rts-monitor") logger go where go l = getRTSStatsEnabled >>= \case False -> do logFunctionText l Warn "RTS Stats isn't enabled. Run with '+RTS -T' to enable it." True -> do - runMonitorLoop "Chainweb.Node.runRtsMonitor" l $ do - logFunctionText l Debug $ "logging RTS stats" + scheduleEvery sched "Chainweb.Node.runRtsMonitor" 60_000_000 $ do + logFunctionText l Debug "logging RTS stats" stats <- getRTSStats logFunctionJson logger Info stats - approximateThreadDelay 60_000_000 {- 1 minute -} -runQueueMonitor :: Logger logger => logger -> CutDb tbl -> IO () -runQueueMonitor logger cutDb = L.withLoggerLabel ("component", "queue-monitor") logger go +runQueueMonitor :: Logger logger => Scheduler -> logger -> CutDb logger -> IO () +runQueueMonitor sched logger cutDb = L.withLoggerLabel ("component", "queue-monitor") logger go where go l = do - runMonitorLoop "ChainwebNode.runQueueMonitor" l $ do - logFunctionText l Debug $ "logging cut queue stats" + scheduleEvery sched "ChainwebNode.runQueueMonitor" 60_000_000 $ do + logFunctionText l Debug "logging cut queue stats" stats <- getQueueStats cutDb logFunctionJson logger Info stats - approximateThreadDelay 60_000_000 {- 1 minute -} data DbStats = DbStats { dbStatsName :: !Text , dbStatsSize :: !Integer } deriving (Generic, NFData, ToJSON) -runDatabaseMonitor :: Logger logger => logger -> FilePath -> FilePath -> IO () -runDatabaseMonitor logger rocksDbDir pactDbDir = L.withLoggerLabel ("component", "database-monitor") logger go +runDatabaseMonitor :: Logger logger => Scheduler -> logger -> FilePath -> FilePath -> IO () +runDatabaseMonitor sched logger rocksDbDir pactDbDir = L.withLoggerLabel ("component", "database-monitor") logger go where go l = do - runMonitorLoop "ChainwebNode.runDatabaseMonitor" l $ do - logFunctionText l Debug $ "logging database stats" + scheduleEvery sched "ChainwebNode.runDatabaseMonitor" 1_200_000_000 {- 20 minutes -} $ do + logFunctionText l Debug "logging database stats" logFunctionJson l Info . DbStats "rocksDb" =<< sizeOf rocksDbDir logFunctionJson l Info . DbStats "pactDb" =<< sizeOf pactDbDir - approximateThreadDelay 1_200_000_000 {- 20 minutes -} sizeOf path = do dir <- doesDirectoryExist path file <- doesFileExist path @@ -314,48 +294,46 @@ runDatabaseMonitor logger rocksDbDir pactDbDir = L.withLoggerLabel ("component", -- -------------------------------------------------------------------------- -- -- Run Node -node :: HasCallStack => Logger logger => ChainwebNodeConfiguration -> logger -> IO () +node :: HasCallStack => HasVersion => Logger logger => ChainwebNodeConfiguration -> logger -> IO () node conf logger = do - dbBaseDir <- getDbBaseDir conf - when (_nodeConfigResetChainDbs conf) $ removeDirectoryRecursive dbBaseDir rocksDbDir <- getRocksDbDir conf pactDbDir <- getPactDbDir conf dbBackupsDir <- getBackupsDir conf withRocksDb' <- - if _configOnlySyncPact cwConf || _configReadOnlyReplay cwConf + if _configReadOnlyReplay cwConf then - if _cutPruneChainDatabase (_configCuts cwConf) == GcNone - then withReadOnlyRocksDb <$ logFunctionText logger Info "Opening RocksDB in read-only mode" - else withRocksDb <$ logFunctionText logger Info "Opening RocksDB in read-write mode, if this wasn't intended, ensure that cuts.pruneChainDatabase is set to none" + withReadOnlyRocksDb <$ logFunctionText logger Info "Opening RocksDB in read-only mode" else return withRocksDb withRocksDb' rocksDbDir modernDefaultOptions $ \rocksDb -> do logFunctionText logger Info $ "opened rocksdb in directory " <> sshow rocksDbDir logFunctionText logger Debug $ "backup config: " <> sshow (_configBackup cwConf) - withChainweb cwConf logger rocksDb pactDbDir dbBackupsDir (_nodeConfigResetChainDbs conf) $ \case - Replayed _ _ -> return () - StartedChainweb cw -> do - let telemetryEnabled = - _enableConfigEnabled $ _logConfigTelemetryBackend $ _nodeConfigLog conf - concurrentlies_ - [ runChainweb cw (\_ -> return ()) + runResourceT $ do + sched <- withScheduler (logFunctionText logger) =<< liftIO backgroundJobsPoolSize + liftIO $ withChainweb cwConf logger sched rocksDb pactDbDir dbBackupsDir $ \case + RewoundToCut _ -> return () + StartedChainweb cw -> do + let telemetryEnabled = + _enableConfigEnabled $ _logConfigTelemetryBackend $ _nodeConfigLog conf + sched' = _chainwebScheduler cw + when telemetryEnabled $ do + runCutMonitor sched' (_chainwebLogger cw) (_cutResCutDb $ _chainwebCutResources cw) + runQueueMonitor sched' (_chainwebLogger cw) (_cutResCutDb $ _chainwebCutResources cw) + runRtsMonitor sched' (_chainwebLogger cw) + -- runBlockUpdateMonitor (_chainwebLogger cw) (_cutResCutDb $ _chainwebCutResources cw) + runDatabaseMonitor sched' (_chainwebLogger cw) rocksDbDir pactDbDir -- we should probably push 'onReady' deeper here but this should be ok - , when telemetryEnabled $ - runCutMonitor (_chainwebLogger cw) (_cutResCutDb $ _chainwebCutResources cw) - , when telemetryEnabled $ - runQueueMonitor (_chainwebLogger cw) (_cutResCutDb $ _chainwebCutResources cw) - , when telemetryEnabled $ - runRtsMonitor (_chainwebLogger cw) - , when telemetryEnabled $ - runBlockUpdateMonitor (_chainwebLogger cw) (_cutResCutDb $ _chainwebCutResources cw) - , when telemetryEnabled $ - runDatabaseMonitor (_chainwebLogger cw) rocksDbDir pactDbDir - ] + runChainweb cw (\_ -> return ()) where cwConf = _nodeConfigChainweb conf + backgroundJobsPoolSize = case _configBackgroundJobsPoolSize cwConf of + Just n -> return $! int n + Nothing -> max 1 . (`div` 2) <$> getNumCapabilities + withNodeLogger - :: LogConfig + :: HasVersion + => LogConfig -> ChainwebConfiguration -> ChainwebVersion -> (L.Logger SomeLogMessage -> IO ()) @@ -371,8 +349,10 @@ withNodeLogger logCfg chainwebCfg v f = runManaged $ do -- we don't log tx failures in replay let !txFailureHandler = - if _configOnlySyncPact chainwebCfg || _configReadOnlyReplay chainwebCfg - then [dropLogHandler (Proxy :: Proxy Pact4TxFailureLog), dropLogHandler (Proxy :: Proxy Pact5TxFailureLog)] + if isJust (_cutInitialCutFile (_configCuts chainwebCfg)) + || isJust (_cutInitialBlockHeightLimit (_configCuts chainwebCfg)) + || _configReadOnlyReplay chainwebCfg + then [dropLogHandler (Proxy :: Proxy PactTxFailureLog)] else [] -- Telemetry Backends @@ -391,14 +371,12 @@ withNodeLogger logCfg chainwebCfg v f = runManaged $ do $ mkTelemetryLogger @NewMinedBlock mgr teleLogConfig orphanedBlockBackend <- managed $ mkTelemetryLogger @OrphanedBlock mgr teleLogConfig - miningStatsBackend <- managed - $ mkTelemetryLogger @MiningStats mgr teleLogConfig +-- miningStatsBackend <- managed +-- $ mkTelemetryLogger @MiningStats mgr teleLogConfig requestLogBackend <- managed $ mkTelemetryLogger @RequestResponseLog mgr teleLogConfig queueStatsBackend <- managed $ mkTelemetryLogger @QueueStats mgr teleLogConfig - reintroBackend <- managed - $ mkTelemetryLogger @ReintroducedTxsLog mgr teleLogConfig traceBackend <- managed $ mkTelemetryLogger @Trace mgr teleLogConfig mempoolStatsBackend <- managed @@ -409,12 +387,12 @@ withNodeLogger logCfg chainwebCfg v f = runManaged $ do $ mkTelemetryLogger @DbCacheStats mgr teleLogConfig dbStatsBackend <- managed $ mkTelemetryLogger @DbStats mgr teleLogConfig - pactQueueStatsBackend <- managed - $ mkTelemetryLogger @PactQueueStats mgr teleLogConfig p2pNodeStatsBackend <- managed $ mkTelemetryLogger @P2pNodeStats mgr teleLogConfig topLevelStatusBackend <- managed $ mkTelemetryLogger @ChainwebStatus mgr teleLogConfig + pruneStatsBackend <- managed + $ mkTelemetryLogger @PruneStats mgr teleLogConfig logger <- managed $ L.withLogger (_logConfigLogger logCfg) $ logHandles @@ -429,18 +407,17 @@ withNodeLogger logCfg chainwebCfg v f = runManaged $ do , logHandler endpointBackend , logHandler newBlockBackend , logHandler orphanedBlockBackend - , logHandler miningStatsBackend + -- , logHandler miningStatsBackend , logHandler requestLogBackend , logHandler queueStatsBackend - , logHandler reintroBackend , logHandler traceBackend , logHandler mempoolStatsBackend , logHandler blockUpdateBackend , logHandler dbCacheBackend , logHandler dbStatsBackend - , logHandler pactQueueStatsBackend , logHandler p2pNodeStatsBackend , logHandler topLevelStatusBackend + , logHandler pruneStatsBackend ] ]) baseBackend @@ -492,18 +469,17 @@ main = do installFatalSignalHandlers [ sigHUP, sigTERM, sigXCPU, sigXFSZ ] checkRLimits runWithPkgInfoConfiguration mainInfo pkgInfo $ \conf -> do - let v = _configChainwebVersion $ _nodeConfigChainweb conf - registerVersion v - hSetBuffering stderr LineBuffering - withNodeLogger (_nodeConfigLog conf) (_nodeConfigChainweb conf) v $ \logger -> do - logFunctionJson logger Info ProcessStarted - handles - [ Handler $ \(e :: SomeAsyncException) -> - logFunctionJson logger Info (ProcessDied $ show e) >> throwIO e - , Handler $ \(e :: SomeException) -> - logFunctionJson logger Error (ProcessDied $ show e) >> throwIO e - ] $ do - void $ race (node conf logger) (gcRunner (logFunctionText logger)) + withVersion (_configChainwebVersion $ _nodeConfigChainweb conf) $ do + hSetBuffering stderr LineBuffering + withNodeLogger (_nodeConfigLog conf) (_nodeConfigChainweb conf) implicitVersion $ \logger -> do + logFunctionJson logger Info ProcessStarted + handles + [ Handler $ \(e :: SomeAsyncException) -> + logFunctionJson logger Info (ProcessDied $ show e) >> throwIO e + , Handler $ \(e :: SomeException) -> + logFunctionJson logger Error (ProcessDied $ show e) >> throwIO e + ] $ do + void $ race (node conf logger) (gcRunner (logFunctionText logger)) where gcRunner lf = runForever lf "GarbageCollect" $ do performMajorGC diff --git a/pact/coin-contract/v1/load-fungible-asset.yaml b/pact/coin-contract/v1/load-fungible-asset.yaml index cd2f25c9bf..c1327d7e1f 100644 --- a/pact/coin-contract/v1/load-fungible-asset.yaml +++ b/pact/coin-contract/v1/load-fungible-asset.yaml @@ -1,3 +1,4 @@ +type: exec codeFile: fungible-v1.pact nonce: genesis-01 -keyPairs: [] \ No newline at end of file +keyPairs: [] diff --git a/src/Chainweb/Backup.hs b/src/Chainweb/Backup.hs index a3daf520a7..84c24ec9da 100644 --- a/src/Chainweb/Backup.hs +++ b/src/Chainweb/Backup.hs @@ -1,6 +1,7 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ImportQualifiedPost #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -17,42 +18,41 @@ module Chainweb.Backup ) where import Control.Lens - +import Chainweb.ChainId +import Chainweb.Logger +import Chainweb.Pact.Backend.Utils(chainDbFileName, withSqliteDb) +import Chainweb.Storage.Table.RocksDB +import Chainweb.Utils +import Chainweb.Version (HasVersion) import Control.Concurrent.Async import Control.Monad import Control.Monad.Catch +import Control.Monad.IO.Class +import Control.Monad.Trans.Resource import Data.HashSet(HashSet) import Data.String -import qualified Data.Text as T -import qualified Data.Text.IO as T -import qualified Data.Text.Lazy as TL -import qualified Data.Text.Lazy.Encoding as TL +import Data.Text qualified as T +import Data.Text.IO qualified as T +import Data.Text.Lazy qualified as TL +import Data.Text.Lazy.Encoding qualified as TL +import Pact.Types.SQLite +import Servant import System.Directory import System.FilePath import System.LogLevel -import Pact.Types.SQLite -import Servant - -import Chainweb.ChainId -import Chainweb.Logger -import Chainweb.Pact.Backend.Utils(chainDbFileName, withSqliteDb) -import Chainweb.Utils - -import Chainweb.Storage.Table.RocksDB - data BackupOptions = BackupOptions { _backupIdentifier :: !FilePath , _backupPact :: !Bool } data BackupEnv logger = BackupEnv - { _backupRocksDb :: !RocksDb - , _backupDir :: !FilePath - , _backupPactDbDir :: !FilePath - , _backupChainIds :: !(HashSet ChainId) - , _backupLogger :: !logger - } + { _backupRocksDb :: !RocksDb + , _backupDir :: !FilePath + , _backupPactDbDir :: !FilePath + , _backupChainIds :: !(HashSet ChainId) + , _backupLogger :: !logger + } data BackupStatus = BackupDone | BackupInProgress | BackupFailed @@ -74,7 +74,7 @@ instance MimeRender PlainText BackupStatus where instance MimeUnrender PlainText BackupStatus where mimeUnrender = const (over _Left show . fromText . TL.toStrict . TL.decodeUtf8) -makeBackup :: Logger logger => BackupEnv logger -> BackupOptions -> IO () +makeBackup :: (Logger logger, HasVersion) => BackupEnv logger -> BackupOptions -> IO () makeBackup env options = do logCr Info ("making backup to " <> T.pack thisBackup) createDirectoryIfMissing True (thisBackup "0" "sqlite") @@ -97,13 +97,13 @@ makeBackup env options = do logCr Info "rocksdb checkpoint made" when (_backupPact options) $ do logCr Info $ "backing up pact databases" <> T.pack thisBackup - forConcurrently_ (_backupChainIds env) $ \cid -> do - withSqliteDb cid (_backupLogger env) (_backupPactDbDir env) False $ \db -> - void $ qry db - ("VACUUM main INTO ?") - [SText $ fromString (thisBackup "0" "sqlite" chainDbFileName cid)] - [] - logCr Info $ "pact databases backed up" + forConcurrently_ (_backupChainIds env) $ \cid -> runResourceT $ do + db <- withSqliteDb cid (_backupLogger env) (_backupPactDbDir env) False + liftIO $ void $ qry db + "VACUUM main INTO ?" + [SText $ fromString (thisBackup "0" "sqlite" chainDbFileName cid)] + [] + logCr Info "pact databases backed up" checkBackup :: Logger logger => BackupEnv logger -> FilePath -> IO (Maybe BackupStatus) checkBackup env name = do @@ -112,6 +112,6 @@ checkBackup env name = do exists <- doesFileExist (thisBackup "status") if exists then - fmap Just . fromText =<< T.readFile (thisBackup "status") + fmap Just . fromTextM =<< T.readFile (thisBackup "status") else return Nothing diff --git a/src/Chainweb/BlockHash.hs b/src/Chainweb/BlockHash.hs index 7c1f6f340b..26cee5bbad 100644 --- a/src/Chainweb/BlockHash.hs +++ b/src/Chainweb/BlockHash.hs @@ -1,16 +1,20 @@ {-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE BangPatterns #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE DerivingVia #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE ImportQualifiedPost #-} {-# LANGUAGE InstanceSigs #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PackageImports #-} +{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-} @@ -18,7 +22,6 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE PatternSynonyms #-} -- | -- Module: Chainweb.BlockHash @@ -61,24 +64,35 @@ module Chainweb.BlockHash , encodeRankedBlockHash , decodeRankedBlockHash +-- * AdjacentsHash +, AdjacentsHash(..) +, adjacentsHash +, adjacentsHashBytes +, encodeAdjacentsHash +, decodeAdjacentsHash +, AdjacentsHashAlgorithm +, AdjacentsHashSize + -- * Exceptions ) where import Control.DeepSeq -import Control.Lens +import Control.Lens hiding ((.=)) import Control.Monad import Control.Monad.Catch (MonadThrow, throwM) import Data.Aeson - (FromJSON(..), FromJSONKey(..), ToJSON(..), ToJSONKey(..), withText) + (FromJSON(..), FromJSONKey(..), ToJSON(..), ToJSONKey(..), withText, object, KeyValue, withObject, (.=), pairs, (.:)) import Data.Aeson.Types (FromJSONKeyFunction(..), toJSONKeyText) import Data.Bifoldable +import Data.ByteString.Short qualified as SB import Data.Foldable +import Data.Hash.SHA2 +import Data.HashMap.Strict qualified as HM import Data.Hashable (Hashable(..)) -import qualified Data.HashMap.Strict as HM -import qualified Data.List as L -import qualified Data.Text as T -import qualified Data.Vector as V +import Data.List qualified as L +import Data.Text qualified as T +import Data.Vector qualified as V import GHC.Generics hiding (to) @@ -92,9 +106,11 @@ import Chainweb.Crypto.MerkleLog import Chainweb.Graph import Chainweb.MerkleLogHash import Chainweb.MerkleUniverse +import Chainweb.Parent import Chainweb.Ranked import Chainweb.Utils import Chainweb.Utils.Serialization +import Chainweb.Core.CryptoHash -- -------------------------------------------------------------------------- -- -- BlockHash @@ -114,22 +130,23 @@ type BlockHash = BlockHash_ ChainwebMerkleHashAlgorithm newtype BlockHash_ a = BlockHash (MerkleLogHash a) deriving stock (Eq, Ord, Generic) deriving anyclass (NFData) + deriving (IsMerkleLogEntry a ChainwebHashTag) via MerkleRootLogEntry a 'BlockHashTag -instance Show (BlockHash_ a) where +instance MerkleHashAlgorithm a => Show (BlockHash_ a) where show = T.unpack . encodeToText instance Hashable (BlockHash_ a) where hashWithSalt s (BlockHash bytes) = hashWithSalt s bytes {-# INLINE hashWithSalt #-} -instance MerkleHashAlgorithm a => IsMerkleLogEntry a ChainwebHashTag (BlockHash_ a) where - type Tag (BlockHash_ a) = 'BlockHashTag +instance MerkleHashAlgorithm a => IsMerkleLogEntry a ChainwebHashTag (Parent (BlockHash_ a)) where + type Tag (Parent (BlockHash_ a)) = 'BlockHashTag toMerkleNode = encodeMerkleTreeNode fromMerkleNode = decodeMerkleTreeNode {-# INLINE toMerkleNode #-} {-# INLINE fromMerkleNode #-} -encodeBlockHash :: BlockHash_ a -> Put +encodeBlockHash :: MerkleHashAlgorithm a => BlockHash_ a -> Put encodeBlockHash (BlockHash bytes) = encodeMerkleLogHash bytes {-# INLINE encodeBlockHash #-} @@ -137,7 +154,7 @@ decodeBlockHash :: MerkleHashAlgorithm a => Get (BlockHash_ a) decodeBlockHash = BlockHash <$!> decodeMerkleLogHash {-# INLINE decodeBlockHash #-} -instance ToJSON (BlockHash_ a) where +instance MerkleHashAlgorithm a => ToJSON (BlockHash_ a) where toJSON = toJSON . encodeB64UrlNoPaddingText . runPutS . encodeBlockHash toEncoding = b64UrlNoPaddingTextEncoding . runPutS . encodeBlockHash {-# INLINE toJSON #-} @@ -148,7 +165,7 @@ instance MerkleHashAlgorithm a => FromJSON (BlockHash_ a) where . (runGetS decodeBlockHash <=< decodeB64UrlNoPaddingText) {-# INLINE parseJSON #-} -instance ToJSONKey (BlockHash_ a) where +instance MerkleHashAlgorithm a => ToJSONKey (BlockHash_ a) where toJSONKey = toJSONKeyText $ encodeB64UrlNoPaddingText . runPutS . encodeBlockHash {-# INLINE toJSONKey #-} @@ -162,11 +179,11 @@ nullBlockHash :: MerkleHashAlgorithm a => BlockHash_ a nullBlockHash = BlockHash nullHashBytes {-# INLINE nullBlockHash #-} -blockHashToText :: BlockHash_ a -> T.Text +blockHashToText :: MerkleHashAlgorithm a => BlockHash_ a -> T.Text blockHashToText = encodeB64UrlNoPaddingText . runPutS . encodeBlockHash {-# INLINE blockHashToText #-} -blockHashToTextShort :: BlockHash_ a -> T.Text +blockHashToTextShort :: MerkleHashAlgorithm a => BlockHash_ a -> T.Text blockHashToTextShort = T.take 6 . blockHashToText blockHashFromText @@ -189,7 +206,7 @@ instance MerkleHashAlgorithm a => HasTextRepresentation (BlockHash_ a) where -- TODO(greg): BlockHashRecord should be a sorted vector newtype BlockHashRecord = BlockHashRecord - { _getBlockHashRecord :: HM.HashMap ChainId BlockHash } + { _getBlockHashRecord :: HM.HashMap ChainId (Parent BlockHash) } deriving stock (Show, Eq, Generic) deriving anyclass (Hashable, NFData) deriving newtype (ToJSON, FromJSON) @@ -197,24 +214,24 @@ newtype BlockHashRecord = BlockHashRecord makeLenses ''BlockHashRecord type instance Index BlockHashRecord = ChainId -type instance IxValue BlockHashRecord = BlockHash +type instance IxValue BlockHashRecord = Parent BlockHash instance Ixed BlockHashRecord where ix i = getBlockHashRecord . ix i instance IxedGet BlockHashRecord -instance Each BlockHashRecord BlockHashRecord BlockHash BlockHash where +instance Each BlockHashRecord BlockHashRecord (Parent BlockHash) (Parent BlockHash) where each f = fmap BlockHashRecord . each f . _getBlockHashRecord encodeBlockHashRecord :: BlockHashRecord -> Put encodeBlockHashRecord (BlockHashRecord r) = do putWord16le (int $ length r) - traverse_ (bimapM_ encodeChainId encodeBlockHash) $ L.sort $ HM.toList r + traverse_ (bimapM_ encodeChainId (encodeBlockHash . unwrapParent)) $ L.sort $ HM.toList r decodeBlockHashWithChainId - :: Get (ChainId, BlockHash) -decodeBlockHashWithChainId = (,) <$!> decodeChainId <*> decodeBlockHash + :: Get (ChainId, Parent BlockHash) +decodeBlockHashWithChainId = (,) <$!> decodeChainId <*> (Parent <$> decodeBlockHash) decodeBlockHashRecord :: Get BlockHashRecord decodeBlockHashRecord = do @@ -225,10 +242,10 @@ decodeBlockHashRecord = do decodeBlockHashWithChainIdChecked :: HasChainId p => Expected p - -> Get (ChainId, BlockHash) + -> Get (ChainId, Parent BlockHash) decodeBlockHashWithChainIdChecked p = (,) <$!> decodeChainIdChecked p - <*> decodeBlockHash + <*> (Parent <$> decodeBlockHash) -- to use this wrap the runGet into some MonadThrow. -- @@ -242,7 +259,7 @@ decodeBlockHashRecordChecked ps = do hashes <- mapM decodeBlockHashWithChainIdChecked (Expected <$!> getExpected ps) return $! BlockHashRecord $! HM.fromList hashes -blockHashRecordToVector :: BlockHashRecord -> V.Vector BlockHash +blockHashRecordToVector :: BlockHashRecord -> V.Vector (Parent BlockHash) blockHashRecordToVector = V.fromList . fmap snd . L.sort . HM.toList . _getBlockHashRecord blockHashRecordChainIdx :: BlockHashRecord -> ChainId -> Maybe Int @@ -257,13 +274,47 @@ blockHashRecordFromVector => HasChainId c => g -> c - -> V.Vector BlockHash + -> V.Vector (Parent BlockHash) -> BlockHashRecord blockHashRecordFromVector g cid = BlockHashRecord . HM.fromList . zip (L.sort $ toList $ adjacentChainIds (_chainGraph g) cid) . toList +-- ---------------------------------------------------------------------------- +-- | BlockHashRecord Hash for MiningWork + +type AdjacentsHashAlgorithm = Sha2_512_256 +type AdjacentsHashSize = DigestSize AdjacentsHashAlgorithm + +-- | The MiningWork includes an (aggregate) hash of the adjacent block hashes +-- that is calculate from the BlockHashRecord. +-- +newtype AdjacentsHash = AdjacentsHash (CryptoHash Sha2_512_256) + deriving stock (Show, Generic) + deriving anyclass (NFData) + deriving newtype (Eq, Ord, Hashable, ToJSON, FromJSON, HasTextRepresentation) + +encodeAdjacentsHash :: AdjacentsHash -> Put +encodeAdjacentsHash (AdjacentsHash w) = encodeCryptoHash w +{-# INLINE encodeAdjacentsHash #-} + +adjacentsHashBytes :: AdjacentsHash -> SB.ShortByteString +adjacentsHashBytes (AdjacentsHash bytes) = cryptoHashBytes bytes +{-# INLINE adjacentsHashBytes #-} + +decodeAdjacentsHash :: Get AdjacentsHash +decodeAdjacentsHash = AdjacentsHash <$> decodeCryptoHash +{-# INLINE decodeAdjacentsHash #-} + +-- | Compute the AdjacentsHash from a BlockHashRecord. +-- +adjacentsHash :: BlockHashRecord -> AdjacentsHash +adjacentsHash = AdjacentsHash + . hashByteString_ @(CryptoHash AdjacentsHashAlgorithm) + . foldMap (runPutS . encodeBlockHash . view _Parent) + . blockHashRecordToVector + -- -------------------------------------------------------------------------- -- -- Ranked Block Hash @@ -280,3 +331,25 @@ encodeRankedBlockHash = encodeRanked encodeBlockHash decodeRankedBlockHash :: Get RankedBlockHash decodeRankedBlockHash = decodeRanked decodeBlockHash +blockHashWithHeightProperties :: KeyValue e kv => RankedBlockHash -> [kv] +blockHashWithHeightProperties o = + [ "height" .= _rankedBlockHashHeight o + , "hash" .= _rankedBlockHashHash o + ] +{-# INLINE blockHashWithHeightProperties #-} + +instance ToJSON RankedBlockHash where + toJSON = object . blockHashWithHeightProperties + toEncoding = pairs . mconcat . blockHashWithHeightProperties + {-# INLINE toJSON #-} + {-# INLINE toEncoding #-} + +instance FromJSON RankedBlockHash where + parseJSON = withObject "HashWithHeight" $ \o -> RankedBlockHash + <$> o .: "height" + <*> o .: "hash" + {-# INLINE parseJSON #-} + +instance ToJSONKey RankedBlockHash where + toJSONKey = toJSONKeyText toText + {-# INLINE toJSONKey #-} diff --git a/src/Chainweb/BlockHeader.hs b/src/Chainweb/BlockHeader.hs index 281824daab..60a7744f5e 100644 --- a/src/Chainweb/BlockHeader.hs +++ b/src/Chainweb/BlockHeader.hs @@ -10,16 +10,8 @@ -- 'Setter', again only in tests, use 'Chainweb.BlockHeader.Internal' instead. module Chainweb.BlockHeader ( --- * Newtype wrappers for function parameters - I.ParentHeader(..) -, I.parentHeader -, I.parentHeaderHash -, I._rankedParentHash -, I.rankedParentHash -, I.ParentCreationTime(..) - -- * Block Payload Hash -, I.BlockPayloadHash + I.BlockPayloadHash , I.BlockPayloadHash_(..) , I.encodeBlockPayloadHash , I.decodeBlockPayloadHash @@ -69,6 +61,7 @@ module Chainweb.BlockHeader , I._rankedBlockPayloadHash , I._blockAdjacentChainIds , I.blockAdjacentChainIds +, I.encodeAsMiningWork , I.encodeBlockHeader , I.encodeBlockHeaderWithoutHash , I.decodeBlockHeader @@ -98,7 +91,11 @@ module Chainweb.BlockHeader -- * Genesis BlockHeader , I.isGenesisBlockHeader +, I.isGenesisBlockHeader' +, I.childBlockHeight +, I.parentBlockHeight , I.genesisParentBlockHash +, I.genesisRankedParentBlockHash , I.genesisBlockHeader , I.genesisBlockHeaders , I.genesisBlockHeadersAtHeight @@ -112,18 +109,20 @@ module Chainweb.BlockHeader -- * CAS Constraint , I.BlockHeaderCas +, I.ReadableBlockHeaderCas ) where +import Chainweb.ChainId (ChainId) import Chainweb.ForkState (ForkState, ForkVotes, ForkNumber) import Chainweb.BlockCreationTime (BlockCreationTime) import Chainweb.BlockHash (BlockHash, BlockHashRecord) import Chainweb.BlockHeader.Internal qualified as I import Chainweb.BlockHeight (BlockHeight) import Chainweb.BlockWeight (BlockWeight) -import Chainweb.ChainId (ChainId) +import Chainweb.Parent import Chainweb.Difficulty (HashTarget) -import Chainweb.Payload (BlockPayloadHash) +import Chainweb.BlockPayloadHash import Chainweb.Version (ChainwebVersionCode) import Control.Lens (Getter) @@ -133,7 +132,7 @@ blockFlags = I.blockFlags blockCreationTime :: Getter I.BlockHeader BlockCreationTime blockCreationTime = I.blockCreationTime -blockParent :: Getter I.BlockHeader BlockHash +blockParent :: Getter I.BlockHeader (Parent BlockHash) blockParent = I.blockParent blockAdjacentHashes :: Getter I.BlockHeader BlockHashRecord diff --git a/src/Chainweb/BlockHeader/Genesis/Development0Payload.hs b/src/Chainweb/BlockHeader/Genesis/Development0Payload.hs index 509d4d187e..3de441c4f4 100644 --- a/src/Chainweb/BlockHeader/Genesis/Development0Payload.hs +++ b/src/Chainweb/BlockHeader/Genesis/Development0Payload.hs @@ -8,7 +8,7 @@ import qualified Data.Text as T import qualified Data.Vector as V import GHC.Stack -import Chainweb.Payload +import Chainweb.Pact.Payload import Chainweb.Utils (unsafeFromText, toText) payloadBlock :: HasCallStack => PayloadWithOutputs @@ -21,7 +21,7 @@ payloadBlock where actualHash, expectedHash :: BlockPayloadHash actualHash = _payloadWithOutputsPayloadHash payload - expectedHash = unsafeFromText "GB8YsdVgd50IaJ_shYGN3pnzOohPi-gE3YaP2pvhw0w" + expectedHash = unsafeFromText "1I4CRQ2BGFZEFr7_X_U1hMPPZI4YMbfxEr6cyrRYlsA" payload = newPayloadWithOutputs minerData coinbase txs minerData = unsafeFromText "eyJhY2NvdW50IjoiTm9NaW5lciIsInByZWRpY2F0ZSI6IjwiLCJwdWJsaWMta2V5cyI6W119" @@ -35,5 +35,5 @@ payloadBlock , (unsafeFromText "eyJoYXNoIjoiQ1pteWxXZmllUk1CTXU1dzJFT21wRndLLXQ3YmNPVHM0bUsyYVQzM3VSNCIsInNpZ3MiOltdLCJjbWQiOiJ7XCJuZXR3b3JrSWRcIjpudWxsLFwicGF5bG9hZFwiOntcImV4ZWNcIjp7XCJkYXRhXCI6e1wibnMtYWRtaW4ta2V5c2V0XCI6W1wiMzY4ODIwZjgwYzMyNGJiYzdjMmIwNjEwNjg4YTdkYTQzZTM5ZjkxZDExODczMjY3MWNkOWM3NTAwZmY0M2NjYVwiXSxcIm5zLW9wZXJhdGUta2V5c2V0XCI6W1wiMzY4ODIwZjgwYzMyNGJiYzdjMmIwNjEwNjg4YTdkYTQzZTM5ZjkxZDExODczMjY3MWNkOWM3NTAwZmY0M2NjYVwiXSxcIm5zLWdlbmVzaXMta2V5c2V0XCI6e1wicHJlZFwiOlwiPVwiLFwia2V5c1wiOltdfX0sXCJjb2RlXCI6XCIoZGVmaW5lLWtleXNldCAnbnMtYWRtaW4ta2V5c2V0IChyZWFkLWtleXNldCAnbnMtYWRtaW4ta2V5c2V0KSlcXG4oZGVmaW5lLWtleXNldCAnbnMtb3BlcmF0ZS1rZXlzZXQgKHJlYWQta2V5c2V0ICducy1nZW5lc2lzLWtleXNldCkpXFxuXFxuKG1vZHVsZSBucyBHT1ZFUk5BTkNFXFxuICBcXFwiQWRtaW5pc3RlcnMgZGVmaW5pdGlvbiBvZiBuZXcgbmFtZXNwYWNlcyBpbiBDaGFpbndlYi5cXFwiXFxuXFxuICAoZGVmc2NoZW1hIHJlZy1lbnRyeVxcbiAgICBhZG1pbi1ndWFyZDpndWFyZFxcbiAgICBhY3RpdmU6Ym9vbClcXG5cXG4gIChkZWZ0YWJsZSByZWdpc3RyeTp7cmVnLWVudHJ5fSlcXG5cXG4gIChkZWZjYXAgR09WRVJOQU5DRSAoKVxcbiAgICAoZW5mb3JjZS1rZXlzZXQgJ25zLWFkbWluLWtleXNldCkpXFxuXFxuICAoZGVmY2FwIE9QRVJBVEUgKClcXG4gICAgKGVuZm9yY2Uta2V5c2V0ICducy1vcGVyYXRlLWtleXNldCkpXFxuXFxuICAoZGVmY29uc3QgR1VBUkRfU1VDQ0VTUyAoY3JlYXRlLXVzZXItZ3VhcmQgKHN1Y2Nlc3MpKSlcXG4gIChkZWZjb25zdCBHVUFSRF9GQUlMVVJFIChjcmVhdGUtdXNlci1ndWFyZCAoZmFpbHVyZSkpKVxcblxcbiAgKGRlZnVuIHN1Y2Nlc3MgKClcXG4gICAgdHJ1ZSlcXG4gIChkZWZ1biBmYWlsdXJlICgpXFxuICAgIChlbmZvcmNlIGZhbHNlIFxcXCJEaXNhYmxlZFxcXCIpKVxcblxcbiAgKGRlZnVuIHZhbGlkYXRlLW5hbWUgKG5hbWUpXFxuICAgIChlbmZvcmNlICghPSBcXFwiXFxcIiBuYW1lKSBcXFwiRW1wdHkgbmFtZSBub3QgYWxsb3dlZFxcXCIpXFxuICAgIChlbmZvcmNlICg8IChsZW5ndGggbmFtZSkgNjQpIFxcXCJOYW1lIG11c3QgYmUgbGVzcyB0aGFuIDY0IGNoYXJhY3RlcnMgbG9uZ1xcXCIpXFxuICAgIChlbmZvcmNlIChpcy1jaGFyc2V0IENIQVJTRVRfTEFUSU4xIG5hbWUpXFxuICAgICAgICAgICAgIFxcXCJOYW1lIG11c3QgYmUgaW4gbGF0aW4xIGNoYXJzZXRcXFwiKSlcXG5cXG4gIChkZWZ1biBjcmVhdGUtcHJpbmNpcGFsLW5hbWVzcGFjZTpzdHJpbmdcXG4gICAgICAoIGc6Z3VhcmRcXG4gICAgICAgIClcXG4gICAgXFxcIiBGb3JtYXQgcHJpbmNpcGFsIG5hbWVzcGFjZSBhcyBQYWN0IGhhc2ggKEJMQUtFMmIyNTYpIG9mIHByaW5jaXBhbCBcXFxcXFxuICAgIFxcXFwgaW4gaGV4IHRydW5jYXRlZCB0byAxNjAgYml0cyAoNDAgY2hhcmFjdGVycyksIHByZXBlbmRlZCB3aXRoICduXycuXFxcXFxcbiAgICBcXFxcIE9ubHkgdzogYW5kIGs6IGFjY291bnQgcHJvdG9jb2xzIGFyZSBzdXBwb3J0ZWQuIFxcXCJcXG5cXG4gICAgKGxldFxcbiAgICAgICgodHkgKHR5cGVvZi1wcmluY2lwYWwgKGNyZWF0ZS1wcmluY2lwYWwgZykpKSlcXG5cXG4gICAgICA7OyBvbmx5IHc6IGFuZCBrOiBjdXJyZW50bHkgc3VwcG9ydGVkXFxuICAgICAgKGlmIChvciAoPSB0eSBcXFwiazpcXFwiKSAoPSB0eSBcXFwidzpcXFwiKSlcXG4gICAgICAgICgrIFxcXCJuX1xcXCIgKHRha2UgNDAgKGludC10by1zdHIgMTYgKHN0ci10by1pbnQgNjQgKGhhc2ggZykpKSkpXFxuICAgICAgICAoZW5mb3JjZSBmYWxzZVxcbiAgICAgICAgICAoZm9ybWF0IFxcXCJVbnN1cHBvcnRlZCBndWFyZCBwcm90b2NvbDoge31cXFwiIFt0eV0pKVxcbiAgICAgICAgKSlcXG4gIClcXG5cXG4gIChkZWZ1biB2YWxpZGF0ZTpib29sXFxuICAgICAgKCBucy1uYW1lOnN0cmluZ1xcbiAgICAgICAgbnMtYWRtaW46Z3VhcmRcXG4gICAgICAgIClcXG4gICAgXFxcIiBNYW5hZ2VzIG5hbWVzcGFjZSBpbnN0YWxsIGZvciBDaGFpbndlYi4gXFxcXFxcbiAgICBcXFxcIEFsbG93cyBwcmluY2lwYWwgbmFtZXNwYWNlcy4gXFxcXFxcbiAgICBcXFxcIE5vbi1wcmluY2lwYWwgbmFtZXNwYWNlcyByZXF1aXJlIGFjdGl2ZSByb3cgaW4gcmVnaXN0cnkgXFxcXFxcbiAgICBcXFxcIGZvciBOUy1OQU1FIHdpdGggZ3VhcmQgbWF0Y2hpbmcgTlMtQURNSU4uXFxcIlxcblxcbiAgICAoaWYgKD0gKGNyZWF0ZS1wcmluY2lwYWwtbmFtZXNwYWNlIG5zLWFkbWluKSBucy1uYW1lKVxcblxcbiAgICAgIHRydWUgOzsgYWxsb3cgcHJpbmNpcGFsIG5hbWVzcGFjZXNcXG5cXG4gICAgICAod2l0aC1kZWZhdWx0LXJlYWQgcmVnaXN0cnkgbnMtbmFtZSAgICAgICA7OyBvdGhlcndpc2UgZW5mb3JjZSByZWdpc3RyeVxcbiAgICAgICAgeyAnYWRtaW4tZ3VhcmQgOiBucy1hZG1pblxcbiAgICAgICAgLCAnYWN0aXZlIDogZmFsc2UgfVxcbiAgICAgICAgeyAnYWRtaW4tZ3VhcmQgOj0gYWdcXG4gICAgICAgICwgJ2FjdGl2ZSA6PSBpcy1hY3RpdmUgfVxcblxcbiAgICAgICAgKGVuZm9yY2UgaXMtYWN0aXZlIFxcXCJJbmFjdGl2ZSBvciB1bnJlZ2lzdGVyZWQgbmFtZXNwYWNlXFxcIilcXG4gICAgICAgIChlbmZvcmNlICg9IG5zLWFkbWluIGFnKSBcXFwiQWRtaW4gZ3VhcmQgbXVzdCBtYXRjaCBndWFyZCBpbiByZWdpc3RyeVxcXCIpXFxuXFxuICAgICAgICB0cnVlKVxcbiAgICAgICkpXFxuXFxuICAoZGVmdW4gd3JpdGUtcmVnaXN0cnk6c3RyaW5nXFxuICAgICAgKCBucy1uYW1lOnN0cmluZ1xcbiAgICAgICAgZ3VhcmQ6Z3VhcmRcXG4gICAgICAgIGFjdGl2ZTpib29sXFxuICAgICAgICApXFxuICAgIFxcXCIgV3JpdGUgZW50cnkgd2l0aCBHVUFSRCBhbmQgQUNUSVZFIGludG8gcmVnaXN0cnkgZm9yIE5BTUUuIFxcXFxcXG4gICAgXFxcXCBHdWFyZGVkIGJ5IG9wZXJhdGUga2V5c2V0LiBcXFwiXFxuXFxuICAgICh3aXRoLWNhcGFiaWxpdHkgKE9QRVJBVEUpXFxuXFxuICAgICAgKHZhbGlkYXRlLW5hbWUgbnMtbmFtZSlcXG5cXG4gICAgICAod3JpdGUgcmVnaXN0cnkgbnMtbmFtZVxcbiAgICAgICAgeyAnYWRtaW4tZ3VhcmQ6IGd1YXJkXFxuICAgICAgICAsICdhY3RpdmU6IGFjdGl2ZSB9KVxcblxcbiAgICAgIFxcXCJSZWdpc3RlciBlbnRyeSB3cml0dGVuXFxcIikpXFxuXFxuICAoZGVmdW4gcXVlcnk6b2JqZWN0e3JlZy1lbnRyeX1cXG4gICAgICAoIG5zLW5hbWU6c3RyaW5nIClcXG4gICAgKHJlYWQgcmVnaXN0cnkgbnMtbmFtZSkpXFxuXFxuKVxcblxcbihjcmVhdGUtdGFibGUgcmVnaXN0cnkpXFxuXFxuKHdyaXRlLXJlZ2lzdHJ5IFxcXCJrYWRlbmFcXFwiXFxuICAoa2V5c2V0LXJlZi1ndWFyZCAnbnMtb3BlcmF0ZS1rZXlzZXQpIHRydWUpXFxuKHdyaXRlLXJlZ2lzdHJ5IFxcXCJ1c2VyXFxcIiBHVUFSRF9GQUlMVVJFIHRydWUpXFxuKHdyaXRlLXJlZ2lzdHJ5IFxcXCJmcmVlXFxcIiBHVUFSRF9GQUlMVVJFIHRydWUpXFxuXFxuKGRlZmluZS1uYW1lc3BhY2UgXFxcImthZGVuYVxcXCJcXG4gIChrZXlzZXQtcmVmLWd1YXJkICducy1vcGVyYXRlLWtleXNldClcXG4gIChrZXlzZXQtcmVmLWd1YXJkICducy1vcGVyYXRlLWtleXNldCkpXFxuXFxuKGRlZmluZS1uYW1lc3BhY2UgXFxcInVzZXJcXFwiIEdVQVJEX1NVQ0NFU1MgR1VBUkRfRkFJTFVSRSlcXG4oZGVmaW5lLW5hbWVzcGFjZSBcXFwiZnJlZVxcXCIgR1VBUkRfU1VDQ0VTUyBHVUFSRF9GQUlMVVJFKVxcbjs7cm90YXRlIHRvIHJlYWwgb3BlcmF0ZSBrZXlzZXRcXG4oZGVmaW5lLWtleXNldCAnbnMtb3BlcmF0ZS1rZXlzZXQgKHJlYWQta2V5c2V0ICducy1vcGVyYXRlLWtleXNldCkpXFxuXCJ9fSxcInNpZ25lcnNcIjpbXSxcIm1ldGFcIjp7XCJjcmVhdGlvblRpbWVcIjowLFwidHRsXCI6MTcyODAwLFwiZ2FzTGltaXRcIjowLFwiY2hhaW5JZFwiOlwiXCIsXCJnYXNQcmljZVwiOjAsXCJzZW5kZXJcIjpcIlwifSxcIm5vbmNlXCI6XCJsb2FkLW5zLWRldm5ldC1zZW5kZXIwMFwifSJ9", unsafeFromText "eyJnYXMiOjAsInJlc3VsdCI6eyJzdGF0dXMiOiJzdWNjZXNzIiwiZGF0YSI6IktleXNldCB3cml0ZSBzdWNjZXNzIn0sInJlcUtleSI6IkNabXlsV2ZpZVJNQk11NXcyRU9tcEZ3Sy10N2JjT1RzNG1LMmFUMzN1UjQiLCJsb2dzIjoidDdzQzg1Y1hlWFdSdG90M1lEb2pSejZibWtncEN6enJQQ0Z6QThzTkg3OCIsIm1ldGFEYXRhIjpudWxsLCJjb250aW51YXRpb24iOm51bGwsInR4SWQiOjV9") , (unsafeFromText "eyJoYXNoIjoiWE5BNmxPSjFXLTdYWXY1WWI0QXFsNzRveFlJN09KcWpPUVQ1b1k0OHEtZyIsInNpZ3MiOltdLCJjbWQiOiJ7XCJuZXR3b3JrSWRcIjpudWxsLFwicGF5bG9hZFwiOntcImV4ZWNcIjp7XCJkYXRhXCI6e1wiYWxsb2NhdGlvbi10ZXN0MDFcIjpbXCI3MDExYzM3OTE0MGZmODk5ZjdlNjEzYWMwYTk3ODRhN2MwYTUxNWQzMGZlMGFiMmIwYzA3ZTVhYTE3NjM1ZTNlXCJdLFwiYWxsb2NhdGlvbjAyXCI6W1wiZTllNGU3MWJkMDYzZGNmN2UwNmJkNWIxYTE2Njg4ODk3ZDE1Y2E4YmQyZTUwOWM0NTNjNjE2MjE5YzE4NmNjNVwiXSxcImFsbG9jYXRpb24wMFwiOltcImQ4MmQwZGNkZTk4MjU1MDVkODZhZmI2ZGNjMTA0MTFkNmI2N2E0MjlhNzllMjFiZGE0YmIxMTliZjI4YWI4NzFcIl0sXCJhbGxvY2F0aW9uLXRlc3QwMlwiOltcIjA2NTQ0ZTIyYmZlZjIzMGQ2ZDIyZjk0ODZhYzZjYjc2YmYyNThlYmZiZjAxMzdlZTU4ZjY1NzQzZTFhNWI4YzRcIl0sXCJhbGxvY2F0aW9uMDFcIjpbXCJiNGM4YTNlYTkxZDMxNDZiMDU2MDk5NDc0MGYwZTNlZWQ5MWM1OWQyZWVjYTFkYzk5ZjBjMjg3Mjg0NWMyOTRkXCJdfSxcImNvZGVcIjpcIihkZWZpbmUta2V5c2V0IFxcXCJhbGxvY2F0aW9uMDBcXFwiIChyZWFkLWtleXNldCBcXFwiYWxsb2NhdGlvbjAwXFxcIikpXFxuKGRlZmluZS1rZXlzZXQgXFxcImFsbG9jYXRpb24wMVxcXCIgKHJlYWQta2V5c2V0IFxcXCJhbGxvY2F0aW9uMDFcXFwiKSlcXG4oZGVmaW5lLWtleXNldCBcXFwiYWxsb2NhdGlvbjAyXFxcIiAocmVhZC1rZXlzZXQgXFxcImFsbG9jYXRpb24wMlxcXCIpKVxcbihkZWZpbmUta2V5c2V0IFxcXCJhbGxvY2F0aW9uLXRlc3QwMVxcXCIgKHJlYWQta2V5c2V0IFxcXCJhbGxvY2F0aW9uLXRlc3QwMVxcXCIpKVxcbihkZWZpbmUta2V5c2V0IFxcXCJhbGxvY2F0aW9uLXRlc3QwMlxcXCIgKHJlYWQta2V5c2V0IFxcXCJhbGxvY2F0aW9uLXRlc3QwMlxcXCIpKVwifX0sXCJzaWduZXJzXCI6W10sXCJtZXRhXCI6e1wiY3JlYXRpb25UaW1lXCI6MCxcInR0bFwiOjE3MjgwMCxcImdhc0xpbWl0XCI6MCxcImNoYWluSWRcIjpcIlwiLFwiZ2FzUHJpY2VcIjowLFwic2VuZGVyXCI6XCJcIn0sXCJub25jZVwiOlwiZGV2bmV0LWtleXNldHNcIn0ifQ", unsafeFromText "eyJnYXMiOjAsInJlc3VsdCI6eyJzdGF0dXMiOiJzdWNjZXNzIiwiZGF0YSI6IktleXNldCB3cml0ZSBzdWNjZXNzIn0sInJlcUtleSI6IlhOQTZsT0oxVy03WFl2NVliNEFxbDc0b3hZSTdPSnFqT1FUNW9ZNDhxLWciLCJsb2dzIjoiYXJRSWpQVGRrcXhoQTNjWl9WaVE3OXM3Uk5XRTlGV2Rha0xWdXl4Nlc0YyIsIm1ldGFEYXRhIjpudWxsLCJjb250aW51YXRpb24iOm51bGwsInR4SWQiOjZ9") , (unsafeFromText "eyJoYXNoIjoiNWtxZ0tzWWtwbjZCcS1KUnhNYnA1VG9jUWhRWGRJVVNiM1NGQm1Ba3VWcyIsInNpZ3MiOltdLCJjbWQiOiJ7XCJuZXR3b3JrSWRcIjpudWxsLFwicGF5bG9hZFwiOntcImV4ZWNcIjp7XCJkYXRhXCI6bnVsbCxcImNvZGVcIjpcIihjb2luLmNyZWF0ZS1hbGxvY2F0aW9uLWFjY291bnQgXFxcImFsbG9jYXRpb24wMFxcXCIgKHRpbWUgXFxcIjE5MDAtMTAtMTVUMTg6MDA6MDBaXFxcIikgXFxcImFsbG9jYXRpb24wMFxcXCIgMTAwMDAwMC4wKVxcbihjb2luLmNyZWF0ZS1hbGxvY2F0aW9uLWFjY291bnQgXFxcImFsbG9jYXRpb24wMVxcXCIgKHRpbWUgXFxcIjIxMDAtMTAtMzFUMTg6MDA6MDBaXFxcIikgXFxcImFsbG9jYXRpb24wMVxcXCIgMTAwMDAwMC4wKVxcbihjb2luLmNyZWF0ZS1hbGxvY2F0aW9uLWFjY291bnQgXFxcImFsbG9jYXRpb24wMlxcXCIgKHRpbWUgXFxcIjE5MDAtMTAtMzFUMTg6MDA6MDBaXFxcIikgXFxcImFsbG9jYXRpb24wMlxcXCIgMTAwMDAwMC4wKVxcbihjb2luLmNyZWF0ZS1hbGxvY2F0aW9uLWFjY291bnQgXFxcImFsbG9jYXRpb24tdGVzdDAxXFxcIiAodGltZSBcXFwiMTkwMC0xMC0zMVQxODowMDowMFpcXFwiKSBcXFwiYWxsb2NhdGlvbi10ZXN0MDFcXFwiIDEwMDAwMDAuMClcXG4oY29pbi5jcmVhdGUtYWxsb2NhdGlvbi1hY2NvdW50IFxcXCJhbGxvY2F0aW9uLXRlc3QwMlxcXCIgKHRpbWUgXFxcIjE5MDAtMTAtMzFUMTg6MDA6MDBaXFxcIikgXFxcImFsbG9jYXRpb24tdGVzdDAyXFxcIiAyMDAwMDAwLjApXCJ9fSxcInNpZ25lcnNcIjpbXSxcIm1ldGFcIjp7XCJjcmVhdGlvblRpbWVcIjowLFwidHRsXCI6MTcyODAwLFwiZ2FzTGltaXRcIjowLFwiY2hhaW5JZFwiOlwiXCIsXCJnYXNQcmljZVwiOjAsXCJzZW5kZXJcIjpcIlwifSxcIm5vbmNlXCI6XCJkZXZuZXQtYWxsb2NhdGlvbnNcIn0ifQ", unsafeFromText "eyJnYXMiOjAsInJlc3VsdCI6eyJzdGF0dXMiOiJzdWNjZXNzIiwiZGF0YSI6IldyaXRlIHN1Y2NlZWRlZCJ9LCJyZXFLZXkiOiI1a3FnS3NZa3BuNkJxLUpSeE1icDVUb2NRaFFYZElVU2IzU0ZCbUFrdVZzIiwibG9ncyI6IkhpX3ZfVEhFT2s2aEJFRU0yWmV2Vzh3eVJsQWpUZzNjVUQydXBlVkx0b1UiLCJtZXRhRGF0YSI6bnVsbCwiY29udGludWF0aW9uIjpudWxsLCJ0eElkIjo3fQ") - , (unsafeFromText "eyJoYXNoIjoiY2tiMmZnNWVJeXRoS3U5YVN3TkhIWllsWVY2V1R1NGlYaUZDamc5WFFLWSIsInNpZ3MiOltdLCJjbWQiOiJ7XCJuZXR3b3JrSWRcIjpudWxsLFwicGF5bG9hZFwiOntcImV4ZWNcIjp7XCJkYXRhXCI6e1wic2VuZGVyMDdcIjpbXCI0YzMxZGM5ZWU3ZjI0MTc3Zjc4YjZmNTE4MDEyYTIwODMyNmUyYWYxZjM3YmIwYTI0MDViNTA1NmQwY2FkNjI4XCJdLFwic2VuZGVyMDFcIjpbXCI2YmUyZjQ4NWE3YWY3NWZlZGI0YjdmMTUzYTkwM2Y3ZTYwMDBjYTRhYTUwMTE3OWM5MWEyNDUwYjc3N2JkMmE3XCJdLFwic2VuZGVyMDZcIjpbXCI1ZmZjMWY3ZmVmN2E0NDczODYyNTc2MmY3NWE0MjI5NDU0OTUxZTAzZjJhZmM2ZjgxMzA5YzBjMWJkZjllZTZmXCJdLFwic2VuZGVyMDBcIjpbXCIzNjg4MjBmODBjMzI0YmJjN2MyYjA2MTA2ODhhN2RhNDNlMzlmOTFkMTE4NzMyNjcxY2Q5Yzc1MDBmZjQzY2NhXCJdLFwiZTdmN1wiOltcImU3Zjc2MzRlOTI1NTQxZjM2OGI4MjdhZDVjNzI0MjE5MDUxMDBmNjIwNTI4NWE3OGMxOWQ3YjRhMzg3MTE4MDVcIl0sXCJzZW5kZXIwNVwiOltcImYwOWQ4ZjYzOTRhZWE0MjVmZTY3ODNkODhjZDgxMzYzZDgwMTdmMTZhZmQzNzExYzU3NWJlMGY1Y2Q1YzliYjlcIl0sXCJzZW5kZXIwNFwiOltcIjJkNzBhYTRmNjk3YzNhM2I4ZGQ2ZDk3NzQ1YWMwNzRlZGNmZDBlYjY1YzM3Nzc0Y2RlMjUxMzU0ODNiZWE3MWVcIl0sXCJtdWx0aS0wMi0wMy0wNC1hbnlcIjp7XCJwcmVkXCI6XCJrZXlzLWFueVwiLFwia2V5c1wiOltcIjNhOWRkNTMyZDczZGFjZTE5NWRiYjY0ZDFkYmE2NTcyZmI3ODNkMGZkZDMyNDY4NWUzMmZiZGEyZjg5Zjk5YTZcIixcIjQzZjJhZGIxZGUxOTIwMDBjYjM3NzdiYWNjN2Y5ODNiNjYxNGZkOWMxNzE1Y2Q0NGNkNDg0YjZkM2EwZDM0YzhcIixcIjJkNzBhYTRmNjk3YzNhM2I4ZGQ2ZDk3NzQ1YWMwNzRlZGNmZDBlYjY1YzM3Nzc0Y2RlMjUxMzU0ODNiZWE3MWVcIl19LFwic2VuZGVyMDlcIjpbXCJjNTlkOTg0MGIwYjY2MDkwODM2NTQ2YjdlYjRhNzM2MDYyNTc1MjdlYzhjMmI0ODIzMDBmZDIyOTI2NGIwN2U2XCJdLFwic2VuZGVyMDNcIjpbXCI0M2YyYWRiMWRlMTkyMDAwY2IzNzc3YmFjYzdmOTgzYjY2MTRmZDljMTcxNWNkNDRjZDQ4NGI2ZDNhMGQzNGM4XCJdLFwibXVsdGktMDAtMDFcIjpbXCIzNjg4MjBmODBjMzI0YmJjN2MyYjA2MTA2ODhhN2RhNDNlMzlmOTFkMTE4NzMyNjcxY2Q5Yzc1MDBmZjQzY2NhXCIsXCI2YmUyZjQ4NWE3YWY3NWZlZGI0YjdmMTUzYTkwM2Y3ZTYwMDBjYTRhYTUwMTE3OWM5MWEyNDUwYjc3N2JkMmE3XCJdLFwic2VuZGVyMDhcIjpbXCI2M2IyZWJhNGVkNzBkNDYxMmQzZTdiYzkwZGIyZmJmNGM3NmY3YjA3NDM2M2U4NmQ3M2YwYmM2MTdmOGU4YjgxXCJdLFwic2VuZGVyMDJcIjpbXCIzYTlkZDUzMmQ3M2RhY2UxOTVkYmI2NGQxZGJhNjU3MmZiNzgzZDBmZGQzMjQ2ODVlMzJmYmRhMmY4OWY5OWE2XCJdfSxcImNvZGVcIjpcIihjb2luLmNvaW5iYXNlIFxcXCJzZW5kZXIwMFxcXCIgKHJlYWQta2V5c2V0IFxcXCJzZW5kZXIwMFxcXCIpIDEwMDAwMDAwMC4wKVxcbihjb2luLmNvaW5iYXNlIFxcXCJzZW5kZXIwMVxcXCIgKHJlYWQta2V5c2V0IFxcXCJzZW5kZXIwMVxcXCIpIDExMDAwMDAwMC4wKVxcbihjb2luLmNvaW5iYXNlIFxcXCJzZW5kZXIwMlxcXCIgKHJlYWQta2V5c2V0IFxcXCJzZW5kZXIwMlxcXCIpIDEyMDAwMDAwMC4wKVxcbihjb2luLmNvaW5iYXNlIFxcXCJzZW5kZXIwM1xcXCIgKHJlYWQta2V5c2V0IFxcXCJzZW5kZXIwM1xcXCIpIDEzMDAwMDAwMC4wKVxcbihjb2luLmNvaW5iYXNlIFxcXCJzZW5kZXIwNFxcXCIgKHJlYWQta2V5c2V0IFxcXCJzZW5kZXIwNFxcXCIpIDE0MDAwMDAwMC4wKVxcbihjb2luLmNvaW5iYXNlIFxcXCJzZW5kZXIwNVxcXCIgKHJlYWQta2V5c2V0IFxcXCJzZW5kZXIwNVxcXCIpIDE1MDAwMDAwMC4wKVxcbihjb2luLmNvaW5iYXNlIFxcXCJzZW5kZXIwNlxcXCIgKHJlYWQta2V5c2V0IFxcXCJzZW5kZXIwNlxcXCIpIDE2MDAwMDAwMC4wKVxcbihjb2luLmNvaW5iYXNlIFxcXCJzZW5kZXIwN1xcXCIgKHJlYWQta2V5c2V0IFxcXCJzZW5kZXIwN1xcXCIpIDE3MDAwMDAwMC4wKVxcbihjb2luLmNvaW5iYXNlIFxcXCJzZW5kZXIwOFxcXCIgKHJlYWQta2V5c2V0IFxcXCJzZW5kZXIwOFxcXCIpIDE4MDAwMDAwMC4wKVxcbihjb2luLmNvaW5iYXNlIFxcXCJzZW5kZXIwOVxcXCIgKHJlYWQta2V5c2V0IFxcXCJzZW5kZXIwOVxcXCIpIDE5MDAwMDAwMC4wKVxcbihjb2luLmNvaW5iYXNlIFxcXCJtdWx0aS0wMC0wMVxcXCIgKHJlYWQta2V5c2V0IFxcXCJtdWx0aS0wMC0wMVxcXCIpIDEwMTAwMDAwMC4wKVxcbihjb2luLmNvaW5iYXNlIFxcXCJtdWx0aS0wMi0wMy0wNC1hbnlcXFwiIChyZWFkLWtleXNldCBcXFwibXVsdGktMDItMDMtMDQtYW55XFxcIikgMTIzNDAwMDAwLjApXFxuXFxuKGNvaW4uY29pbmJhc2UgXFxcImU3Zjc2MzRlOTI1NTQxZjM2OGI4MjdhZDVjNzI0MjE5MDUxMDBmNjIwNTI4NWE3OGMxOWQ3YjRhMzg3MTE4MDVcXFwiIChyZWFkLWtleXNldCBcXFwiZTdmN1xcXCIpIDE1MC4wKVxcblxcbjsgZW5vdWdoIHRvIGNvdmVyIHRoZSBnYXMgY29zdHMgZm9yIGFsbG9jYXRpb24gcmVsZWFzZVxcbihjb2luLmNvaW5iYXNlIFxcXCJhbGxvY2F0aW9uMDBcXFwiIChrZXlzZXQtcmVmLWd1YXJkIFxcXCJhbGxvY2F0aW9uMDBcXFwiKSAxMDAwMDAuMClcXG4oY29pbi5jb2luYmFzZSBcXFwiYWxsb2NhdGlvbjAxXFxcIiAoa2V5c2V0LXJlZi1ndWFyZCBcXFwiYWxsb2NhdGlvbjAxXFxcIikgMTAwMDAwLjApXFxuKGNvaW4uY29pbmJhc2UgXFxcImFsbG9jYXRpb24wMlxcXCIgKGtleXNldC1yZWYtZ3VhcmQgXFxcImFsbG9jYXRpb24wMlxcXCIpIDEwMDAwMC4wKVwifX0sXCJzaWduZXJzXCI6W10sXCJtZXRhXCI6e1wiY3JlYXRpb25UaW1lXCI6MCxcInR0bFwiOjE3MjgwMCxcImdhc0xpbWl0XCI6MCxcImNoYWluSWRcIjpcIlwiLFwiZ2FzUHJpY2VcIjowLFwic2VuZGVyXCI6XCJcIn0sXCJub25jZVwiOlwiZGV2bmV0LWdyYW50czBcIn0ifQ", unsafeFromText "eyJnYXMiOjAsInJlc3VsdCI6eyJzdGF0dXMiOiJzdWNjZXNzIiwiZGF0YSI6IldyaXRlIHN1Y2NlZWRlZCJ9LCJyZXFLZXkiOiJja2IyZmc1ZUl5dGhLdTlhU3dOSEhaWWxZVjZXVHU0aVhpRkNqZzlYUUtZIiwibG9ncyI6ImFCUXM2aDJGVUN1a00tM0pjQmdLZGFvRU1Ta3p2OTJkM0VmT2t5MXNrMmciLCJldmVudHMiOlt7InBhcmFtcyI6WyIiLCJzZW5kZXIwMCIsMTAwMDAwMDAwXSwibmFtZSI6IlRSQU5TRkVSIiwibW9kdWxlIjp7Im5hbWVzcGFjZSI6bnVsbCwibmFtZSI6ImNvaW4ifSwibW9kdWxlSGFzaCI6IjNpSUJRZEpuc3Q0NFoyWmdYb0hQa0FhdXliSjBoODVsX2VuX1NHSE5pYkUifSx7InBhcmFtcyI6WyIiLCJzZW5kZXIwMSIsMTEwMDAwMDAwXSwibmFtZSI6IlRSQU5TRkVSIiwibW9kdWxlIjp7Im5hbWVzcGFjZSI6bnVsbCwibmFtZSI6ImNvaW4ifSwibW9kdWxlSGFzaCI6IjNpSUJRZEpuc3Q0NFoyWmdYb0hQa0FhdXliSjBoODVsX2VuX1NHSE5pYkUifSx7InBhcmFtcyI6WyIiLCJzZW5kZXIwMiIsMTIwMDAwMDAwXSwibmFtZSI6IlRSQU5TRkVSIiwibW9kdWxlIjp7Im5hbWVzcGFjZSI6bnVsbCwibmFtZSI6ImNvaW4ifSwibW9kdWxlSGFzaCI6IjNpSUJRZEpuc3Q0NFoyWmdYb0hQa0FhdXliSjBoODVsX2VuX1NHSE5pYkUifSx7InBhcmFtcyI6WyIiLCJzZW5kZXIwMyIsMTMwMDAwMDAwXSwibmFtZSI6IlRSQU5TRkVSIiwibW9kdWxlIjp7Im5hbWVzcGFjZSI6bnVsbCwibmFtZSI6ImNvaW4ifSwibW9kdWxlSGFzaCI6IjNpSUJRZEpuc3Q0NFoyWmdYb0hQa0FhdXliSjBoODVsX2VuX1NHSE5pYkUifSx7InBhcmFtcyI6WyIiLCJzZW5kZXIwNCIsMTQwMDAwMDAwXSwibmFtZSI6IlRSQU5TRkVSIiwibW9kdWxlIjp7Im5hbWVzcGFjZSI6bnVsbCwibmFtZSI6ImNvaW4ifSwibW9kdWxlSGFzaCI6IjNpSUJRZEpuc3Q0NFoyWmdYb0hQa0FhdXliSjBoODVsX2VuX1NHSE5pYkUifSx7InBhcmFtcyI6WyIiLCJzZW5kZXIwNSIsMTUwMDAwMDAwXSwibmFtZSI6IlRSQU5TRkVSIiwibW9kdWxlIjp7Im5hbWVzcGFjZSI6bnVsbCwibmFtZSI6ImNvaW4ifSwibW9kdWxlSGFzaCI6IjNpSUJRZEpuc3Q0NFoyWmdYb0hQa0FhdXliSjBoODVsX2VuX1NHSE5pYkUifSx7InBhcmFtcyI6WyIiLCJzZW5kZXIwNiIsMTYwMDAwMDAwXSwibmFtZSI6IlRSQU5TRkVSIiwibW9kdWxlIjp7Im5hbWVzcGFjZSI6bnVsbCwibmFtZSI6ImNvaW4ifSwibW9kdWxlSGFzaCI6IjNpSUJRZEpuc3Q0NFoyWmdYb0hQa0FhdXliSjBoODVsX2VuX1NHSE5pYkUifSx7InBhcmFtcyI6WyIiLCJzZW5kZXIwNyIsMTcwMDAwMDAwXSwibmFtZSI6IlRSQU5TRkVSIiwibW9kdWxlIjp7Im5hbWVzcGFjZSI6bnVsbCwibmFtZSI6ImNvaW4ifSwibW9kdWxlSGFzaCI6IjNpSUJRZEpuc3Q0NFoyWmdYb0hQa0FhdXliSjBoODVsX2VuX1NHSE5pYkUifSx7InBhcmFtcyI6WyIiLCJzZW5kZXIwOCIsMTgwMDAwMDAwXSwibmFtZSI6IlRSQU5TRkVSIiwibW9kdWxlIjp7Im5hbWVzcGFjZSI6bnVsbCwibmFtZSI6ImNvaW4ifSwibW9kdWxlSGFzaCI6IjNpSUJRZEpuc3Q0NFoyWmdYb0hQa0FhdXliSjBoODVsX2VuX1NHSE5pYkUifSx7InBhcmFtcyI6WyIiLCJzZW5kZXIwOSIsMTkwMDAwMDAwXSwibmFtZSI6IlRSQU5TRkVSIiwibW9kdWxlIjp7Im5hbWVzcGFjZSI6bnVsbCwibmFtZSI6ImNvaW4ifSwibW9kdWxlSGFzaCI6IjNpSUJRZEpuc3Q0NFoyWmdYb0hQa0FhdXliSjBoODVsX2VuX1NHSE5pYkUifSx7InBhcmFtcyI6WyIiLCJtdWx0aS0wMC0wMSIsMTAxMDAwMDAwXSwibmFtZSI6IlRSQU5TRkVSIiwibW9kdWxlIjp7Im5hbWVzcGFjZSI6bnVsbCwibmFtZSI6ImNvaW4ifSwibW9kdWxlSGFzaCI6IjNpSUJRZEpuc3Q0NFoyWmdYb0hQa0FhdXliSjBoODVsX2VuX1NHSE5pYkUifSx7InBhcmFtcyI6WyIiLCJtdWx0aS0wMi0wMy0wNC1hbnkiLDEyMzQwMDAwMF0sIm5hbWUiOiJUUkFOU0ZFUiIsIm1vZHVsZSI6eyJuYW1lc3BhY2UiOm51bGwsIm5hbWUiOiJjb2luIn0sIm1vZHVsZUhhc2giOiIzaUlCUWRKbnN0NDRaMlpnWG9IUGtBYXV5YkowaDg1bF9lbl9TR0hOaWJFIn0seyJwYXJhbXMiOlsiIiwiZTdmNzYzNGU5MjU1NDFmMzY4YjgyN2FkNWM3MjQyMTkwNTEwMGY2MjA1Mjg1YTc4YzE5ZDdiNGEzODcxMTgwNSIsMTUwXSwibmFtZSI6IlRSQU5TRkVSIiwibW9kdWxlIjp7Im5hbWVzcGFjZSI6bnVsbCwibmFtZSI6ImNvaW4ifSwibW9kdWxlSGFzaCI6IjNpSUJRZEpuc3Q0NFoyWmdYb0hQa0FhdXliSjBoODVsX2VuX1NHSE5pYkUifSx7InBhcmFtcyI6WyIiLCJhbGxvY2F0aW9uMDAiLDEwMDAwMF0sIm5hbWUiOiJUUkFOU0ZFUiIsIm1vZHVsZSI6eyJuYW1lc3BhY2UiOm51bGwsIm5hbWUiOiJjb2luIn0sIm1vZHVsZUhhc2giOiIzaUlCUWRKbnN0NDRaMlpnWG9IUGtBYXV5YkowaDg1bF9lbl9TR0hOaWJFIn0seyJwYXJhbXMiOlsiIiwiYWxsb2NhdGlvbjAxIiwxMDAwMDBdLCJuYW1lIjoiVFJBTlNGRVIiLCJtb2R1bGUiOnsibmFtZXNwYWNlIjpudWxsLCJuYW1lIjoiY29pbiJ9LCJtb2R1bGVIYXNoIjoiM2lJQlFkSm5zdDQ0WjJaZ1hvSFBrQWF1eWJKMGg4NWxfZW5fU0dITmliRSJ9LHsicGFyYW1zIjpbIiIsImFsbG9jYXRpb24wMiIsMTAwMDAwXSwibmFtZSI6IlRSQU5TRkVSIiwibW9kdWxlIjp7Im5hbWVzcGFjZSI6bnVsbCwibmFtZSI6ImNvaW4ifSwibW9kdWxlSGFzaCI6IjNpSUJRZEpuc3Q0NFoyWmdYb0hQa0FhdXliSjBoODVsX2VuX1NHSE5pYkUifV0sIm1ldGFEYXRhIjpudWxsLCJjb250aW51YXRpb24iOm51bGwsInR4SWQiOjh9") + , (unsafeFromText "eyJoYXNoIjoiejJtR1ZxektqeHp5bUdHLWNpWjBCSEpGM1EzeGtvOFYyNEE4ejBxcEl4ayIsInNpZ3MiOltdLCJjbWQiOiJ7XCJuZXR3b3JrSWRcIjpudWxsLFwicGF5bG9hZFwiOntcImV4ZWNcIjp7XCJkYXRhXCI6e1wic2VuZGVyMDdcIjpbXCI0YzMxZGM5ZWU3ZjI0MTc3Zjc4YjZmNTE4MDEyYTIwODMyNmUyYWYxZjM3YmIwYTI0MDViNTA1NmQwY2FkNjI4XCJdLFwic2VuZGVyMDFcIjpbXCI2YmUyZjQ4NWE3YWY3NWZlZGI0YjdmMTUzYTkwM2Y3ZTYwMDBjYTRhYTUwMTE3OWM5MWEyNDUwYjc3N2JkMmE3XCJdLFwic2VuZGVyMDZcIjpbXCI1ZmZjMWY3ZmVmN2E0NDczODYyNTc2MmY3NWE0MjI5NDU0OTUxZTAzZjJhZmM2ZjgxMzA5YzBjMWJkZjllZTZmXCJdLFwic2VuZGVyMDBcIjpbXCIzNjg4MjBmODBjMzI0YmJjN2MyYjA2MTA2ODhhN2RhNDNlMzlmOTFkMTE4NzMyNjcxY2Q5Yzc1MDBmZjQzY2NhXCJdLFwiZTdmN1wiOltcImU3Zjc2MzRlOTI1NTQxZjM2OGI4MjdhZDVjNzI0MjE5MDUxMDBmNjIwNTI4NWE3OGMxOWQ3YjRhMzg3MTE4MDVcIl0sXCJzZW5kZXIwNVwiOltcImYwOWQ4ZjYzOTRhZWE0MjVmZTY3ODNkODhjZDgxMzYzZDgwMTdmMTZhZmQzNzExYzU3NWJlMGY1Y2Q1YzliYjlcIl0sXCJzZW5kZXIwNFwiOltcIjJkNzBhYTRmNjk3YzNhM2I4ZGQ2ZDk3NzQ1YWMwNzRlZGNmZDBlYjY1YzM3Nzc0Y2RlMjUxMzU0ODNiZWE3MWVcIl0sXCJtdWx0aS0wMi0wMy0wNC1hbnlcIjp7XCJwcmVkXCI6XCJrZXlzLWFueVwiLFwia2V5c1wiOltcIjJkNzBhYTRmNjk3YzNhM2I4ZGQ2ZDk3NzQ1YWMwNzRlZGNmZDBlYjY1YzM3Nzc0Y2RlMjUxMzU0ODNiZWE3MWVcIixcIjNhOWRkNTMyZDczZGFjZTE5NWRiYjY0ZDFkYmE2NTcyZmI3ODNkMGZkZDMyNDY4NWUzMmZiZGEyZjg5Zjk5YTZcIixcIjQzZjJhZGIxZGUxOTIwMDBjYjM3NzdiYWNjN2Y5ODNiNjYxNGZkOWMxNzE1Y2Q0NGNkNDg0YjZkM2EwZDM0YzhcIl19LFwic2VuZGVyMDlcIjpbXCJjNTlkOTg0MGIwYjY2MDkwODM2NTQ2YjdlYjRhNzM2MDYyNTc1MjdlYzhjMmI0ODIzMDBmZDIyOTI2NGIwN2U2XCJdLFwic2VuZGVyMDNcIjpbXCI0M2YyYWRiMWRlMTkyMDAwY2IzNzc3YmFjYzdmOTgzYjY2MTRmZDljMTcxNWNkNDRjZDQ4NGI2ZDNhMGQzNGM4XCJdLFwibXVsdGktMDAtMDFcIjpbXCIzNjg4MjBmODBjMzI0YmJjN2MyYjA2MTA2ODhhN2RhNDNlMzlmOTFkMTE4NzMyNjcxY2Q5Yzc1MDBmZjQzY2NhXCIsXCI2YmUyZjQ4NWE3YWY3NWZlZGI0YjdmMTUzYTkwM2Y3ZTYwMDBjYTRhYTUwMTE3OWM5MWEyNDUwYjc3N2JkMmE3XCJdLFwic2VuZGVyMDhcIjpbXCI2M2IyZWJhNGVkNzBkNDYxMmQzZTdiYzkwZGIyZmJmNGM3NmY3YjA3NDM2M2U4NmQ3M2YwYmM2MTdmOGU4YjgxXCJdLFwic2VuZGVyMDJcIjpbXCIzYTlkZDUzMmQ3M2RhY2UxOTVkYmI2NGQxZGJhNjU3MmZiNzgzZDBmZGQzMjQ2ODVlMzJmYmRhMmY4OWY5OWE2XCJdfSxcImNvZGVcIjpcIihjb2luLmNvaW5iYXNlIFxcXCJzZW5kZXIwMFxcXCIgKHJlYWQta2V5c2V0IFxcXCJzZW5kZXIwMFxcXCIpIDEwMDAwMDAwMC4wKVxcbihjb2luLmNvaW5iYXNlIFxcXCJzZW5kZXIwMVxcXCIgKHJlYWQta2V5c2V0IFxcXCJzZW5kZXIwMVxcXCIpIDExMDAwMDAwMC4wKVxcbihjb2luLmNvaW5iYXNlIFxcXCJzZW5kZXIwMlxcXCIgKHJlYWQta2V5c2V0IFxcXCJzZW5kZXIwMlxcXCIpIDEyMDAwMDAwMC4wKVxcbihjb2luLmNvaW5iYXNlIFxcXCJzZW5kZXIwM1xcXCIgKHJlYWQta2V5c2V0IFxcXCJzZW5kZXIwM1xcXCIpIDEzMDAwMDAwMC4wKVxcbihjb2luLmNvaW5iYXNlIFxcXCJzZW5kZXIwNFxcXCIgKHJlYWQta2V5c2V0IFxcXCJzZW5kZXIwNFxcXCIpIDE0MDAwMDAwMC4wKVxcbihjb2luLmNvaW5iYXNlIFxcXCJzZW5kZXIwNVxcXCIgKHJlYWQta2V5c2V0IFxcXCJzZW5kZXIwNVxcXCIpIDE1MDAwMDAwMC4wKVxcbihjb2luLmNvaW5iYXNlIFxcXCJzZW5kZXIwNlxcXCIgKHJlYWQta2V5c2V0IFxcXCJzZW5kZXIwNlxcXCIpIDE2MDAwMDAwMC4wKVxcbihjb2luLmNvaW5iYXNlIFxcXCJzZW5kZXIwN1xcXCIgKHJlYWQta2V5c2V0IFxcXCJzZW5kZXIwN1xcXCIpIDE3MDAwMDAwMC4wKVxcbihjb2luLmNvaW5iYXNlIFxcXCJzZW5kZXIwOFxcXCIgKHJlYWQta2V5c2V0IFxcXCJzZW5kZXIwOFxcXCIpIDE4MDAwMDAwMC4wKVxcbihjb2luLmNvaW5iYXNlIFxcXCJzZW5kZXIwOVxcXCIgKHJlYWQta2V5c2V0IFxcXCJzZW5kZXIwOVxcXCIpIDE5MDAwMDAwMC4wKVxcbihjb2luLmNvaW5iYXNlIFxcXCJtdWx0aS0wMC0wMVxcXCIgKHJlYWQta2V5c2V0IFxcXCJtdWx0aS0wMC0wMVxcXCIpIDEwMTAwMDAwMC4wKVxcbihjb2luLmNvaW5iYXNlIFxcXCJtdWx0aS0wMi0wMy0wNC1hbnlcXFwiIChyZWFkLWtleXNldCBcXFwibXVsdGktMDItMDMtMDQtYW55XFxcIikgMTIzNDAwMDAwLjApXFxuXFxuKGNvaW4uY29pbmJhc2UgXFxcImU3Zjc2MzRlOTI1NTQxZjM2OGI4MjdhZDVjNzI0MjE5MDUxMDBmNjIwNTI4NWE3OGMxOWQ3YjRhMzg3MTE4MDVcXFwiIChyZWFkLWtleXNldCBcXFwiZTdmN1xcXCIpIDE1MC4wKVxcblxcbjsgZW5vdWdoIHRvIGNvdmVyIHRoZSBnYXMgY29zdHMgZm9yIGFsbG9jYXRpb24gcmVsZWFzZVxcbihjb2luLmNvaW5iYXNlIFxcXCJhbGxvY2F0aW9uMDBcXFwiIChrZXlzZXQtcmVmLWd1YXJkIFxcXCJhbGxvY2F0aW9uMDBcXFwiKSAxMDAwMDAuMClcXG4oY29pbi5jb2luYmFzZSBcXFwiYWxsb2NhdGlvbjAxXFxcIiAoa2V5c2V0LXJlZi1ndWFyZCBcXFwiYWxsb2NhdGlvbjAxXFxcIikgMTAwMDAwLjApXFxuKGNvaW4uY29pbmJhc2UgXFxcImFsbG9jYXRpb24wMlxcXCIgKGtleXNldC1yZWYtZ3VhcmQgXFxcImFsbG9jYXRpb24wMlxcXCIpIDEwMDAwMC4wKVwifX0sXCJzaWduZXJzXCI6W10sXCJtZXRhXCI6e1wiY3JlYXRpb25UaW1lXCI6MCxcInR0bFwiOjE3MjgwMCxcImdhc0xpbWl0XCI6MCxcImNoYWluSWRcIjpcIlwiLFwiZ2FzUHJpY2VcIjowLFwic2VuZGVyXCI6XCJcIn0sXCJub25jZVwiOlwiZGV2bmV0LWdyYW50czBcIn0ifQ", unsafeFromText "eyJnYXMiOjAsInJlc3VsdCI6eyJzdGF0dXMiOiJzdWNjZXNzIiwiZGF0YSI6IldyaXRlIHN1Y2NlZWRlZCJ9LCJyZXFLZXkiOiJ6Mm1HVnF6S2p4enltR0ctY2laMEJISkYzUTN4a284VjI0QTh6MHFwSXhrIiwibG9ncyI6ImFCUXM2aDJGVUN1a00tM0pjQmdLZGFvRU1Ta3p2OTJkM0VmT2t5MXNrMmciLCJldmVudHMiOlt7InBhcmFtcyI6WyIiLCJzZW5kZXIwMCIsMTAwMDAwMDAwXSwibmFtZSI6IlRSQU5TRkVSIiwibW9kdWxlIjp7Im5hbWVzcGFjZSI6bnVsbCwibmFtZSI6ImNvaW4ifSwibW9kdWxlSGFzaCI6IjNpSUJRZEpuc3Q0NFoyWmdYb0hQa0FhdXliSjBoODVsX2VuX1NHSE5pYkUifSx7InBhcmFtcyI6WyIiLCJzZW5kZXIwMSIsMTEwMDAwMDAwXSwibmFtZSI6IlRSQU5TRkVSIiwibW9kdWxlIjp7Im5hbWVzcGFjZSI6bnVsbCwibmFtZSI6ImNvaW4ifSwibW9kdWxlSGFzaCI6IjNpSUJRZEpuc3Q0NFoyWmdYb0hQa0FhdXliSjBoODVsX2VuX1NHSE5pYkUifSx7InBhcmFtcyI6WyIiLCJzZW5kZXIwMiIsMTIwMDAwMDAwXSwibmFtZSI6IlRSQU5TRkVSIiwibW9kdWxlIjp7Im5hbWVzcGFjZSI6bnVsbCwibmFtZSI6ImNvaW4ifSwibW9kdWxlSGFzaCI6IjNpSUJRZEpuc3Q0NFoyWmdYb0hQa0FhdXliSjBoODVsX2VuX1NHSE5pYkUifSx7InBhcmFtcyI6WyIiLCJzZW5kZXIwMyIsMTMwMDAwMDAwXSwibmFtZSI6IlRSQU5TRkVSIiwibW9kdWxlIjp7Im5hbWVzcGFjZSI6bnVsbCwibmFtZSI6ImNvaW4ifSwibW9kdWxlSGFzaCI6IjNpSUJRZEpuc3Q0NFoyWmdYb0hQa0FhdXliSjBoODVsX2VuX1NHSE5pYkUifSx7InBhcmFtcyI6WyIiLCJzZW5kZXIwNCIsMTQwMDAwMDAwXSwibmFtZSI6IlRSQU5TRkVSIiwibW9kdWxlIjp7Im5hbWVzcGFjZSI6bnVsbCwibmFtZSI6ImNvaW4ifSwibW9kdWxlSGFzaCI6IjNpSUJRZEpuc3Q0NFoyWmdYb0hQa0FhdXliSjBoODVsX2VuX1NHSE5pYkUifSx7InBhcmFtcyI6WyIiLCJzZW5kZXIwNSIsMTUwMDAwMDAwXSwibmFtZSI6IlRSQU5TRkVSIiwibW9kdWxlIjp7Im5hbWVzcGFjZSI6bnVsbCwibmFtZSI6ImNvaW4ifSwibW9kdWxlSGFzaCI6IjNpSUJRZEpuc3Q0NFoyWmdYb0hQa0FhdXliSjBoODVsX2VuX1NHSE5pYkUifSx7InBhcmFtcyI6WyIiLCJzZW5kZXIwNiIsMTYwMDAwMDAwXSwibmFtZSI6IlRSQU5TRkVSIiwibW9kdWxlIjp7Im5hbWVzcGFjZSI6bnVsbCwibmFtZSI6ImNvaW4ifSwibW9kdWxlSGFzaCI6IjNpSUJRZEpuc3Q0NFoyWmdYb0hQa0FhdXliSjBoODVsX2VuX1NHSE5pYkUifSx7InBhcmFtcyI6WyIiLCJzZW5kZXIwNyIsMTcwMDAwMDAwXSwibmFtZSI6IlRSQU5TRkVSIiwibW9kdWxlIjp7Im5hbWVzcGFjZSI6bnVsbCwibmFtZSI6ImNvaW4ifSwibW9kdWxlSGFzaCI6IjNpSUJRZEpuc3Q0NFoyWmdYb0hQa0FhdXliSjBoODVsX2VuX1NHSE5pYkUifSx7InBhcmFtcyI6WyIiLCJzZW5kZXIwOCIsMTgwMDAwMDAwXSwibmFtZSI6IlRSQU5TRkVSIiwibW9kdWxlIjp7Im5hbWVzcGFjZSI6bnVsbCwibmFtZSI6ImNvaW4ifSwibW9kdWxlSGFzaCI6IjNpSUJRZEpuc3Q0NFoyWmdYb0hQa0FhdXliSjBoODVsX2VuX1NHSE5pYkUifSx7InBhcmFtcyI6WyIiLCJzZW5kZXIwOSIsMTkwMDAwMDAwXSwibmFtZSI6IlRSQU5TRkVSIiwibW9kdWxlIjp7Im5hbWVzcGFjZSI6bnVsbCwibmFtZSI6ImNvaW4ifSwibW9kdWxlSGFzaCI6IjNpSUJRZEpuc3Q0NFoyWmdYb0hQa0FhdXliSjBoODVsX2VuX1NHSE5pYkUifSx7InBhcmFtcyI6WyIiLCJtdWx0aS0wMC0wMSIsMTAxMDAwMDAwXSwibmFtZSI6IlRSQU5TRkVSIiwibW9kdWxlIjp7Im5hbWVzcGFjZSI6bnVsbCwibmFtZSI6ImNvaW4ifSwibW9kdWxlSGFzaCI6IjNpSUJRZEpuc3Q0NFoyWmdYb0hQa0FhdXliSjBoODVsX2VuX1NHSE5pYkUifSx7InBhcmFtcyI6WyIiLCJtdWx0aS0wMi0wMy0wNC1hbnkiLDEyMzQwMDAwMF0sIm5hbWUiOiJUUkFOU0ZFUiIsIm1vZHVsZSI6eyJuYW1lc3BhY2UiOm51bGwsIm5hbWUiOiJjb2luIn0sIm1vZHVsZUhhc2giOiIzaUlCUWRKbnN0NDRaMlpnWG9IUGtBYXV5YkowaDg1bF9lbl9TR0hOaWJFIn0seyJwYXJhbXMiOlsiIiwiZTdmNzYzNGU5MjU1NDFmMzY4YjgyN2FkNWM3MjQyMTkwNTEwMGY2MjA1Mjg1YTc4YzE5ZDdiNGEzODcxMTgwNSIsMTUwXSwibmFtZSI6IlRSQU5TRkVSIiwibW9kdWxlIjp7Im5hbWVzcGFjZSI6bnVsbCwibmFtZSI6ImNvaW4ifSwibW9kdWxlSGFzaCI6IjNpSUJRZEpuc3Q0NFoyWmdYb0hQa0FhdXliSjBoODVsX2VuX1NHSE5pYkUifSx7InBhcmFtcyI6WyIiLCJhbGxvY2F0aW9uMDAiLDEwMDAwMF0sIm5hbWUiOiJUUkFOU0ZFUiIsIm1vZHVsZSI6eyJuYW1lc3BhY2UiOm51bGwsIm5hbWUiOiJjb2luIn0sIm1vZHVsZUhhc2giOiIzaUlCUWRKbnN0NDRaMlpnWG9IUGtBYXV5YkowaDg1bF9lbl9TR0hOaWJFIn0seyJwYXJhbXMiOlsiIiwiYWxsb2NhdGlvbjAxIiwxMDAwMDBdLCJuYW1lIjoiVFJBTlNGRVIiLCJtb2R1bGUiOnsibmFtZXNwYWNlIjpudWxsLCJuYW1lIjoiY29pbiJ9LCJtb2R1bGVIYXNoIjoiM2lJQlFkSm5zdDQ0WjJaZ1hvSFBrQWF1eWJKMGg4NWxfZW5fU0dITmliRSJ9LHsicGFyYW1zIjpbIiIsImFsbG9jYXRpb24wMiIsMTAwMDAwXSwibmFtZSI6IlRSQU5TRkVSIiwibW9kdWxlIjp7Im5hbWVzcGFjZSI6bnVsbCwibmFtZSI6ImNvaW4ifSwibW9kdWxlSGFzaCI6IjNpSUJRZEpuc3Q0NFoyWmdYb0hQa0FhdXliSjBoODVsX2VuX1NHSE5pYkUifV0sIm1ldGFEYXRhIjpudWxsLCJjb250aW51YXRpb24iOm51bGwsInR4SWQiOjh9") ] diff --git a/src/Chainweb/BlockHeader/Genesis/Development1to19Payload.hs b/src/Chainweb/BlockHeader/Genesis/Development1to19Payload.hs index 10c6b8fbc4..1d20e93d79 100644 --- a/src/Chainweb/BlockHeader/Genesis/Development1to19Payload.hs +++ b/src/Chainweb/BlockHeader/Genesis/Development1to19Payload.hs @@ -8,7 +8,7 @@ import qualified Data.Text as T import qualified Data.Vector as V import GHC.Stack -import Chainweb.Payload +import Chainweb.Pact.Payload import Chainweb.Utils (unsafeFromText, toText) payloadBlock :: HasCallStack => PayloadWithOutputs @@ -21,7 +21,7 @@ payloadBlock where actualHash, expectedHash :: BlockPayloadHash actualHash = _payloadWithOutputsPayloadHash payload - expectedHash = unsafeFromText "tL8Um8Zql3uKtYX5yo9-YoW_cKGf_BFBONzVD5JDd5k" + expectedHash = unsafeFromText "jrfVQ_AVbtnWRVXeUhyNurrz1XXl37sofUfEBh7EBG0" payload = newPayloadWithOutputs minerData coinbase txs minerData = unsafeFromText "eyJhY2NvdW50IjoiTm9NaW5lciIsInByZWRpY2F0ZSI6IjwiLCJwdWJsaWMta2V5cyI6W119" @@ -35,5 +35,5 @@ payloadBlock , (unsafeFromText "eyJoYXNoIjoiQ1pteWxXZmllUk1CTXU1dzJFT21wRndLLXQ3YmNPVHM0bUsyYVQzM3VSNCIsInNpZ3MiOltdLCJjbWQiOiJ7XCJuZXR3b3JrSWRcIjpudWxsLFwicGF5bG9hZFwiOntcImV4ZWNcIjp7XCJkYXRhXCI6e1wibnMtYWRtaW4ta2V5c2V0XCI6W1wiMzY4ODIwZjgwYzMyNGJiYzdjMmIwNjEwNjg4YTdkYTQzZTM5ZjkxZDExODczMjY3MWNkOWM3NTAwZmY0M2NjYVwiXSxcIm5zLW9wZXJhdGUta2V5c2V0XCI6W1wiMzY4ODIwZjgwYzMyNGJiYzdjMmIwNjEwNjg4YTdkYTQzZTM5ZjkxZDExODczMjY3MWNkOWM3NTAwZmY0M2NjYVwiXSxcIm5zLWdlbmVzaXMta2V5c2V0XCI6e1wicHJlZFwiOlwiPVwiLFwia2V5c1wiOltdfX0sXCJjb2RlXCI6XCIoZGVmaW5lLWtleXNldCAnbnMtYWRtaW4ta2V5c2V0IChyZWFkLWtleXNldCAnbnMtYWRtaW4ta2V5c2V0KSlcXG4oZGVmaW5lLWtleXNldCAnbnMtb3BlcmF0ZS1rZXlzZXQgKHJlYWQta2V5c2V0ICducy1nZW5lc2lzLWtleXNldCkpXFxuXFxuKG1vZHVsZSBucyBHT1ZFUk5BTkNFXFxuICBcXFwiQWRtaW5pc3RlcnMgZGVmaW5pdGlvbiBvZiBuZXcgbmFtZXNwYWNlcyBpbiBDaGFpbndlYi5cXFwiXFxuXFxuICAoZGVmc2NoZW1hIHJlZy1lbnRyeVxcbiAgICBhZG1pbi1ndWFyZDpndWFyZFxcbiAgICBhY3RpdmU6Ym9vbClcXG5cXG4gIChkZWZ0YWJsZSByZWdpc3RyeTp7cmVnLWVudHJ5fSlcXG5cXG4gIChkZWZjYXAgR09WRVJOQU5DRSAoKVxcbiAgICAoZW5mb3JjZS1rZXlzZXQgJ25zLWFkbWluLWtleXNldCkpXFxuXFxuICAoZGVmY2FwIE9QRVJBVEUgKClcXG4gICAgKGVuZm9yY2Uta2V5c2V0ICducy1vcGVyYXRlLWtleXNldCkpXFxuXFxuICAoZGVmY29uc3QgR1VBUkRfU1VDQ0VTUyAoY3JlYXRlLXVzZXItZ3VhcmQgKHN1Y2Nlc3MpKSlcXG4gIChkZWZjb25zdCBHVUFSRF9GQUlMVVJFIChjcmVhdGUtdXNlci1ndWFyZCAoZmFpbHVyZSkpKVxcblxcbiAgKGRlZnVuIHN1Y2Nlc3MgKClcXG4gICAgdHJ1ZSlcXG4gIChkZWZ1biBmYWlsdXJlICgpXFxuICAgIChlbmZvcmNlIGZhbHNlIFxcXCJEaXNhYmxlZFxcXCIpKVxcblxcbiAgKGRlZnVuIHZhbGlkYXRlLW5hbWUgKG5hbWUpXFxuICAgIChlbmZvcmNlICghPSBcXFwiXFxcIiBuYW1lKSBcXFwiRW1wdHkgbmFtZSBub3QgYWxsb3dlZFxcXCIpXFxuICAgIChlbmZvcmNlICg8IChsZW5ndGggbmFtZSkgNjQpIFxcXCJOYW1lIG11c3QgYmUgbGVzcyB0aGFuIDY0IGNoYXJhY3RlcnMgbG9uZ1xcXCIpXFxuICAgIChlbmZvcmNlIChpcy1jaGFyc2V0IENIQVJTRVRfTEFUSU4xIG5hbWUpXFxuICAgICAgICAgICAgIFxcXCJOYW1lIG11c3QgYmUgaW4gbGF0aW4xIGNoYXJzZXRcXFwiKSlcXG5cXG4gIChkZWZ1biBjcmVhdGUtcHJpbmNpcGFsLW5hbWVzcGFjZTpzdHJpbmdcXG4gICAgICAoIGc6Z3VhcmRcXG4gICAgICAgIClcXG4gICAgXFxcIiBGb3JtYXQgcHJpbmNpcGFsIG5hbWVzcGFjZSBhcyBQYWN0IGhhc2ggKEJMQUtFMmIyNTYpIG9mIHByaW5jaXBhbCBcXFxcXFxuICAgIFxcXFwgaW4gaGV4IHRydW5jYXRlZCB0byAxNjAgYml0cyAoNDAgY2hhcmFjdGVycyksIHByZXBlbmRlZCB3aXRoICduXycuXFxcXFxcbiAgICBcXFxcIE9ubHkgdzogYW5kIGs6IGFjY291bnQgcHJvdG9jb2xzIGFyZSBzdXBwb3J0ZWQuIFxcXCJcXG5cXG4gICAgKGxldFxcbiAgICAgICgodHkgKHR5cGVvZi1wcmluY2lwYWwgKGNyZWF0ZS1wcmluY2lwYWwgZykpKSlcXG5cXG4gICAgICA7OyBvbmx5IHc6IGFuZCBrOiBjdXJyZW50bHkgc3VwcG9ydGVkXFxuICAgICAgKGlmIChvciAoPSB0eSBcXFwiazpcXFwiKSAoPSB0eSBcXFwidzpcXFwiKSlcXG4gICAgICAgICgrIFxcXCJuX1xcXCIgKHRha2UgNDAgKGludC10by1zdHIgMTYgKHN0ci10by1pbnQgNjQgKGhhc2ggZykpKSkpXFxuICAgICAgICAoZW5mb3JjZSBmYWxzZVxcbiAgICAgICAgICAoZm9ybWF0IFxcXCJVbnN1cHBvcnRlZCBndWFyZCBwcm90b2NvbDoge31cXFwiIFt0eV0pKVxcbiAgICAgICAgKSlcXG4gIClcXG5cXG4gIChkZWZ1biB2YWxpZGF0ZTpib29sXFxuICAgICAgKCBucy1uYW1lOnN0cmluZ1xcbiAgICAgICAgbnMtYWRtaW46Z3VhcmRcXG4gICAgICAgIClcXG4gICAgXFxcIiBNYW5hZ2VzIG5hbWVzcGFjZSBpbnN0YWxsIGZvciBDaGFpbndlYi4gXFxcXFxcbiAgICBcXFxcIEFsbG93cyBwcmluY2lwYWwgbmFtZXNwYWNlcy4gXFxcXFxcbiAgICBcXFxcIE5vbi1wcmluY2lwYWwgbmFtZXNwYWNlcyByZXF1aXJlIGFjdGl2ZSByb3cgaW4gcmVnaXN0cnkgXFxcXFxcbiAgICBcXFxcIGZvciBOUy1OQU1FIHdpdGggZ3VhcmQgbWF0Y2hpbmcgTlMtQURNSU4uXFxcIlxcblxcbiAgICAoaWYgKD0gKGNyZWF0ZS1wcmluY2lwYWwtbmFtZXNwYWNlIG5zLWFkbWluKSBucy1uYW1lKVxcblxcbiAgICAgIHRydWUgOzsgYWxsb3cgcHJpbmNpcGFsIG5hbWVzcGFjZXNcXG5cXG4gICAgICAod2l0aC1kZWZhdWx0LXJlYWQgcmVnaXN0cnkgbnMtbmFtZSAgICAgICA7OyBvdGhlcndpc2UgZW5mb3JjZSByZWdpc3RyeVxcbiAgICAgICAgeyAnYWRtaW4tZ3VhcmQgOiBucy1hZG1pblxcbiAgICAgICAgLCAnYWN0aXZlIDogZmFsc2UgfVxcbiAgICAgICAgeyAnYWRtaW4tZ3VhcmQgOj0gYWdcXG4gICAgICAgICwgJ2FjdGl2ZSA6PSBpcy1hY3RpdmUgfVxcblxcbiAgICAgICAgKGVuZm9yY2UgaXMtYWN0aXZlIFxcXCJJbmFjdGl2ZSBvciB1bnJlZ2lzdGVyZWQgbmFtZXNwYWNlXFxcIilcXG4gICAgICAgIChlbmZvcmNlICg9IG5zLWFkbWluIGFnKSBcXFwiQWRtaW4gZ3VhcmQgbXVzdCBtYXRjaCBndWFyZCBpbiByZWdpc3RyeVxcXCIpXFxuXFxuICAgICAgICB0cnVlKVxcbiAgICAgICkpXFxuXFxuICAoZGVmdW4gd3JpdGUtcmVnaXN0cnk6c3RyaW5nXFxuICAgICAgKCBucy1uYW1lOnN0cmluZ1xcbiAgICAgICAgZ3VhcmQ6Z3VhcmRcXG4gICAgICAgIGFjdGl2ZTpib29sXFxuICAgICAgICApXFxuICAgIFxcXCIgV3JpdGUgZW50cnkgd2l0aCBHVUFSRCBhbmQgQUNUSVZFIGludG8gcmVnaXN0cnkgZm9yIE5BTUUuIFxcXFxcXG4gICAgXFxcXCBHdWFyZGVkIGJ5IG9wZXJhdGUga2V5c2V0LiBcXFwiXFxuXFxuICAgICh3aXRoLWNhcGFiaWxpdHkgKE9QRVJBVEUpXFxuXFxuICAgICAgKHZhbGlkYXRlLW5hbWUgbnMtbmFtZSlcXG5cXG4gICAgICAod3JpdGUgcmVnaXN0cnkgbnMtbmFtZVxcbiAgICAgICAgeyAnYWRtaW4tZ3VhcmQ6IGd1YXJkXFxuICAgICAgICAsICdhY3RpdmU6IGFjdGl2ZSB9KVxcblxcbiAgICAgIFxcXCJSZWdpc3RlciBlbnRyeSB3cml0dGVuXFxcIikpXFxuXFxuICAoZGVmdW4gcXVlcnk6b2JqZWN0e3JlZy1lbnRyeX1cXG4gICAgICAoIG5zLW5hbWU6c3RyaW5nIClcXG4gICAgKHJlYWQgcmVnaXN0cnkgbnMtbmFtZSkpXFxuXFxuKVxcblxcbihjcmVhdGUtdGFibGUgcmVnaXN0cnkpXFxuXFxuKHdyaXRlLXJlZ2lzdHJ5IFxcXCJrYWRlbmFcXFwiXFxuICAoa2V5c2V0LXJlZi1ndWFyZCAnbnMtb3BlcmF0ZS1rZXlzZXQpIHRydWUpXFxuKHdyaXRlLXJlZ2lzdHJ5IFxcXCJ1c2VyXFxcIiBHVUFSRF9GQUlMVVJFIHRydWUpXFxuKHdyaXRlLXJlZ2lzdHJ5IFxcXCJmcmVlXFxcIiBHVUFSRF9GQUlMVVJFIHRydWUpXFxuXFxuKGRlZmluZS1uYW1lc3BhY2UgXFxcImthZGVuYVxcXCJcXG4gIChrZXlzZXQtcmVmLWd1YXJkICducy1vcGVyYXRlLWtleXNldClcXG4gIChrZXlzZXQtcmVmLWd1YXJkICducy1vcGVyYXRlLWtleXNldCkpXFxuXFxuKGRlZmluZS1uYW1lc3BhY2UgXFxcInVzZXJcXFwiIEdVQVJEX1NVQ0NFU1MgR1VBUkRfRkFJTFVSRSlcXG4oZGVmaW5lLW5hbWVzcGFjZSBcXFwiZnJlZVxcXCIgR1VBUkRfU1VDQ0VTUyBHVUFSRF9GQUlMVVJFKVxcbjs7cm90YXRlIHRvIHJlYWwgb3BlcmF0ZSBrZXlzZXRcXG4oZGVmaW5lLWtleXNldCAnbnMtb3BlcmF0ZS1rZXlzZXQgKHJlYWQta2V5c2V0ICducy1vcGVyYXRlLWtleXNldCkpXFxuXCJ9fSxcInNpZ25lcnNcIjpbXSxcIm1ldGFcIjp7XCJjcmVhdGlvblRpbWVcIjowLFwidHRsXCI6MTcyODAwLFwiZ2FzTGltaXRcIjowLFwiY2hhaW5JZFwiOlwiXCIsXCJnYXNQcmljZVwiOjAsXCJzZW5kZXJcIjpcIlwifSxcIm5vbmNlXCI6XCJsb2FkLW5zLWRldm5ldC1zZW5kZXIwMFwifSJ9", unsafeFromText "eyJnYXMiOjAsInJlc3VsdCI6eyJzdGF0dXMiOiJzdWNjZXNzIiwiZGF0YSI6IktleXNldCB3cml0ZSBzdWNjZXNzIn0sInJlcUtleSI6IkNabXlsV2ZpZVJNQk11NXcyRU9tcEZ3Sy10N2JjT1RzNG1LMmFUMzN1UjQiLCJsb2dzIjoidDdzQzg1Y1hlWFdSdG90M1lEb2pSejZibWtncEN6enJQQ0Z6QThzTkg3OCIsIm1ldGFEYXRhIjpudWxsLCJjb250aW51YXRpb24iOm51bGwsInR4SWQiOjV9") , (unsafeFromText "eyJoYXNoIjoiWE5BNmxPSjFXLTdYWXY1WWI0QXFsNzRveFlJN09KcWpPUVQ1b1k0OHEtZyIsInNpZ3MiOltdLCJjbWQiOiJ7XCJuZXR3b3JrSWRcIjpudWxsLFwicGF5bG9hZFwiOntcImV4ZWNcIjp7XCJkYXRhXCI6e1wiYWxsb2NhdGlvbi10ZXN0MDFcIjpbXCI3MDExYzM3OTE0MGZmODk5ZjdlNjEzYWMwYTk3ODRhN2MwYTUxNWQzMGZlMGFiMmIwYzA3ZTVhYTE3NjM1ZTNlXCJdLFwiYWxsb2NhdGlvbjAyXCI6W1wiZTllNGU3MWJkMDYzZGNmN2UwNmJkNWIxYTE2Njg4ODk3ZDE1Y2E4YmQyZTUwOWM0NTNjNjE2MjE5YzE4NmNjNVwiXSxcImFsbG9jYXRpb24wMFwiOltcImQ4MmQwZGNkZTk4MjU1MDVkODZhZmI2ZGNjMTA0MTFkNmI2N2E0MjlhNzllMjFiZGE0YmIxMTliZjI4YWI4NzFcIl0sXCJhbGxvY2F0aW9uLXRlc3QwMlwiOltcIjA2NTQ0ZTIyYmZlZjIzMGQ2ZDIyZjk0ODZhYzZjYjc2YmYyNThlYmZiZjAxMzdlZTU4ZjY1NzQzZTFhNWI4YzRcIl0sXCJhbGxvY2F0aW9uMDFcIjpbXCJiNGM4YTNlYTkxZDMxNDZiMDU2MDk5NDc0MGYwZTNlZWQ5MWM1OWQyZWVjYTFkYzk5ZjBjMjg3Mjg0NWMyOTRkXCJdfSxcImNvZGVcIjpcIihkZWZpbmUta2V5c2V0IFxcXCJhbGxvY2F0aW9uMDBcXFwiIChyZWFkLWtleXNldCBcXFwiYWxsb2NhdGlvbjAwXFxcIikpXFxuKGRlZmluZS1rZXlzZXQgXFxcImFsbG9jYXRpb24wMVxcXCIgKHJlYWQta2V5c2V0IFxcXCJhbGxvY2F0aW9uMDFcXFwiKSlcXG4oZGVmaW5lLWtleXNldCBcXFwiYWxsb2NhdGlvbjAyXFxcIiAocmVhZC1rZXlzZXQgXFxcImFsbG9jYXRpb24wMlxcXCIpKVxcbihkZWZpbmUta2V5c2V0IFxcXCJhbGxvY2F0aW9uLXRlc3QwMVxcXCIgKHJlYWQta2V5c2V0IFxcXCJhbGxvY2F0aW9uLXRlc3QwMVxcXCIpKVxcbihkZWZpbmUta2V5c2V0IFxcXCJhbGxvY2F0aW9uLXRlc3QwMlxcXCIgKHJlYWQta2V5c2V0IFxcXCJhbGxvY2F0aW9uLXRlc3QwMlxcXCIpKVwifX0sXCJzaWduZXJzXCI6W10sXCJtZXRhXCI6e1wiY3JlYXRpb25UaW1lXCI6MCxcInR0bFwiOjE3MjgwMCxcImdhc0xpbWl0XCI6MCxcImNoYWluSWRcIjpcIlwiLFwiZ2FzUHJpY2VcIjowLFwic2VuZGVyXCI6XCJcIn0sXCJub25jZVwiOlwiZGV2bmV0LWtleXNldHNcIn0ifQ", unsafeFromText "eyJnYXMiOjAsInJlc3VsdCI6eyJzdGF0dXMiOiJzdWNjZXNzIiwiZGF0YSI6IktleXNldCB3cml0ZSBzdWNjZXNzIn0sInJlcUtleSI6IlhOQTZsT0oxVy03WFl2NVliNEFxbDc0b3hZSTdPSnFqT1FUNW9ZNDhxLWciLCJsb2dzIjoiYXJRSWpQVGRrcXhoQTNjWl9WaVE3OXM3Uk5XRTlGV2Rha0xWdXl4Nlc0YyIsIm1ldGFEYXRhIjpudWxsLCJjb250aW51YXRpb24iOm51bGwsInR4SWQiOjZ9") , (unsafeFromText "eyJoYXNoIjoiNWtxZ0tzWWtwbjZCcS1KUnhNYnA1VG9jUWhRWGRJVVNiM1NGQm1Ba3VWcyIsInNpZ3MiOltdLCJjbWQiOiJ7XCJuZXR3b3JrSWRcIjpudWxsLFwicGF5bG9hZFwiOntcImV4ZWNcIjp7XCJkYXRhXCI6bnVsbCxcImNvZGVcIjpcIihjb2luLmNyZWF0ZS1hbGxvY2F0aW9uLWFjY291bnQgXFxcImFsbG9jYXRpb24wMFxcXCIgKHRpbWUgXFxcIjE5MDAtMTAtMTVUMTg6MDA6MDBaXFxcIikgXFxcImFsbG9jYXRpb24wMFxcXCIgMTAwMDAwMC4wKVxcbihjb2luLmNyZWF0ZS1hbGxvY2F0aW9uLWFjY291bnQgXFxcImFsbG9jYXRpb24wMVxcXCIgKHRpbWUgXFxcIjIxMDAtMTAtMzFUMTg6MDA6MDBaXFxcIikgXFxcImFsbG9jYXRpb24wMVxcXCIgMTAwMDAwMC4wKVxcbihjb2luLmNyZWF0ZS1hbGxvY2F0aW9uLWFjY291bnQgXFxcImFsbG9jYXRpb24wMlxcXCIgKHRpbWUgXFxcIjE5MDAtMTAtMzFUMTg6MDA6MDBaXFxcIikgXFxcImFsbG9jYXRpb24wMlxcXCIgMTAwMDAwMC4wKVxcbihjb2luLmNyZWF0ZS1hbGxvY2F0aW9uLWFjY291bnQgXFxcImFsbG9jYXRpb24tdGVzdDAxXFxcIiAodGltZSBcXFwiMTkwMC0xMC0zMVQxODowMDowMFpcXFwiKSBcXFwiYWxsb2NhdGlvbi10ZXN0MDFcXFwiIDEwMDAwMDAuMClcXG4oY29pbi5jcmVhdGUtYWxsb2NhdGlvbi1hY2NvdW50IFxcXCJhbGxvY2F0aW9uLXRlc3QwMlxcXCIgKHRpbWUgXFxcIjE5MDAtMTAtMzFUMTg6MDA6MDBaXFxcIikgXFxcImFsbG9jYXRpb24tdGVzdDAyXFxcIiAyMDAwMDAwLjApXCJ9fSxcInNpZ25lcnNcIjpbXSxcIm1ldGFcIjp7XCJjcmVhdGlvblRpbWVcIjowLFwidHRsXCI6MTcyODAwLFwiZ2FzTGltaXRcIjowLFwiY2hhaW5JZFwiOlwiXCIsXCJnYXNQcmljZVwiOjAsXCJzZW5kZXJcIjpcIlwifSxcIm5vbmNlXCI6XCJkZXZuZXQtYWxsb2NhdGlvbnNcIn0ifQ", unsafeFromText "eyJnYXMiOjAsInJlc3VsdCI6eyJzdGF0dXMiOiJzdWNjZXNzIiwiZGF0YSI6IldyaXRlIHN1Y2NlZWRlZCJ9LCJyZXFLZXkiOiI1a3FnS3NZa3BuNkJxLUpSeE1icDVUb2NRaFFYZElVU2IzU0ZCbUFrdVZzIiwibG9ncyI6IkhpX3ZfVEhFT2s2aEJFRU0yWmV2Vzh3eVJsQWpUZzNjVUQydXBlVkx0b1UiLCJtZXRhRGF0YSI6bnVsbCwiY29udGludWF0aW9uIjpudWxsLCJ0eElkIjo3fQ") - , (unsafeFromText "eyJoYXNoIjoiZjIxVTFJRnlRN0ZfLTRlTnR6QTFuWnZjQ0g5cnY5ZnZsNWM1a0RyNXFsdyIsInNpZ3MiOltdLCJjbWQiOiJ7XCJuZXR3b3JrSWRcIjpudWxsLFwicGF5bG9hZFwiOntcImV4ZWNcIjp7XCJkYXRhXCI6e1wic2VuZGVyMDdcIjpbXCI0YzMxZGM5ZWU3ZjI0MTc3Zjc4YjZmNTE4MDEyYTIwODMyNmUyYWYxZjM3YmIwYTI0MDViNTA1NmQwY2FkNjI4XCJdLFwic2VuZGVyMDFcIjpbXCI2YmUyZjQ4NWE3YWY3NWZlZGI0YjdmMTUzYTkwM2Y3ZTYwMDBjYTRhYTUwMTE3OWM5MWEyNDUwYjc3N2JkMmE3XCJdLFwic2VuZGVyMDZcIjpbXCI1ZmZjMWY3ZmVmN2E0NDczODYyNTc2MmY3NWE0MjI5NDU0OTUxZTAzZjJhZmM2ZjgxMzA5YzBjMWJkZjllZTZmXCJdLFwic2VuZGVyMDBcIjpbXCIzNjg4MjBmODBjMzI0YmJjN2MyYjA2MTA2ODhhN2RhNDNlMzlmOTFkMTE4NzMyNjcxY2Q5Yzc1MDBmZjQzY2NhXCJdLFwiZTdmN1wiOltcImU3Zjc2MzRlOTI1NTQxZjM2OGI4MjdhZDVjNzI0MjE5MDUxMDBmNjIwNTI4NWE3OGMxOWQ3YjRhMzg3MTE4MDVcIl0sXCJzZW5kZXIwNVwiOltcImYwOWQ4ZjYzOTRhZWE0MjVmZTY3ODNkODhjZDgxMzYzZDgwMTdmMTZhZmQzNzExYzU3NWJlMGY1Y2Q1YzliYjlcIl0sXCJzZW5kZXIwNFwiOltcIjJkNzBhYTRmNjk3YzNhM2I4ZGQ2ZDk3NzQ1YWMwNzRlZGNmZDBlYjY1YzM3Nzc0Y2RlMjUxMzU0ODNiZWE3MWVcIl0sXCJtdWx0aS0wMi0wMy0wNC1hbnlcIjp7XCJwcmVkXCI6XCJrZXlzLWFueVwiLFwia2V5c1wiOltcIjNhOWRkNTMyZDczZGFjZTE5NWRiYjY0ZDFkYmE2NTcyZmI3ODNkMGZkZDMyNDY4NWUzMmZiZGEyZjg5Zjk5YTZcIixcIjQzZjJhZGIxZGUxOTIwMDBjYjM3NzdiYWNjN2Y5ODNiNjYxNGZkOWMxNzE1Y2Q0NGNkNDg0YjZkM2EwZDM0YzhcIixcIjJkNzBhYTRmNjk3YzNhM2I4ZGQ2ZDk3NzQ1YWMwNzRlZGNmZDBlYjY1YzM3Nzc0Y2RlMjUxMzU0ODNiZWE3MWVcIl19LFwic2VuZGVyMDlcIjpbXCJjNTlkOTg0MGIwYjY2MDkwODM2NTQ2YjdlYjRhNzM2MDYyNTc1MjdlYzhjMmI0ODIzMDBmZDIyOTI2NGIwN2U2XCJdLFwic2VuZGVyMDNcIjpbXCI0M2YyYWRiMWRlMTkyMDAwY2IzNzc3YmFjYzdmOTgzYjY2MTRmZDljMTcxNWNkNDRjZDQ4NGI2ZDNhMGQzNGM4XCJdLFwibXVsdGktMDAtMDFcIjpbXCIzNjg4MjBmODBjMzI0YmJjN2MyYjA2MTA2ODhhN2RhNDNlMzlmOTFkMTE4NzMyNjcxY2Q5Yzc1MDBmZjQzY2NhXCIsXCI2YmUyZjQ4NWE3YWY3NWZlZGI0YjdmMTUzYTkwM2Y3ZTYwMDBjYTRhYTUwMTE3OWM5MWEyNDUwYjc3N2JkMmE3XCJdLFwic2VuZGVyMDhcIjpbXCI2M2IyZWJhNGVkNzBkNDYxMmQzZTdiYzkwZGIyZmJmNGM3NmY3YjA3NDM2M2U4NmQ3M2YwYmM2MTdmOGU4YjgxXCJdLFwic2VuZGVyMDJcIjpbXCIzYTlkZDUzMmQ3M2RhY2UxOTVkYmI2NGQxZGJhNjU3MmZiNzgzZDBmZGQzMjQ2ODVlMzJmYmRhMmY4OWY5OWE2XCJdfSxcImNvZGVcIjpcIihjb2luLmNvaW5iYXNlIFxcXCJzZW5kZXIwMFxcXCIgKHJlYWQta2V5c2V0IFxcXCJzZW5kZXIwMFxcXCIpIDEwMDAwMDAwMC4wKVxcbihjb2luLmNvaW5iYXNlIFxcXCJzZW5kZXIwMVxcXCIgKHJlYWQta2V5c2V0IFxcXCJzZW5kZXIwMVxcXCIpIDExMDAwMDAwMC4wKVxcbihjb2luLmNvaW5iYXNlIFxcXCJzZW5kZXIwMlxcXCIgKHJlYWQta2V5c2V0IFxcXCJzZW5kZXIwMlxcXCIpIDEyMDAwMDAwMC4wKVxcbihjb2luLmNvaW5iYXNlIFxcXCJzZW5kZXIwM1xcXCIgKHJlYWQta2V5c2V0IFxcXCJzZW5kZXIwM1xcXCIpIDEzMDAwMDAwMC4wKVxcbihjb2luLmNvaW5iYXNlIFxcXCJzZW5kZXIwNFxcXCIgKHJlYWQta2V5c2V0IFxcXCJzZW5kZXIwNFxcXCIpIDE0MDAwMDAwMC4wKVxcbihjb2luLmNvaW5iYXNlIFxcXCJzZW5kZXIwNVxcXCIgKHJlYWQta2V5c2V0IFxcXCJzZW5kZXIwNVxcXCIpIDE1MDAwMDAwMC4wKVxcbihjb2luLmNvaW5iYXNlIFxcXCJzZW5kZXIwNlxcXCIgKHJlYWQta2V5c2V0IFxcXCJzZW5kZXIwNlxcXCIpIDE2MDAwMDAwMC4wKVxcbihjb2luLmNvaW5iYXNlIFxcXCJzZW5kZXIwN1xcXCIgKHJlYWQta2V5c2V0IFxcXCJzZW5kZXIwN1xcXCIpIDE3MDAwMDAwMC4wKVxcbihjb2luLmNvaW5iYXNlIFxcXCJzZW5kZXIwOFxcXCIgKHJlYWQta2V5c2V0IFxcXCJzZW5kZXIwOFxcXCIpIDE4MDAwMDAwMC4wKVxcbihjb2luLmNvaW5iYXNlIFxcXCJzZW5kZXIwOVxcXCIgKHJlYWQta2V5c2V0IFxcXCJzZW5kZXIwOVxcXCIpIDE5MDAwMDAwMC4wKVxcbihjb2luLmNvaW5iYXNlIFxcXCJtdWx0aS0wMC0wMVxcXCIgKHJlYWQta2V5c2V0IFxcXCJtdWx0aS0wMC0wMVxcXCIpIDEwMTAwMDAwMC4wKVxcbihjb2luLmNvaW5iYXNlIFxcXCJtdWx0aS0wMi0wMy0wNC1hbnlcXFwiIChyZWFkLWtleXNldCBcXFwibXVsdGktMDItMDMtMDQtYW55XFxcIikgMTIzNDAwMDAwLjApXFxuXFxuKGNvaW4uY29pbmJhc2UgXFxcImU3Zjc2MzRlOTI1NTQxZjM2OGI4MjdhZDVjNzI0MjE5MDUxMDBmNjIwNTI4NWE3OGMxOWQ3YjRhMzg3MTE4MDVcXFwiIChyZWFkLWtleXNldCBcXFwiZTdmN1xcXCIpIDE1MC4wKVwifX0sXCJzaWduZXJzXCI6W10sXCJtZXRhXCI6e1wiY3JlYXRpb25UaW1lXCI6MCxcInR0bFwiOjE3MjgwMCxcImdhc0xpbWl0XCI6MCxcImNoYWluSWRcIjpcIlwiLFwiZ2FzUHJpY2VcIjowLFwic2VuZGVyXCI6XCJcIn0sXCJub25jZVwiOlwiZGV2bmV0LWdyYW50c05cIn0ifQ", unsafeFromText "eyJnYXMiOjAsInJlc3VsdCI6eyJzdGF0dXMiOiJzdWNjZXNzIiwiZGF0YSI6IldyaXRlIHN1Y2NlZWRlZCJ9LCJyZXFLZXkiOiJmMjFVMUlGeVE3Rl8tNGVOdHpBMW5admNDSDlydjlmdmw1YzVrRHI1cWx3IiwibG9ncyI6IkF3MTVuVFF0YmlQYlVCQm1reGpRV09JZlc3ZHNfUi1sWjhNMGZDMXAxZHciLCJldmVudHMiOlt7InBhcmFtcyI6WyIiLCJzZW5kZXIwMCIsMTAwMDAwMDAwXSwibmFtZSI6IlRSQU5TRkVSIiwibW9kdWxlIjp7Im5hbWVzcGFjZSI6bnVsbCwibmFtZSI6ImNvaW4ifSwibW9kdWxlSGFzaCI6IjNpSUJRZEpuc3Q0NFoyWmdYb0hQa0FhdXliSjBoODVsX2VuX1NHSE5pYkUifSx7InBhcmFtcyI6WyIiLCJzZW5kZXIwMSIsMTEwMDAwMDAwXSwibmFtZSI6IlRSQU5TRkVSIiwibW9kdWxlIjp7Im5hbWVzcGFjZSI6bnVsbCwibmFtZSI6ImNvaW4ifSwibW9kdWxlSGFzaCI6IjNpSUJRZEpuc3Q0NFoyWmdYb0hQa0FhdXliSjBoODVsX2VuX1NHSE5pYkUifSx7InBhcmFtcyI6WyIiLCJzZW5kZXIwMiIsMTIwMDAwMDAwXSwibmFtZSI6IlRSQU5TRkVSIiwibW9kdWxlIjp7Im5hbWVzcGFjZSI6bnVsbCwibmFtZSI6ImNvaW4ifSwibW9kdWxlSGFzaCI6IjNpSUJRZEpuc3Q0NFoyWmdYb0hQa0FhdXliSjBoODVsX2VuX1NHSE5pYkUifSx7InBhcmFtcyI6WyIiLCJzZW5kZXIwMyIsMTMwMDAwMDAwXSwibmFtZSI6IlRSQU5TRkVSIiwibW9kdWxlIjp7Im5hbWVzcGFjZSI6bnVsbCwibmFtZSI6ImNvaW4ifSwibW9kdWxlSGFzaCI6IjNpSUJRZEpuc3Q0NFoyWmdYb0hQa0FhdXliSjBoODVsX2VuX1NHSE5pYkUifSx7InBhcmFtcyI6WyIiLCJzZW5kZXIwNCIsMTQwMDAwMDAwXSwibmFtZSI6IlRSQU5TRkVSIiwibW9kdWxlIjp7Im5hbWVzcGFjZSI6bnVsbCwibmFtZSI6ImNvaW4ifSwibW9kdWxlSGFzaCI6IjNpSUJRZEpuc3Q0NFoyWmdYb0hQa0FhdXliSjBoODVsX2VuX1NHSE5pYkUifSx7InBhcmFtcyI6WyIiLCJzZW5kZXIwNSIsMTUwMDAwMDAwXSwibmFtZSI6IlRSQU5TRkVSIiwibW9kdWxlIjp7Im5hbWVzcGFjZSI6bnVsbCwibmFtZSI6ImNvaW4ifSwibW9kdWxlSGFzaCI6IjNpSUJRZEpuc3Q0NFoyWmdYb0hQa0FhdXliSjBoODVsX2VuX1NHSE5pYkUifSx7InBhcmFtcyI6WyIiLCJzZW5kZXIwNiIsMTYwMDAwMDAwXSwibmFtZSI6IlRSQU5TRkVSIiwibW9kdWxlIjp7Im5hbWVzcGFjZSI6bnVsbCwibmFtZSI6ImNvaW4ifSwibW9kdWxlSGFzaCI6IjNpSUJRZEpuc3Q0NFoyWmdYb0hQa0FhdXliSjBoODVsX2VuX1NHSE5pYkUifSx7InBhcmFtcyI6WyIiLCJzZW5kZXIwNyIsMTcwMDAwMDAwXSwibmFtZSI6IlRSQU5TRkVSIiwibW9kdWxlIjp7Im5hbWVzcGFjZSI6bnVsbCwibmFtZSI6ImNvaW4ifSwibW9kdWxlSGFzaCI6IjNpSUJRZEpuc3Q0NFoyWmdYb0hQa0FhdXliSjBoODVsX2VuX1NHSE5pYkUifSx7InBhcmFtcyI6WyIiLCJzZW5kZXIwOCIsMTgwMDAwMDAwXSwibmFtZSI6IlRSQU5TRkVSIiwibW9kdWxlIjp7Im5hbWVzcGFjZSI6bnVsbCwibmFtZSI6ImNvaW4ifSwibW9kdWxlSGFzaCI6IjNpSUJRZEpuc3Q0NFoyWmdYb0hQa0FhdXliSjBoODVsX2VuX1NHSE5pYkUifSx7InBhcmFtcyI6WyIiLCJzZW5kZXIwOSIsMTkwMDAwMDAwXSwibmFtZSI6IlRSQU5TRkVSIiwibW9kdWxlIjp7Im5hbWVzcGFjZSI6bnVsbCwibmFtZSI6ImNvaW4ifSwibW9kdWxlSGFzaCI6IjNpSUJRZEpuc3Q0NFoyWmdYb0hQa0FhdXliSjBoODVsX2VuX1NHSE5pYkUifSx7InBhcmFtcyI6WyIiLCJtdWx0aS0wMC0wMSIsMTAxMDAwMDAwXSwibmFtZSI6IlRSQU5TRkVSIiwibW9kdWxlIjp7Im5hbWVzcGFjZSI6bnVsbCwibmFtZSI6ImNvaW4ifSwibW9kdWxlSGFzaCI6IjNpSUJRZEpuc3Q0NFoyWmdYb0hQa0FhdXliSjBoODVsX2VuX1NHSE5pYkUifSx7InBhcmFtcyI6WyIiLCJtdWx0aS0wMi0wMy0wNC1hbnkiLDEyMzQwMDAwMF0sIm5hbWUiOiJUUkFOU0ZFUiIsIm1vZHVsZSI6eyJuYW1lc3BhY2UiOm51bGwsIm5hbWUiOiJjb2luIn0sIm1vZHVsZUhhc2giOiIzaUlCUWRKbnN0NDRaMlpnWG9IUGtBYXV5YkowaDg1bF9lbl9TR0hOaWJFIn0seyJwYXJhbXMiOlsiIiwiZTdmNzYzNGU5MjU1NDFmMzY4YjgyN2FkNWM3MjQyMTkwNTEwMGY2MjA1Mjg1YTc4YzE5ZDdiNGEzODcxMTgwNSIsMTUwXSwibmFtZSI6IlRSQU5TRkVSIiwibW9kdWxlIjp7Im5hbWVzcGFjZSI6bnVsbCwibmFtZSI6ImNvaW4ifSwibW9kdWxlSGFzaCI6IjNpSUJRZEpuc3Q0NFoyWmdYb0hQa0FhdXliSjBoODVsX2VuX1NHSE5pYkUifV0sIm1ldGFEYXRhIjpudWxsLCJjb250aW51YXRpb24iOm51bGwsInR4SWQiOjh9") + , (unsafeFromText "eyJoYXNoIjoibWd3Z3lCdTRGS3NEQ042Q3dWOEJNcFdNcnBwb2UtVkJKYTFYRjktLTFQRSIsInNpZ3MiOltdLCJjbWQiOiJ7XCJuZXR3b3JrSWRcIjpudWxsLFwicGF5bG9hZFwiOntcImV4ZWNcIjp7XCJkYXRhXCI6e1wic2VuZGVyMDdcIjpbXCI0YzMxZGM5ZWU3ZjI0MTc3Zjc4YjZmNTE4MDEyYTIwODMyNmUyYWYxZjM3YmIwYTI0MDViNTA1NmQwY2FkNjI4XCJdLFwic2VuZGVyMDFcIjpbXCI2YmUyZjQ4NWE3YWY3NWZlZGI0YjdmMTUzYTkwM2Y3ZTYwMDBjYTRhYTUwMTE3OWM5MWEyNDUwYjc3N2JkMmE3XCJdLFwic2VuZGVyMDZcIjpbXCI1ZmZjMWY3ZmVmN2E0NDczODYyNTc2MmY3NWE0MjI5NDU0OTUxZTAzZjJhZmM2ZjgxMzA5YzBjMWJkZjllZTZmXCJdLFwic2VuZGVyMDBcIjpbXCIzNjg4MjBmODBjMzI0YmJjN2MyYjA2MTA2ODhhN2RhNDNlMzlmOTFkMTE4NzMyNjcxY2Q5Yzc1MDBmZjQzY2NhXCJdLFwiZTdmN1wiOltcImU3Zjc2MzRlOTI1NTQxZjM2OGI4MjdhZDVjNzI0MjE5MDUxMDBmNjIwNTI4NWE3OGMxOWQ3YjRhMzg3MTE4MDVcIl0sXCJzZW5kZXIwNVwiOltcImYwOWQ4ZjYzOTRhZWE0MjVmZTY3ODNkODhjZDgxMzYzZDgwMTdmMTZhZmQzNzExYzU3NWJlMGY1Y2Q1YzliYjlcIl0sXCJzZW5kZXIwNFwiOltcIjJkNzBhYTRmNjk3YzNhM2I4ZGQ2ZDk3NzQ1YWMwNzRlZGNmZDBlYjY1YzM3Nzc0Y2RlMjUxMzU0ODNiZWE3MWVcIl0sXCJtdWx0aS0wMi0wMy0wNC1hbnlcIjp7XCJwcmVkXCI6XCJrZXlzLWFueVwiLFwia2V5c1wiOltcIjJkNzBhYTRmNjk3YzNhM2I4ZGQ2ZDk3NzQ1YWMwNzRlZGNmZDBlYjY1YzM3Nzc0Y2RlMjUxMzU0ODNiZWE3MWVcIixcIjNhOWRkNTMyZDczZGFjZTE5NWRiYjY0ZDFkYmE2NTcyZmI3ODNkMGZkZDMyNDY4NWUzMmZiZGEyZjg5Zjk5YTZcIixcIjQzZjJhZGIxZGUxOTIwMDBjYjM3NzdiYWNjN2Y5ODNiNjYxNGZkOWMxNzE1Y2Q0NGNkNDg0YjZkM2EwZDM0YzhcIl19LFwic2VuZGVyMDlcIjpbXCJjNTlkOTg0MGIwYjY2MDkwODM2NTQ2YjdlYjRhNzM2MDYyNTc1MjdlYzhjMmI0ODIzMDBmZDIyOTI2NGIwN2U2XCJdLFwic2VuZGVyMDNcIjpbXCI0M2YyYWRiMWRlMTkyMDAwY2IzNzc3YmFjYzdmOTgzYjY2MTRmZDljMTcxNWNkNDRjZDQ4NGI2ZDNhMGQzNGM4XCJdLFwibXVsdGktMDAtMDFcIjpbXCIzNjg4MjBmODBjMzI0YmJjN2MyYjA2MTA2ODhhN2RhNDNlMzlmOTFkMTE4NzMyNjcxY2Q5Yzc1MDBmZjQzY2NhXCIsXCI2YmUyZjQ4NWE3YWY3NWZlZGI0YjdmMTUzYTkwM2Y3ZTYwMDBjYTRhYTUwMTE3OWM5MWEyNDUwYjc3N2JkMmE3XCJdLFwic2VuZGVyMDhcIjpbXCI2M2IyZWJhNGVkNzBkNDYxMmQzZTdiYzkwZGIyZmJmNGM3NmY3YjA3NDM2M2U4NmQ3M2YwYmM2MTdmOGU4YjgxXCJdLFwic2VuZGVyMDJcIjpbXCIzYTlkZDUzMmQ3M2RhY2UxOTVkYmI2NGQxZGJhNjU3MmZiNzgzZDBmZGQzMjQ2ODVlMzJmYmRhMmY4OWY5OWE2XCJdfSxcImNvZGVcIjpcIihjb2luLmNvaW5iYXNlIFxcXCJzZW5kZXIwMFxcXCIgKHJlYWQta2V5c2V0IFxcXCJzZW5kZXIwMFxcXCIpIDEwMDAwMDAwMC4wKVxcbihjb2luLmNvaW5iYXNlIFxcXCJzZW5kZXIwMVxcXCIgKHJlYWQta2V5c2V0IFxcXCJzZW5kZXIwMVxcXCIpIDExMDAwMDAwMC4wKVxcbihjb2luLmNvaW5iYXNlIFxcXCJzZW5kZXIwMlxcXCIgKHJlYWQta2V5c2V0IFxcXCJzZW5kZXIwMlxcXCIpIDEyMDAwMDAwMC4wKVxcbihjb2luLmNvaW5iYXNlIFxcXCJzZW5kZXIwM1xcXCIgKHJlYWQta2V5c2V0IFxcXCJzZW5kZXIwM1xcXCIpIDEzMDAwMDAwMC4wKVxcbihjb2luLmNvaW5iYXNlIFxcXCJzZW5kZXIwNFxcXCIgKHJlYWQta2V5c2V0IFxcXCJzZW5kZXIwNFxcXCIpIDE0MDAwMDAwMC4wKVxcbihjb2luLmNvaW5iYXNlIFxcXCJzZW5kZXIwNVxcXCIgKHJlYWQta2V5c2V0IFxcXCJzZW5kZXIwNVxcXCIpIDE1MDAwMDAwMC4wKVxcbihjb2luLmNvaW5iYXNlIFxcXCJzZW5kZXIwNlxcXCIgKHJlYWQta2V5c2V0IFxcXCJzZW5kZXIwNlxcXCIpIDE2MDAwMDAwMC4wKVxcbihjb2luLmNvaW5iYXNlIFxcXCJzZW5kZXIwN1xcXCIgKHJlYWQta2V5c2V0IFxcXCJzZW5kZXIwN1xcXCIpIDE3MDAwMDAwMC4wKVxcbihjb2luLmNvaW5iYXNlIFxcXCJzZW5kZXIwOFxcXCIgKHJlYWQta2V5c2V0IFxcXCJzZW5kZXIwOFxcXCIpIDE4MDAwMDAwMC4wKVxcbihjb2luLmNvaW5iYXNlIFxcXCJzZW5kZXIwOVxcXCIgKHJlYWQta2V5c2V0IFxcXCJzZW5kZXIwOVxcXCIpIDE5MDAwMDAwMC4wKVxcbihjb2luLmNvaW5iYXNlIFxcXCJtdWx0aS0wMC0wMVxcXCIgKHJlYWQta2V5c2V0IFxcXCJtdWx0aS0wMC0wMVxcXCIpIDEwMTAwMDAwMC4wKVxcbihjb2luLmNvaW5iYXNlIFxcXCJtdWx0aS0wMi0wMy0wNC1hbnlcXFwiIChyZWFkLWtleXNldCBcXFwibXVsdGktMDItMDMtMDQtYW55XFxcIikgMTIzNDAwMDAwLjApXFxuXFxuKGNvaW4uY29pbmJhc2UgXFxcImU3Zjc2MzRlOTI1NTQxZjM2OGI4MjdhZDVjNzI0MjE5MDUxMDBmNjIwNTI4NWE3OGMxOWQ3YjRhMzg3MTE4MDVcXFwiIChyZWFkLWtleXNldCBcXFwiZTdmN1xcXCIpIDE1MC4wKVwifX0sXCJzaWduZXJzXCI6W10sXCJtZXRhXCI6e1wiY3JlYXRpb25UaW1lXCI6MCxcInR0bFwiOjE3MjgwMCxcImdhc0xpbWl0XCI6MCxcImNoYWluSWRcIjpcIlwiLFwiZ2FzUHJpY2VcIjowLFwic2VuZGVyXCI6XCJcIn0sXCJub25jZVwiOlwiZGV2bmV0LWdyYW50c05cIn0ifQ", unsafeFromText "eyJnYXMiOjAsInJlc3VsdCI6eyJzdGF0dXMiOiJzdWNjZXNzIiwiZGF0YSI6IldyaXRlIHN1Y2NlZWRlZCJ9LCJyZXFLZXkiOiJtZ3dneUJ1NEZLc0RDTjZDd1Y4Qk1wV01ycHBvZS1WQkphMVhGOS0tMVBFIiwibG9ncyI6IkF3MTVuVFF0YmlQYlVCQm1reGpRV09JZlc3ZHNfUi1sWjhNMGZDMXAxZHciLCJldmVudHMiOlt7InBhcmFtcyI6WyIiLCJzZW5kZXIwMCIsMTAwMDAwMDAwXSwibmFtZSI6IlRSQU5TRkVSIiwibW9kdWxlIjp7Im5hbWVzcGFjZSI6bnVsbCwibmFtZSI6ImNvaW4ifSwibW9kdWxlSGFzaCI6IjNpSUJRZEpuc3Q0NFoyWmdYb0hQa0FhdXliSjBoODVsX2VuX1NHSE5pYkUifSx7InBhcmFtcyI6WyIiLCJzZW5kZXIwMSIsMTEwMDAwMDAwXSwibmFtZSI6IlRSQU5TRkVSIiwibW9kdWxlIjp7Im5hbWVzcGFjZSI6bnVsbCwibmFtZSI6ImNvaW4ifSwibW9kdWxlSGFzaCI6IjNpSUJRZEpuc3Q0NFoyWmdYb0hQa0FhdXliSjBoODVsX2VuX1NHSE5pYkUifSx7InBhcmFtcyI6WyIiLCJzZW5kZXIwMiIsMTIwMDAwMDAwXSwibmFtZSI6IlRSQU5TRkVSIiwibW9kdWxlIjp7Im5hbWVzcGFjZSI6bnVsbCwibmFtZSI6ImNvaW4ifSwibW9kdWxlSGFzaCI6IjNpSUJRZEpuc3Q0NFoyWmdYb0hQa0FhdXliSjBoODVsX2VuX1NHSE5pYkUifSx7InBhcmFtcyI6WyIiLCJzZW5kZXIwMyIsMTMwMDAwMDAwXSwibmFtZSI6IlRSQU5TRkVSIiwibW9kdWxlIjp7Im5hbWVzcGFjZSI6bnVsbCwibmFtZSI6ImNvaW4ifSwibW9kdWxlSGFzaCI6IjNpSUJRZEpuc3Q0NFoyWmdYb0hQa0FhdXliSjBoODVsX2VuX1NHSE5pYkUifSx7InBhcmFtcyI6WyIiLCJzZW5kZXIwNCIsMTQwMDAwMDAwXSwibmFtZSI6IlRSQU5TRkVSIiwibW9kdWxlIjp7Im5hbWVzcGFjZSI6bnVsbCwibmFtZSI6ImNvaW4ifSwibW9kdWxlSGFzaCI6IjNpSUJRZEpuc3Q0NFoyWmdYb0hQa0FhdXliSjBoODVsX2VuX1NHSE5pYkUifSx7InBhcmFtcyI6WyIiLCJzZW5kZXIwNSIsMTUwMDAwMDAwXSwibmFtZSI6IlRSQU5TRkVSIiwibW9kdWxlIjp7Im5hbWVzcGFjZSI6bnVsbCwibmFtZSI6ImNvaW4ifSwibW9kdWxlSGFzaCI6IjNpSUJRZEpuc3Q0NFoyWmdYb0hQa0FhdXliSjBoODVsX2VuX1NHSE5pYkUifSx7InBhcmFtcyI6WyIiLCJzZW5kZXIwNiIsMTYwMDAwMDAwXSwibmFtZSI6IlRSQU5TRkVSIiwibW9kdWxlIjp7Im5hbWVzcGFjZSI6bnVsbCwibmFtZSI6ImNvaW4ifSwibW9kdWxlSGFzaCI6IjNpSUJRZEpuc3Q0NFoyWmdYb0hQa0FhdXliSjBoODVsX2VuX1NHSE5pYkUifSx7InBhcmFtcyI6WyIiLCJzZW5kZXIwNyIsMTcwMDAwMDAwXSwibmFtZSI6IlRSQU5TRkVSIiwibW9kdWxlIjp7Im5hbWVzcGFjZSI6bnVsbCwibmFtZSI6ImNvaW4ifSwibW9kdWxlSGFzaCI6IjNpSUJRZEpuc3Q0NFoyWmdYb0hQa0FhdXliSjBoODVsX2VuX1NHSE5pYkUifSx7InBhcmFtcyI6WyIiLCJzZW5kZXIwOCIsMTgwMDAwMDAwXSwibmFtZSI6IlRSQU5TRkVSIiwibW9kdWxlIjp7Im5hbWVzcGFjZSI6bnVsbCwibmFtZSI6ImNvaW4ifSwibW9kdWxlSGFzaCI6IjNpSUJRZEpuc3Q0NFoyWmdYb0hQa0FhdXliSjBoODVsX2VuX1NHSE5pYkUifSx7InBhcmFtcyI6WyIiLCJzZW5kZXIwOSIsMTkwMDAwMDAwXSwibmFtZSI6IlRSQU5TRkVSIiwibW9kdWxlIjp7Im5hbWVzcGFjZSI6bnVsbCwibmFtZSI6ImNvaW4ifSwibW9kdWxlSGFzaCI6IjNpSUJRZEpuc3Q0NFoyWmdYb0hQa0FhdXliSjBoODVsX2VuX1NHSE5pYkUifSx7InBhcmFtcyI6WyIiLCJtdWx0aS0wMC0wMSIsMTAxMDAwMDAwXSwibmFtZSI6IlRSQU5TRkVSIiwibW9kdWxlIjp7Im5hbWVzcGFjZSI6bnVsbCwibmFtZSI6ImNvaW4ifSwibW9kdWxlSGFzaCI6IjNpSUJRZEpuc3Q0NFoyWmdYb0hQa0FhdXliSjBoODVsX2VuX1NHSE5pYkUifSx7InBhcmFtcyI6WyIiLCJtdWx0aS0wMi0wMy0wNC1hbnkiLDEyMzQwMDAwMF0sIm5hbWUiOiJUUkFOU0ZFUiIsIm1vZHVsZSI6eyJuYW1lc3BhY2UiOm51bGwsIm5hbWUiOiJjb2luIn0sIm1vZHVsZUhhc2giOiIzaUlCUWRKbnN0NDRaMlpnWG9IUGtBYXV5YkowaDg1bF9lbl9TR0hOaWJFIn0seyJwYXJhbXMiOlsiIiwiZTdmNzYzNGU5MjU1NDFmMzY4YjgyN2FkNWM3MjQyMTkwNTEwMGY2MjA1Mjg1YTc4YzE5ZDdiNGEzODcxMTgwNSIsMTUwXSwibmFtZSI6IlRSQU5TRkVSIiwibW9kdWxlIjp7Im5hbWVzcGFjZSI6bnVsbCwibmFtZSI6ImNvaW4ifSwibW9kdWxlSGFzaCI6IjNpSUJRZEpuc3Q0NFoyWmdYb0hQa0FhdXliSjBoODVsX2VuX1NHSE5pYkUifV0sIm1ldGFEYXRhIjpudWxsLCJjb250aW51YXRpb24iOm51bGwsInR4SWQiOjh9") ] diff --git a/src/Chainweb/BlockHeader/Genesis/FastTimedCPM0Payload.hs b/src/Chainweb/BlockHeader/Genesis/FastTimedCPM0Payload.hs index 9efcf84a89..34f5267383 100644 --- a/src/Chainweb/BlockHeader/Genesis/FastTimedCPM0Payload.hs +++ b/src/Chainweb/BlockHeader/Genesis/FastTimedCPM0Payload.hs @@ -8,7 +8,7 @@ import qualified Data.Text as T import qualified Data.Vector as V import GHC.Stack -import Chainweb.Payload +import Chainweb.Pact.Payload import Chainweb.Utils (unsafeFromText, toText) payloadBlock :: HasCallStack => PayloadWithOutputs diff --git a/src/Chainweb/BlockHeader/Genesis/FastTimedCPM1to9Payload.hs b/src/Chainweb/BlockHeader/Genesis/FastTimedCPM1to9Payload.hs index e2c81a7ec4..71bb47c927 100644 --- a/src/Chainweb/BlockHeader/Genesis/FastTimedCPM1to9Payload.hs +++ b/src/Chainweb/BlockHeader/Genesis/FastTimedCPM1to9Payload.hs @@ -8,7 +8,7 @@ import qualified Data.Text as T import qualified Data.Vector as V import GHC.Stack -import Chainweb.Payload +import Chainweb.Pact.Payload import Chainweb.Utils (unsafeFromText, toText) payloadBlock :: HasCallStack => PayloadWithOutputs diff --git a/src/Chainweb/BlockHeader/Genesis/InstantTimedCPM0Payload.hs b/src/Chainweb/BlockHeader/Genesis/InstantTimedCPM0Payload.hs index a1e1262079..b92ada0a8b 100644 --- a/src/Chainweb/BlockHeader/Genesis/InstantTimedCPM0Payload.hs +++ b/src/Chainweb/BlockHeader/Genesis/InstantTimedCPM0Payload.hs @@ -8,7 +8,7 @@ import qualified Data.Text as T import qualified Data.Vector as V import GHC.Stack -import Chainweb.Payload +import Chainweb.Pact.Payload import Chainweb.Utils (unsafeFromText, toText) payloadBlock :: HasCallStack => PayloadWithOutputs @@ -21,19 +21,19 @@ payloadBlock where actualHash, expectedHash :: BlockPayloadHash actualHash = _payloadWithOutputsPayloadHash payload - expectedHash = unsafeFromText "QzxVHFZ5go4PYd3QeAZhxP61hsVnICPw4BB9h-T3PDM" + expectedHash = unsafeFromText "1I4CRQ2BGFZEFr7_X_U1hMPPZI4YMbfxEr6cyrRYlsA" payload = newPayloadWithOutputs minerData coinbase txs minerData = unsafeFromText "eyJhY2NvdW50IjoiTm9NaW5lciIsInByZWRpY2F0ZSI6IjwiLCJwdWJsaWMta2V5cyI6W119" coinbase = unsafeFromText "eyJnYXMiOjAsInJlc3VsdCI6eyJzdGF0dXMiOiJzdWNjZXNzIiwiZGF0YSI6Ik5PX0NPSU5CQVNFIn0sInJlcUtleSI6IkRsZFJ3Q2JsUTdMb3F5NndZSm5hb2RIbDMwZDNqM2VILXF0RnpmRXY0NmciLCJsb2dzIjpudWxsLCJtZXRhRGF0YSI6bnVsbCwiY29udGludWF0aW9uIjpudWxsLCJ0eElkIjpudWxsfQ" txs = V.fromList - [ (unsafeFromText "eyJoYXNoIjoiNDhUMExqQW5TRnBGV3h2dmFQVi1fNkUtQ2pEQVBoV1lVRldidnlmMmxGcyIsInNpZ3MiOltdLCJjbWQiOiJ7XCJuZXR3b3JrSWRcIjpudWxsLFwicGF5bG9hZFwiOntcImV4ZWNcIjp7XCJkYXRhXCI6bnVsbCxcImNvZGVcIjpcIihpbnRlcmZhY2UgZnVuZ2libGUtdjFcXG5cXG4gIFxcXCIgU3RhbmRhcmQgZm9yIGZ1bmdpYmxlIGNvaW5zIGFuZCB0b2tlbnMgYXMgc3BlY2lmaWVkIGluIEtJUC0wMDAyLiBcXFwiXFxuXFxuICAgOyAtLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tXFxuICAgOyBTY2hlbWFcXG5cXG4gICAoZGVmc2NoZW1hIGFjY291bnQtZGV0YWlsc1xcbiAgICBAZG9jIFxcXCJTY2hlbWEgZm9yIHJlc3VsdHMgb2YgJ2FjY291bnQnIG9wZXJhdGlvbi5cXFwiXFxuICAgIEBtb2RlbCBbIChpbnZhcmlhbnQgKCE9IFxcXCJcXFwiIHNlbmRlcikpIF1cXG5cXG4gICAgYWNjb3VudDpzdHJpbmdcXG4gICAgYmFsYW5jZTpkZWNpbWFsXFxuICAgIGd1YXJkOmd1YXJkKVxcblxcblxcbiAgIDsgLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLVxcbiAgIDsgQ2Fwc1xcblxcbiAgIChkZWZjYXAgVFJBTlNGRVI6Ym9vbFxcbiAgICAgKCBzZW5kZXI6c3RyaW5nXFxuICAgICAgIHJlY2VpdmVyOnN0cmluZ1xcbiAgICAgICBhbW91bnQ6ZGVjaW1hbFxcbiAgICAgKVxcbiAgICAgQGRvYyBcXFwiIE1hbmFnZWQgY2FwYWJpbGl0eSBzZWFsaW5nIEFNT1VOVCBmb3IgdHJhbnNmZXIgZnJvbSBTRU5ERVIgdG8gXFxcXFxcbiAgICAgICAgICBcXFxcIFJFQ0VJVkVSLiBQZXJtaXRzIGFueSBudW1iZXIgb2YgdHJhbnNmZXJzIHVwIHRvIEFNT1VOVC5cXFwiXFxuICAgICBAbWFuYWdlZCBhbW91bnQgVFJBTlNGRVItbWdyXFxuICAgICApXFxuXFxuICAgKGRlZnVuIFRSQU5TRkVSLW1ncjpkZWNpbWFsXFxuICAgICAoIG1hbmFnZWQ6ZGVjaW1hbFxcbiAgICAgICByZXF1ZXN0ZWQ6ZGVjaW1hbFxcbiAgICAgKVxcbiAgICAgQGRvYyBcXFwiIE1hbmFnZXMgVFJBTlNGRVIgQU1PVU5UIGxpbmVhcmx5LCBcXFxcXFxuICAgICAgICAgIFxcXFwgc3VjaCB0aGF0IGEgcmVxdWVzdCBmb3IgMS4wIGFtb3VudCBvbiBhIDMuMCBcXFxcXFxuICAgICAgICAgIFxcXFwgbWFuYWdlZCBxdWFudGl0eSBlbWl0cyB1cGRhdGVkIGFtb3VudCAyLjAuXFxcIlxcbiAgICAgKVxcblxcbiAgIDsgLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLVxcbiAgIDsgRnVuY3Rpb25hbGl0eVxcblxcbiAgIChkZWZ1biB0cmFuc2Zlci1jcmVhdGU6c3RyaW5nXFxuICAgICAoIHNlbmRlcjpzdHJpbmdcXG4gICAgICAgcmVjZWl2ZXI6c3RyaW5nXFxuICAgICAgIHJlY2VpdmVyLWd1YXJkOmd1YXJkXFxuICAgICAgIGFtb3VudDpkZWNpbWFsXFxuICAgICApXFxuICAgICBAZG9jIFxcXCIgVHJhbnNmZXIgQU1PVU5UIGJldHdlZW4gYWNjb3VudHMgU0VOREVSIGFuZCBSRUNFSVZFUi4gXFxcXFxcbiAgICAgICAgICBcXFxcIEZhaWxzIGlmIFNFTkRFUiBkb2VzIG5vdCBleGlzdC4gSWYgUkVDRUlWRVIgZXhpc3RzLCBndWFyZCBcXFxcXFxuICAgICAgICAgIFxcXFwgbXVzdCBtYXRjaCBleGlzdGluZyB2YWx1ZS4gSWYgUkVDRUlWRVIgZG9lcyBub3QgZXhpc3QsIFxcXFxcXG4gICAgICAgICAgXFxcXCBSRUNFSVZFUiBhY2NvdW50IGlzIGNyZWF0ZWQgdXNpbmcgUkVDRUlWRVItR1VBUkQuIFxcXFxcXG4gICAgICAgICAgXFxcXCBTdWJqZWN0IHRvIG1hbmFnZW1lbnQgYnkgVFJBTlNGRVIgY2FwYWJpbGl0eS5cXFwiXFxuICAgICBAbW9kZWwgWyAocHJvcGVydHkgKD4gYW1vdW50IDAuMCkpXFxuICAgICAgICAgICAgICAocHJvcGVydHkgKCE9IHNlbmRlciBcXFwiXFxcIikpXFxuICAgICAgICAgICAgICAocHJvcGVydHkgKCE9IHJlY2VpdmVyIFxcXCJcXFwiKSlcXG4gICAgICAgICAgICAgIChwcm9wZXJ0eSAoIT0gc2VuZGVyIHJlY2VpdmVyKSlcXG4gICAgICAgICAgICBdXFxuICAgICApXFxuXFxuICAgKGRlZnBhY3QgdHJhbnNmZXItY3Jvc3NjaGFpbjpzdHJpbmdcXG4gICAgICggc2VuZGVyOnN0cmluZ1xcbiAgICAgICByZWNlaXZlcjpzdHJpbmdcXG4gICAgICAgcmVjZWl2ZXItZ3VhcmQ6Z3VhcmRcXG4gICAgICAgdGFyZ2V0LWNoYWluOnN0cmluZ1xcbiAgICAgICBhbW91bnQ6ZGVjaW1hbFxcbiAgICAgKVxcbiAgICAgQGRvYyBcXFwiIDItc3RlcCBwYWN0IHRvIHRyYW5zZmVyIEFNT1VOVCBmcm9tIFNFTkRFUiBvbiBjdXJyZW50IGNoYWluIFxcXFxcXG4gICAgICAgICAgXFxcXCB0byBSRUNFSVZFUiBvbiBUQVJHRVQtQ0hBSU4gdmlhIFNQViBwcm9vZi4gXFxcXFxcbiAgICAgICAgICBcXFxcIFRBUkdFVC1DSEFJTiBtdXN0IGJlIGRpZmZlcmVudCB0aGFuIGN1cnJlbnQgY2hhaW4gaWQuIFxcXFxcXG4gICAgICAgICAgXFxcXCBGaXJzdCBzdGVwIGRlYml0cyBBTU9VTlQgY29pbnMgaW4gU0VOREVSIGFjY291bnQgYW5kIHlpZWxkcyBcXFxcXFxuICAgICAgICAgIFxcXFwgUkVDRUlWRVIsIFJFQ0VJVkVSX0dVQVJEIGFuZCBBTU9VTlQgdG8gVEFSR0VULUNIQUlOLiBcXFxcXFxuICAgICAgICAgIFxcXFwgU2Vjb25kIHN0ZXAgY29udGludWF0aW9uIGlzIHNlbnQgaW50byBUQVJHRVQtQ0hBSU4gd2l0aCBwcm9vZiBcXFxcXFxuICAgICAgICAgIFxcXFwgb2J0YWluZWQgZnJvbSB0aGUgc3B2ICdvdXRwdXQnIGVuZHBvaW50IG9mIENoYWlud2ViLiBcXFxcXFxuICAgICAgICAgIFxcXFwgUHJvb2YgaXMgdmFsaWRhdGVkIGFuZCBSRUNFSVZFUiBpcyBjcmVkaXRlZCB3aXRoIEFNT1VOVCBcXFxcXFxuICAgICAgICAgIFxcXFwgY3JlYXRpbmcgYWNjb3VudCB3aXRoIFJFQ0VJVkVSX0dVQVJEIGFzIG5lY2Vzc2FyeS5cXFwiXFxuICAgICBAbW9kZWwgWyAocHJvcGVydHkgKD4gYW1vdW50IDAuMCkpXFxuICAgICAgICAgICAgICAocHJvcGVydHkgKCE9IHNlbmRlciBcXFwiXFxcIikpXFxuICAgICAgICAgICAgICAocHJvcGVydHkgKCE9IHJlY2VpdmVyIFxcXCJcXFwiKSlcXG4gICAgICAgICAgICAgIChwcm9wZXJ0eSAoIT0gc2VuZGVyIHJlY2VpdmVyKSlcXG4gICAgICAgICAgICAgIChwcm9wZXJ0eSAoIT0gdGFyZ2V0LWNoYWluIFxcXCJcXFwiKSlcXG4gICAgICAgICAgICBdXFxuICAgICApXFxuXFxuICAgKGRlZnVuIGdldC1iYWxhbmNlOmRlY2ltYWxcXG4gICAgICggYWNjb3VudDpzdHJpbmcgKVxcbiAgICAgXFxcIiBHZXQgYmFsYW5jZSBmb3IgQUNDT1VOVC4gRmFpbHMgaWYgYWNjb3VudCBkb2VzIG5vdCBleGlzdC5cXFwiXFxuICAgICApXFxuXFxuICAgKGRlZnVuIGRldGFpbHM6b2JqZWN0e2FjY291bnQtZGV0YWlsc31cXG4gICAgICggYWNjb3VudDogc3RyaW5nIClcXG4gICAgIFxcXCIgR2V0IGFuIG9iamVjdCB3aXRoIGRldGFpbHMgb2YgQUNDT1VOVC4gXFxcXFxcbiAgICAgXFxcXCBGYWlscyBpZiBhY2NvdW50IGRvZXMgbm90IGV4aXN0LlxcXCJcXG4gICAgIClcXG5cXG4gICAoZGVmdW4gcHJlY2lzaW9uOmludGVnZXJcXG4gICAgICgpXFxuICAgICBcXFwiUmV0dXJuIHRoZSBtYXhpbXVtIGFsbG93ZWQgZGVjaW1hbCBwcmVjaXNpb24uXFxcIlxcbiAgICAgKVxcblxcbiAgIChkZWZ1biBlbmZvcmNlLXVuaXQ6Ym9vbFxcbiAgICAgKCBhbW91bnQ6ZGVjaW1hbCApXFxuICAgICBcXFwiIEVuZm9yY2UgbWluaW11bSBwcmVjaXNpb24gYWxsb3dlZCBmb3IgdHJhbnNhY3Rpb25zLlxcXCJcXG4gICAgIClcXG5cXG4gICAoZGVmdW4gY3JlYXRlLWFjY291bnQ6c3RyaW5nXFxuICAgICAoIGFjY291bnQ6c3RyaW5nXFxuICAgICAgIGd1YXJkOmd1YXJkXFxuICAgICApXFxuICAgICBcXFwiIENyZWF0ZSBBQ0NPVU5UIHdpdGggMC4wIGJhbGFuY2UsIHdpdGggR1VBUkQgY29udHJvbGxpbmcgYWNjZXNzLlxcXCJcXG4gICAgIClcXG5cXG4gICAoZGVmdW4gcm90YXRlOnN0cmluZ1xcbiAgICAgKCBhY2NvdW50OnN0cmluZ1xcbiAgICAgICBuZXctZ3VhcmQ6Z3VhcmRcXG4gICAgIClcXG4gICAgIFxcXCIgUm90YXRlIGd1YXJkIGZvciBBQ0NPVU5ULiBUcmFuc2FjdGlvbiBpcyB2YWxpZGF0ZWQgYWdhaW5zdCBcXFxcXFxuICAgICBcXFxcIGV4aXN0aW5nIGd1YXJkIGJlZm9yZSBpbnN0YWxsaW5nIG5ldyBndWFyZC4gXFxcIlxcbiAgICAgKVxcblxcbilcXG5cIn19LFwic2lnbmVyc1wiOltdLFwibWV0YVwiOntcImNyZWF0aW9uVGltZVwiOjAsXCJ0dGxcIjoxNzI4MDAsXCJnYXNMaW1pdFwiOjAsXCJjaGFpbklkXCI6XCJcIixcImdhc1ByaWNlXCI6MCxcInNlbmRlclwiOlwiXCJ9LFwibm9uY2VcIjpcImdlbmVzaXMtMDFcIn0ifQ", unsafeFromText "eyJnYXMiOjAsInJlc3VsdCI6eyJzdGF0dXMiOiJzdWNjZXNzIiwiZGF0YSI6IkxvYWRlZCBpbnRlcmZhY2UgZnVuZ2libGUtdjEifSwicmVxS2V5IjoiNDhUMExqQW5TRnBGV3h2dmFQVi1fNkUtQ2pEQVBoV1lVRldidnlmMmxGcyIsImxvZ3MiOiJRRmEyOHRuOXkydFdMVzdUc3lHdzNOTkhpYzhxYjJ6UGtudXRpWWhnQXc4IiwibWV0YURhdGEiOm51bGwsImNvbnRpbnVhdGlvbiI6bnVsbCwidHhJZCI6MH0") - , (unsafeFromText "eyJoYXNoIjoieW5ucDFYVVNSTjJrMUYwYTZ2dXM3RFp0SDZjcHN6MVhmX0d3V0xnTFhTTSIsInNpZ3MiOltdLCJjbWQiOiJ7XCJuZXR3b3JrSWRcIjpudWxsLFwicGF5bG9hZFwiOntcImV4ZWNcIjp7XCJkYXRhXCI6bnVsbCxcImNvZGVcIjpcIihpbnRlcmZhY2UgZnVuZ2libGUteGNoYWluLXYxXFxuXFxuICBcXFwiIFRoaXMgaW50ZXJmYWNlIG9mZmVycyBhIHN0YW5kYXJkIGNhcGFiaWxpdHkgZm9yIGNyb3NzLWNoYWluIFxcXFxcXG4gIFxcXFwgdHJhbnNmZXJzIGFuZCBhc3NvY2lhdGVkIGV2ZW50cy4gXFxcIlxcblxcbiAgKGRlZmNhcCBUUkFOU0ZFUl9YQ0hBSU46Ym9vbFxcbiAgICAoIHNlbmRlcjpzdHJpbmdcXG4gICAgICByZWNlaXZlcjpzdHJpbmdcXG4gICAgICBhbW91bnQ6ZGVjaW1hbFxcbiAgICAgIHRhcmdldC1jaGFpbjpzdHJpbmdcXG4gICAgKVxcbiAgICBAZG9jIFxcXCIgTWFuYWdlZCBjYXBhYmlsaXR5IHNlYWxpbmcgQU1PVU5UIGZvciB0cmFuc2ZlciBcXFxcXFxuICAgICAgICAgXFxcXCBmcm9tIFNFTkRFUiB0byBSRUNFSVZFUiBvbiBUQVJHRVQtQ0hBSU4uIFBlcm1pdHMgXFxcXFxcbiAgICAgICAgIFxcXFwgYW55IG51bWJlciBvZiBjcm9zcy1jaGFpbiB0cmFuc2ZlcnMgdXAgdG8gQU1PVU5ULlxcXCJcXG5cXG4gICAgQG1hbmFnZWQgYW1vdW50IFRSQU5TRkVSX1hDSEFJTi1tZ3JcXG4gICAgKVxcblxcbiAgKGRlZnVuIFRSQU5TRkVSX1hDSEFJTi1tZ3I6ZGVjaW1hbFxcbiAgICAoIG1hbmFnZWQ6ZGVjaW1hbFxcbiAgICAgIHJlcXVlc3RlZDpkZWNpbWFsXFxuICAgIClcXG4gICAgQGRvYyBcXFwiIEFsbG93cyBUUkFOU0ZFUi1YQ0hBSU4gQU1PVU5UIHRvIGJlIGxlc3MgdGhhbiBvciBcXFxcXFxuICAgICAgICAgXFxcXCBlcXVhbCBtYW5hZ2VkIHF1YW50aXR5IGFzIGEgb25lLXNob3QsIHJldHVybmluZyAwLjAuXFxcIlxcbiAgKVxcblxcbiAgKGRlZmNhcCBUUkFOU0ZFUl9YQ0hBSU5fUkVDRDpib29sXFxuICAgICggc2VuZGVyOnN0cmluZ1xcbiAgICAgIHJlY2VpdmVyOnN0cmluZ1xcbiAgICAgIGFtb3VudDpkZWNpbWFsXFxuICAgICAgc291cmNlLWNoYWluOnN0cmluZ1xcbiAgICApXFxuICAgIEBkb2MgXFxcIkV2ZW50IGVtaXR0ZWQgb24gcmVjZWlwdCBvZiBjcm9zcy1jaGFpbiB0cmFuc2Zlci5cXFwiXFxuICAgIEBldmVudFxcbiAgKVxcbilcXG5cIn19LFwic2lnbmVyc1wiOltdLFwibWV0YVwiOntcImNyZWF0aW9uVGltZVwiOjAsXCJ0dGxcIjoxNzI4MDAsXCJnYXNMaW1pdFwiOjAsXCJjaGFpbklkXCI6XCJcIixcImdhc1ByaWNlXCI6MCxcInNlbmRlclwiOlwiXCJ9LFwibm9uY2VcIjpcImdlbmVzaXMteGNoYWluXCJ9In0", unsafeFromText "eyJnYXMiOjAsInJlc3VsdCI6eyJzdGF0dXMiOiJzdWNjZXNzIiwiZGF0YSI6IkxvYWRlZCBpbnRlcmZhY2UgZnVuZ2libGUteGNoYWluLXYxIn0sInJlcUtleSI6InlubnAxWFVTUk4yazFGMGE2dnVzN0RadEg2Y3BzejFYZl9Hd1dMZ0xYU00iLCJsb2dzIjoiVmRxMHp0SjBnRThOLTNkLW1tRmRRXzZ0ZGp0dnEtNXIwX050dXBvT1hpVSIsIm1ldGFEYXRhIjpudWxsLCJjb250aW51YXRpb24iOm51bGwsInR4SWQiOjF9") - , (unsafeFromText "eyJoYXNoIjoiMDVCdGo3ZUJaQlc3by1TYUxvVmhBaWNNVVBaVUJiRzZRVDhfTEFrQ3hIcyIsInNpZ3MiOltdLCJjbWQiOiJ7XCJuZXR3b3JrSWRcIjpudWxsLFwicGF5bG9hZFwiOntcImV4ZWNcIjp7XCJkYXRhXCI6bnVsbCxcImNvZGVcIjpcIihpbnRlcmZhY2UgZnVuZ2libGUtdjJcXG5cXG4gIFxcXCIgU3RhbmRhcmQgZm9yIGZ1bmdpYmxlIGNvaW5zIGFuZCB0b2tlbnMgYXMgc3BlY2lmaWVkIGluIEtJUC0wMDAyLiBcXFwiXFxuXFxuICAgOyAtLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tXFxuICAgOyBTY2hlbWFcXG5cXG4gICAoZGVmc2NoZW1hIGFjY291bnQtZGV0YWlsc1xcbiAgICBAZG9jIFxcXCJTY2hlbWEgZm9yIHJlc3VsdHMgb2YgJ2FjY291bnQnIG9wZXJhdGlvbi5cXFwiXFxuICAgIEBtb2RlbCBbIChpbnZhcmlhbnQgKCE9IFxcXCJcXFwiIHNlbmRlcikpIF1cXG5cXG4gICAgYWNjb3VudDpzdHJpbmdcXG4gICAgYmFsYW5jZTpkZWNpbWFsXFxuICAgIGd1YXJkOmd1YXJkKVxcblxcblxcbiAgIDsgLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLVxcbiAgIDsgQ2Fwc1xcblxcbiAgIChkZWZjYXAgVFJBTlNGRVI6Ym9vbFxcbiAgICAgKCBzZW5kZXI6c3RyaW5nXFxuICAgICAgIHJlY2VpdmVyOnN0cmluZ1xcbiAgICAgICBhbW91bnQ6ZGVjaW1hbFxcbiAgICAgKVxcbiAgICAgQGRvYyBcXFwiIE1hbmFnZWQgY2FwYWJpbGl0eSBzZWFsaW5nIEFNT1VOVCBmb3IgdHJhbnNmZXIgZnJvbSBTRU5ERVIgdG8gXFxcXFxcbiAgICAgICAgICBcXFxcIFJFQ0VJVkVSLiBQZXJtaXRzIGFueSBudW1iZXIgb2YgdHJhbnNmZXJzIHVwIHRvIEFNT1VOVC5cXFwiXFxuICAgICBAbWFuYWdlZCBhbW91bnQgVFJBTlNGRVItbWdyXFxuICAgICApXFxuXFxuICAgKGRlZnVuIFRSQU5TRkVSLW1ncjpkZWNpbWFsXFxuICAgICAoIG1hbmFnZWQ6ZGVjaW1hbFxcbiAgICAgICByZXF1ZXN0ZWQ6ZGVjaW1hbFxcbiAgICAgKVxcbiAgICAgQGRvYyBcXFwiIE1hbmFnZXMgVFJBTlNGRVIgQU1PVU5UIGxpbmVhcmx5LCBcXFxcXFxuICAgICAgICAgIFxcXFwgc3VjaCB0aGF0IGEgcmVxdWVzdCBmb3IgMS4wIGFtb3VudCBvbiBhIDMuMCBcXFxcXFxuICAgICAgICAgIFxcXFwgbWFuYWdlZCBxdWFudGl0eSBlbWl0cyB1cGRhdGVkIGFtb3VudCAyLjAuXFxcIlxcbiAgICAgKVxcblxcbiAgIDsgLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLVxcbiAgIDsgRnVuY3Rpb25hbGl0eVxcblxcblxcbiAgKGRlZnVuIHRyYW5zZmVyOnN0cmluZ1xcbiAgICAoIHNlbmRlcjpzdHJpbmdcXG4gICAgICByZWNlaXZlcjpzdHJpbmdcXG4gICAgICBhbW91bnQ6ZGVjaW1hbFxcbiAgICApXFxuICAgIEBkb2MgXFxcIiBUcmFuc2ZlciBBTU9VTlQgYmV0d2VlbiBhY2NvdW50cyBTRU5ERVIgYW5kIFJFQ0VJVkVSLiBcXFxcXFxuICAgICAgICAgXFxcXCBGYWlscyBpZiBlaXRoZXIgU0VOREVSIG9yIFJFQ0VJVkVSIGRvZXMgbm90IGV4aXN0LlxcXCJcXG4gICAgQG1vZGVsIFsgKHByb3BlcnR5ICg-IGFtb3VudCAwLjApKVxcbiAgICAgICAgICAgICAocHJvcGVydHkgKCE9IHNlbmRlciBcXFwiXFxcIikpXFxuICAgICAgICAgICAgIChwcm9wZXJ0eSAoIT0gcmVjZWl2ZXIgXFxcIlxcXCIpKVxcbiAgICAgICAgICAgICAocHJvcGVydHkgKCE9IHNlbmRlciByZWNlaXZlcikpXFxuICAgICAgICAgICBdXFxuICAgIClcXG5cXG4gICAoZGVmdW4gdHJhbnNmZXItY3JlYXRlOnN0cmluZ1xcbiAgICAgKCBzZW5kZXI6c3RyaW5nXFxuICAgICAgIHJlY2VpdmVyOnN0cmluZ1xcbiAgICAgICByZWNlaXZlci1ndWFyZDpndWFyZFxcbiAgICAgICBhbW91bnQ6ZGVjaW1hbFxcbiAgICAgKVxcbiAgICAgQGRvYyBcXFwiIFRyYW5zZmVyIEFNT1VOVCBiZXR3ZWVuIGFjY291bnRzIFNFTkRFUiBhbmQgUkVDRUlWRVIuIFxcXFxcXG4gICAgICAgICAgXFxcXCBGYWlscyBpZiBTRU5ERVIgZG9lcyBub3QgZXhpc3QuIElmIFJFQ0VJVkVSIGV4aXN0cywgZ3VhcmQgXFxcXFxcbiAgICAgICAgICBcXFxcIG11c3QgbWF0Y2ggZXhpc3RpbmcgdmFsdWUuIElmIFJFQ0VJVkVSIGRvZXMgbm90IGV4aXN0LCBcXFxcXFxuICAgICAgICAgIFxcXFwgUkVDRUlWRVIgYWNjb3VudCBpcyBjcmVhdGVkIHVzaW5nIFJFQ0VJVkVSLUdVQVJELiBcXFxcXFxuICAgICAgICAgIFxcXFwgU3ViamVjdCB0byBtYW5hZ2VtZW50IGJ5IFRSQU5TRkVSIGNhcGFiaWxpdHkuXFxcIlxcbiAgICAgQG1vZGVsIFsgKHByb3BlcnR5ICg-IGFtb3VudCAwLjApKVxcbiAgICAgICAgICAgICAgKHByb3BlcnR5ICghPSBzZW5kZXIgXFxcIlxcXCIpKVxcbiAgICAgICAgICAgICAgKHByb3BlcnR5ICghPSByZWNlaXZlciBcXFwiXFxcIikpXFxuICAgICAgICAgICAgICAocHJvcGVydHkgKCE9IHNlbmRlciByZWNlaXZlcikpXFxuICAgICAgICAgICAgXVxcbiAgICAgKVxcblxcbiAgIChkZWZwYWN0IHRyYW5zZmVyLWNyb3NzY2hhaW46c3RyaW5nXFxuICAgICAoIHNlbmRlcjpzdHJpbmdcXG4gICAgICAgcmVjZWl2ZXI6c3RyaW5nXFxuICAgICAgIHJlY2VpdmVyLWd1YXJkOmd1YXJkXFxuICAgICAgIHRhcmdldC1jaGFpbjpzdHJpbmdcXG4gICAgICAgYW1vdW50OmRlY2ltYWxcXG4gICAgIClcXG4gICAgIEBkb2MgXFxcIiAyLXN0ZXAgcGFjdCB0byB0cmFuc2ZlciBBTU9VTlQgZnJvbSBTRU5ERVIgb24gY3VycmVudCBjaGFpbiBcXFxcXFxuICAgICAgICAgIFxcXFwgdG8gUkVDRUlWRVIgb24gVEFSR0VULUNIQUlOIHZpYSBTUFYgcHJvb2YuIFxcXFxcXG4gICAgICAgICAgXFxcXCBUQVJHRVQtQ0hBSU4gbXVzdCBiZSBkaWZmZXJlbnQgdGhhbiBjdXJyZW50IGNoYWluIGlkLiBcXFxcXFxuICAgICAgICAgIFxcXFwgRmlyc3Qgc3RlcCBkZWJpdHMgQU1PVU5UIGNvaW5zIGluIFNFTkRFUiBhY2NvdW50IGFuZCB5aWVsZHMgXFxcXFxcbiAgICAgICAgICBcXFxcIFJFQ0VJVkVSLCBSRUNFSVZFUl9HVUFSRCBhbmQgQU1PVU5UIHRvIFRBUkdFVC1DSEFJTi4gXFxcXFxcbiAgICAgICAgICBcXFxcIFNlY29uZCBzdGVwIGNvbnRpbnVhdGlvbiBpcyBzZW50IGludG8gVEFSR0VULUNIQUlOIHdpdGggcHJvb2YgXFxcXFxcbiAgICAgICAgICBcXFxcIG9idGFpbmVkIGZyb20gdGhlIHNwdiAnb3V0cHV0JyBlbmRwb2ludCBvZiBDaGFpbndlYi4gXFxcXFxcbiAgICAgICAgICBcXFxcIFByb29mIGlzIHZhbGlkYXRlZCBhbmQgUkVDRUlWRVIgaXMgY3JlZGl0ZWQgd2l0aCBBTU9VTlQgXFxcXFxcbiAgICAgICAgICBcXFxcIGNyZWF0aW5nIGFjY291bnQgd2l0aCBSRUNFSVZFUl9HVUFSRCBhcyBuZWNlc3NhcnkuXFxcIlxcbiAgICAgQG1vZGVsIFsgKHByb3BlcnR5ICg-IGFtb3VudCAwLjApKVxcbiAgICAgICAgICAgICAgKHByb3BlcnR5ICghPSBzZW5kZXIgXFxcIlxcXCIpKVxcbiAgICAgICAgICAgICAgKHByb3BlcnR5ICghPSByZWNlaXZlciBcXFwiXFxcIikpXFxuICAgICAgICAgICAgICAocHJvcGVydHkgKCE9IHNlbmRlciByZWNlaXZlcikpXFxuICAgICAgICAgICAgICAocHJvcGVydHkgKCE9IHRhcmdldC1jaGFpbiBcXFwiXFxcIikpXFxuICAgICAgICAgICAgXVxcbiAgICAgKVxcblxcbiAgIChkZWZ1biBnZXQtYmFsYW5jZTpkZWNpbWFsXFxuICAgICAoIGFjY291bnQ6c3RyaW5nIClcXG4gICAgIFxcXCIgR2V0IGJhbGFuY2UgZm9yIEFDQ09VTlQuIEZhaWxzIGlmIGFjY291bnQgZG9lcyBub3QgZXhpc3QuXFxcIlxcbiAgICAgKVxcblxcbiAgIChkZWZ1biBkZXRhaWxzOm9iamVjdHthY2NvdW50LWRldGFpbHN9XFxuICAgICAoIGFjY291bnQ6IHN0cmluZyApXFxuICAgICBcXFwiIEdldCBhbiBvYmplY3Qgd2l0aCBkZXRhaWxzIG9mIEFDQ09VTlQuIFxcXFxcXG4gICAgIFxcXFwgRmFpbHMgaWYgYWNjb3VudCBkb2VzIG5vdCBleGlzdC5cXFwiXFxuICAgICApXFxuXFxuICAgKGRlZnVuIHByZWNpc2lvbjppbnRlZ2VyXFxuICAgICAoKVxcbiAgICAgXFxcIlJldHVybiB0aGUgbWF4aW11bSBhbGxvd2VkIGRlY2ltYWwgcHJlY2lzaW9uLlxcXCJcXG4gICAgIClcXG5cXG4gICAoZGVmdW4gZW5mb3JjZS11bml0OmJvb2xcXG4gICAgICggYW1vdW50OmRlY2ltYWwgKVxcbiAgICAgXFxcIiBFbmZvcmNlIG1pbmltdW0gcHJlY2lzaW9uIGFsbG93ZWQgZm9yIHRyYW5zYWN0aW9ucy5cXFwiXFxuICAgICApXFxuXFxuICAgKGRlZnVuIGNyZWF0ZS1hY2NvdW50OnN0cmluZ1xcbiAgICAgKCBhY2NvdW50OnN0cmluZ1xcbiAgICAgICBndWFyZDpndWFyZFxcbiAgICAgKVxcbiAgICAgXFxcIiBDcmVhdGUgQUNDT1VOVCB3aXRoIDAuMCBiYWxhbmNlLCB3aXRoIEdVQVJEIGNvbnRyb2xsaW5nIGFjY2Vzcy5cXFwiXFxuICAgICApXFxuXFxuICAgKGRlZnVuIHJvdGF0ZTpzdHJpbmdcXG4gICAgICggYWNjb3VudDpzdHJpbmdcXG4gICAgICAgbmV3LWd1YXJkOmd1YXJkXFxuICAgICApXFxuICAgICBcXFwiIFJvdGF0ZSBndWFyZCBmb3IgQUNDT1VOVC4gVHJhbnNhY3Rpb24gaXMgdmFsaWRhdGVkIGFnYWluc3QgXFxcXFxcbiAgICAgXFxcXCBleGlzdGluZyBndWFyZCBiZWZvcmUgaW5zdGFsbGluZyBuZXcgZ3VhcmQuIFxcXCJcXG4gICAgIClcXG5cXG4pXFxuXCJ9fSxcInNpZ25lcnNcIjpbXSxcIm1ldGFcIjp7XCJjcmVhdGlvblRpbWVcIjowLFwidHRsXCI6MTcyODAwLFwiZ2FzTGltaXRcIjowLFwiY2hhaW5JZFwiOlwiXCIsXCJnYXNQcmljZVwiOjAsXCJzZW5kZXJcIjpcIlwifSxcIm5vbmNlXCI6XCJmdW5naWJsZS1hc3NldC12MlwifSJ9", unsafeFromText "eyJnYXMiOjAsInJlc3VsdCI6eyJzdGF0dXMiOiJzdWNjZXNzIiwiZGF0YSI6IkxvYWRlZCBpbnRlcmZhY2UgZnVuZ2libGUtdjIifSwicmVxS2V5IjoiMDVCdGo3ZUJaQlc3by1TYUxvVmhBaWNNVVBaVUJiRzZRVDhfTEFrQ3hIcyIsImxvZ3MiOiJWaGlrLVYzOHByQXRpbHhTV3RZNWYxUnpmVjFUYVJBQzF0N3VVVXZjbGxnIiwibWV0YURhdGEiOm51bGwsImNvbnRpbnVhdGlvbiI6bnVsbCwidHhJZCI6Mn0") - , (unsafeFromText "eyJoYXNoIjoiR1JJUXU0aEFLazBJRDlGOHpfLTB5WHlBS0ozM01QeVRZTVhPamxQSm1wSSIsInNpZ3MiOltdLCJjbWQiOiJ7XCJuZXR3b3JrSWRcIjpudWxsLFwicGF5bG9hZFwiOntcImV4ZWNcIjp7XCJkYXRhXCI6bnVsbCxcImNvZGVcIjpcIlxcbihtb2R1bGUgY29pbiBHT1ZFUk5BTkNFXFxuXFxuICBAZG9jIFxcXCInY29pbicgcmVwcmVzZW50cyB0aGUgS2FkZW5hIENvaW4gQ29udHJhY3QuIFRoaXMgY29udHJhY3QgcHJvdmlkZXMgYm90aCB0aGUgXFxcXFxcbiAgXFxcXGJ1eS9yZWRlZW0gZ2FzIHN1cHBvcnQgaW4gdGhlIGZvcm0gb2YgJ2Z1bmQtdHgnLCBhcyB3ZWxsIGFzIHRyYW5zZmVyLCAgICAgICBcXFxcXFxuICBcXFxcY3JlZGl0LCBkZWJpdCwgY29pbmJhc2UsIGFjY291bnQgY3JlYXRpb24gYW5kIHF1ZXJ5LCBhcyB3ZWxsIGFzIFNQViBidXJuICAgIFxcXFxcXG4gIFxcXFxjcmVhdGUuIFRvIGFjY2VzcyB0aGUgY29pbiBjb250cmFjdCwgeW91IG1heSB1c2UgaXRzIGZ1bGx5LXF1YWxpZmllZCBuYW1lLCAgXFxcXFxcbiAgXFxcXG9yIGlzc3VlIHRoZSAnKHVzZSBjb2luKScgY29tbWFuZCBpbiB0aGUgYm9keSBvZiBhIG1vZHVsZSBkZWNsYXJhdGlvbi5cXFwiXFxuXFxuICBAbW9kZWxcXG4gICAgWyAoZGVmcHJvcGVydHkgY29uc2VydmVzLW1hc3NcXG4gICAgICAgICg9IChjb2x1bW4tZGVsdGEgY29pbi10YWJsZSAnYmFsYW5jZSkgMC4wKSlcXG5cXG4gICAgICAoZGVmcHJvcGVydHkgdmFsaWQtYWNjb3VudCAoYWNjb3VudDpzdHJpbmcpXFxuICAgICAgICAoYW5kXFxuICAgICAgICAgICg-PSAobGVuZ3RoIGFjY291bnQpIDMpXFxuICAgICAgICAgICg8PSAobGVuZ3RoIGFjY291bnQpIDI1NikpKVxcbiAgICBdXFxuXFxuICAoaW1wbGVtZW50cyBmdW5naWJsZS12MilcXG4gIChpbXBsZW1lbnRzIGZ1bmdpYmxlLXhjaGFpbi12MSlcXG5cXG4gIDs7IGNvaW4tdjJcXG4gIChibGVzcyBcXFwidXRfSl9aTmtveWFQVUVKaGl3VmVXbmtTUW45SlQ5c1FDV0tkampWVnJXb1xcXCIpXFxuXFxuICA7OyBjb2luIHYzXFxuICAoYmxlc3MgXFxcIjFvc19zTEFVWXZCenNwbjVqamF3dFJwSldpSDFXUGZoeU5yYWVWdlNJd1VcXFwiKVxcblxcbiAgOzsgY29pbiB2NFxcbiAgKGJsZXNzIFxcXCJCalpXMFQyYWM2cUVfSTVYOEdFNGZhbDZ0VHFqaExUQzdteTB5dFFTeExVXFxcIilcXG5cXG4gIDs7IGNvaW4gdjVcXG4gIChibGVzcyBcXFwickU3RFU4amxRTDl4X01QWXVuaVpKZjVJQ0JUQUVIQUlGUUNCNGJsb2ZQNFxcXCIpXFxuXFxuICA7IC0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tXFxuICA7IFNjaGVtYXMgYW5kIFRhYmxlc1xcblxcbiAgKGRlZnNjaGVtYSBjb2luLXNjaGVtYVxcbiAgICBAZG9jIFxcXCJUaGUgY29pbiBjb250cmFjdCB0b2tlbiBzY2hlbWFcXFwiXFxuICAgIEBtb2RlbCBbIChpbnZhcmlhbnQgKD49IGJhbGFuY2UgMC4wKSkgXVxcblxcbiAgICBiYWxhbmNlOmRlY2ltYWxcXG4gICAgZ3VhcmQ6Z3VhcmQpXFxuXFxuICAoZGVmdGFibGUgY29pbi10YWJsZTp7Y29pbi1zY2hlbWF9KVxcblxcbiAgOyAtLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLVxcbiAgOyBDYXBhYmlsaXRpZXNcXG5cXG4gIChkZWZjYXAgR09WRVJOQU5DRSAoKVxcbiAgICAoZW5mb3JjZSBmYWxzZSBcXFwiRW5mb3JjZSBub24tdXBncmFkZWFiaWxpdHlcXFwiKSlcXG5cXG4gIChkZWZjYXAgR0FTICgpXFxuICAgIFxcXCJNYWdpYyBjYXBhYmlsaXR5IHRvIHByb3RlY3QgZ2FzIGJ1eSBhbmQgcmVkZWVtXFxcIlxcbiAgICB0cnVlKVxcblxcbiAgKGRlZmNhcCBDT0lOQkFTRSAoKVxcbiAgICBcXFwiTWFnaWMgY2FwYWJpbGl0eSB0byBwcm90ZWN0IG1pbmVyIHJld2FyZFxcXCJcXG4gICAgdHJ1ZSlcXG5cXG4gIChkZWZjYXAgR0VORVNJUyAoKVxcbiAgICBcXFwiTWFnaWMgY2FwYWJpbGl0eSBjb25zdHJhaW5pbmcgZ2VuZXNpcyB0cmFuc2FjdGlvbnNcXFwiXFxuICAgIHRydWUpXFxuXFxuICAoZGVmY2FwIFJFTUVESUFURSAoKVxcbiAgICBcXFwiTWFnaWMgY2FwYWJpbGl0eSBmb3IgcmVtZWRpYXRpb24gdHJhbnNhY3Rpb25zXFxcIlxcbiAgICB0cnVlKVxcblxcbiAgKGRlZmNhcCBERUJJVCAoc2VuZGVyOnN0cmluZylcXG4gICAgXFxcIkNhcGFiaWxpdHkgZm9yIG1hbmFnaW5nIGRlYml0aW5nIG9wZXJhdGlvbnNcXFwiXFxuICAgIChlbmZvcmNlLWd1YXJkIChhdCAnZ3VhcmQgKHJlYWQgY29pbi10YWJsZSBzZW5kZXIpKSlcXG4gICAgKGVuZm9yY2UgKCE9IHNlbmRlciBcXFwiXFxcIikgXFxcInZhbGlkIHNlbmRlclxcXCIpKVxcblxcbiAgKGRlZmNhcCBDUkVESVQgKHJlY2VpdmVyOnN0cmluZylcXG4gICAgXFxcIkNhcGFiaWxpdHkgZm9yIG1hbmFnaW5nIGNyZWRpdGluZyBvcGVyYXRpb25zXFxcIlxcbiAgICAoZW5mb3JjZSAoIT0gcmVjZWl2ZXIgXFxcIlxcXCIpIFxcXCJ2YWxpZCByZWNlaXZlclxcXCIpKVxcblxcbiAgKGRlZmNhcCBST1RBVEUgKGFjY291bnQ6c3RyaW5nKVxcbiAgICBAZG9jIFxcXCJBdXRvbm9tb3VzbHkgbWFuYWdlZCBjYXBhYmlsaXR5IGZvciBndWFyZCByb3RhdGlvblxcXCJcXG4gICAgQG1hbmFnZWRcXG4gICAgdHJ1ZSlcXG5cXG4gIChkZWZjYXAgVFJBTlNGRVI6Ym9vbFxcbiAgICAoIHNlbmRlcjpzdHJpbmdcXG4gICAgICByZWNlaXZlcjpzdHJpbmdcXG4gICAgICBhbW91bnQ6ZGVjaW1hbFxcbiAgICApXFxuICAgIEBtYW5hZ2VkIGFtb3VudCBUUkFOU0ZFUi1tZ3JcXG4gICAgKGVuZm9yY2UgKCE9IHNlbmRlciByZWNlaXZlcikgXFxcInNhbWUgc2VuZGVyIGFuZCByZWNlaXZlclxcXCIpXFxuICAgIChlbmZvcmNlLXVuaXQgYW1vdW50KVxcbiAgICAoZW5mb3JjZSAoPiBhbW91bnQgMC4wKSBcXFwiUG9zaXRpdmUgYW1vdW50XFxcIilcXG4gICAgKGNvbXBvc2UtY2FwYWJpbGl0eSAoREVCSVQgc2VuZGVyKSlcXG4gICAgKGNvbXBvc2UtY2FwYWJpbGl0eSAoQ1JFRElUIHJlY2VpdmVyKSlcXG4gIClcXG5cXG4gIChkZWZ1biBUUkFOU0ZFUi1tZ3I6ZGVjaW1hbFxcbiAgICAoIG1hbmFnZWQ6ZGVjaW1hbFxcbiAgICAgIHJlcXVlc3RlZDpkZWNpbWFsXFxuICAgIClcXG5cXG4gICAgKGxldCAoKG5ld2JhbCAoLSBtYW5hZ2VkIHJlcXVlc3RlZCkpKVxcbiAgICAgIChlbmZvcmNlICg-PSBuZXdiYWwgMC4wKVxcbiAgICAgICAgKGZvcm1hdCBcXFwiVFJBTlNGRVIgZXhjZWVkZWQgZm9yIGJhbGFuY2Uge31cXFwiIFttYW5hZ2VkXSkpXFxuICAgICAgbmV3YmFsKVxcbiAgKVxcblxcbiAgKGRlZmNhcCBUUkFOU0ZFUl9YQ0hBSU46Ym9vbFxcbiAgICAoIHNlbmRlcjpzdHJpbmdcXG4gICAgICByZWNlaXZlcjpzdHJpbmdcXG4gICAgICBhbW91bnQ6ZGVjaW1hbFxcbiAgICAgIHRhcmdldC1jaGFpbjpzdHJpbmdcXG4gICAgKVxcblxcbiAgICBAbWFuYWdlZCBhbW91bnQgVFJBTlNGRVJfWENIQUlOLW1nclxcbiAgICAoZW5mb3JjZS11bml0IGFtb3VudClcXG4gICAgKGVuZm9yY2UgKD4gYW1vdW50IDAuMCkgXFxcIkNyb3NzLWNoYWluIHRyYW5zZmVycyByZXF1aXJlIGEgcG9zaXRpdmUgYW1vdW50XFxcIilcXG4gICAgKGNvbXBvc2UtY2FwYWJpbGl0eSAoREVCSVQgc2VuZGVyKSlcXG4gIClcXG5cXG4gIChkZWZ1biBUUkFOU0ZFUl9YQ0hBSU4tbWdyOmRlY2ltYWxcXG4gICAgKCBtYW5hZ2VkOmRlY2ltYWxcXG4gICAgICByZXF1ZXN0ZWQ6ZGVjaW1hbFxcbiAgICApXFxuXFxuICAgIChlbmZvcmNlICg-PSBtYW5hZ2VkIHJlcXVlc3RlZClcXG4gICAgICAoZm9ybWF0IFxcXCJUUkFOU0ZFUl9YQ0hBSU4gZXhjZWVkZWQgZm9yIGJhbGFuY2Uge31cXFwiIFttYW5hZ2VkXSkpXFxuICAgIDAuMFxcbiAgKVxcblxcbiAgKGRlZmNhcCBUUkFOU0ZFUl9YQ0hBSU5fUkVDRDpib29sXFxuICAgICggc2VuZGVyOnN0cmluZ1xcbiAgICAgIHJlY2VpdmVyOnN0cmluZ1xcbiAgICAgIGFtb3VudDpkZWNpbWFsXFxuICAgICAgc291cmNlLWNoYWluOnN0cmluZ1xcbiAgICApXFxuICAgIEBldmVudCB0cnVlXFxuICApXFxuXFxuICA7IHYzIGNhcGFiaWxpdGllc1xcbiAgKGRlZmNhcCBSRUxFQVNFX0FMTE9DQVRJT05cXG4gICAgKCBhY2NvdW50OnN0cmluZ1xcbiAgICAgIGFtb3VudDpkZWNpbWFsXFxuICAgIClcXG4gICAgQGRvYyBcXFwiRXZlbnQgZm9yIGFsbG9jYXRpb24gcmVsZWFzZSwgY2FuIGJlIHVzZWQgZm9yIHNpZyBzY29waW5nLlxcXCJcXG4gICAgQGV2ZW50IHRydWVcXG4gIClcXG5cXG4gIDsgLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS1cXG4gIDsgQ29uc3RhbnRzXFxuXFxuICAoZGVmY29uc3QgQ09JTl9DSEFSU0VUIENIQVJTRVRfTEFUSU4xXFxuICAgIFxcXCJUaGUgZGVmYXVsdCBjb2luIGNvbnRyYWN0IGNoYXJhY3RlciBzZXRcXFwiKVxcblxcbiAgKGRlZmNvbnN0IE1JTklNVU1fUFJFQ0lTSU9OIDEyXFxuICAgIFxcXCJNaW5pbXVtIGFsbG93ZWQgcHJlY2lzaW9uIGZvciBjb2luIHRyYW5zYWN0aW9uc1xcXCIpXFxuXFxuICAoZGVmY29uc3QgTUlOSU1VTV9BQ0NPVU5UX0xFTkdUSCAzXFxuICAgIFxcXCJNaW5pbXVtIGFjY291bnQgbGVuZ3RoIGFkbWlzc2libGUgZm9yIGNvaW4gYWNjb3VudHNcXFwiKVxcblxcbiAgKGRlZmNvbnN0IE1BWElNVU1fQUNDT1VOVF9MRU5HVEggMjU2XFxuICAgIFxcXCJNYXhpbXVtIGFjY291bnQgbmFtZSBsZW5ndGggYWRtaXNzaWJsZSBmb3IgY29pbiBhY2NvdW50c1xcXCIpXFxuXFxuICAoZGVmY29uc3QgVkFMSURfQ0hBSU5fSURTIChtYXAgKGludC10by1zdHIgMTApIChlbnVtZXJhdGUgMCAxOSkpXFxuICAgIFxcXCJMaXN0IG9mIGFsbCB2YWxpZCBDaGFpbndlYiBjaGFpbiBpZHNcXFwiKVxcblxcbiAgOyAtLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLVxcbiAgOyBVdGlsaXRpZXNcXG5cXG4gIChkZWZ1biBlbmZvcmNlLXVuaXQ6Ym9vbCAoYW1vdW50OmRlY2ltYWwpXFxuICAgIEBkb2MgXFxcIkVuZm9yY2UgbWluaW11bSBwcmVjaXNpb24gYWxsb3dlZCBmb3IgY29pbiB0cmFuc2FjdGlvbnNcXFwiXFxuXFxuICAgIChlbmZvcmNlXFxuICAgICAgKD0gKGZsb29yIGFtb3VudCBNSU5JTVVNX1BSRUNJU0lPTilcXG4gICAgICAgICBhbW91bnQpXFxuICAgICAgKGZvcm1hdCBcXFwiQW1vdW50IHZpb2xhdGVzIG1pbmltdW0gcHJlY2lzaW9uOiB7fVxcXCIgW2Ftb3VudF0pKVxcbiAgICApXFxuXFxuICAoZGVmdW4gdmFsaWRhdGUtYWNjb3VudCAoYWNjb3VudDpzdHJpbmcpXFxuICAgIEBkb2MgXFxcIkVuZm9yY2UgdGhhdCBhbiBhY2NvdW50IG5hbWUgY29uZm9ybXMgdG8gdGhlIGNvaW4gY29udHJhY3QgXFxcXFxcbiAgICAgICAgIFxcXFxtaW5pbXVtIGFuZCBtYXhpbXVtIGxlbmd0aCByZXF1aXJlbWVudHMsIGFzIHdlbGwgYXMgdGhlICAgIFxcXFxcXG4gICAgICAgICBcXFxcbGF0aW4tMSBjaGFyYWN0ZXIgc2V0LlxcXCJcXG5cXG4gICAgKGVuZm9yY2VcXG4gICAgICAoaXMtY2hhcnNldCBDT0lOX0NIQVJTRVQgYWNjb3VudClcXG4gICAgICAoZm9ybWF0XFxuICAgICAgICBcXFwiQWNjb3VudCBkb2VzIG5vdCBjb25mb3JtIHRvIHRoZSBjb2luIGNvbnRyYWN0IGNoYXJzZXQ6IHt9XFxcIlxcbiAgICAgICAgW2FjY291bnRdKSlcXG5cXG4gICAgKGxldCAoKGFjY291bnQtbGVuZ3RoIChsZW5ndGggYWNjb3VudCkpKVxcblxcbiAgICAgIChlbmZvcmNlXFxuICAgICAgICAoPj0gYWNjb3VudC1sZW5ndGggTUlOSU1VTV9BQ0NPVU5UX0xFTkdUSClcXG4gICAgICAgIChmb3JtYXRcXG4gICAgICAgICAgXFxcIkFjY291bnQgbmFtZSBkb2VzIG5vdCBjb25mb3JtIHRvIHRoZSBtaW4gbGVuZ3RoIHJlcXVpcmVtZW50OiB7fVxcXCJcXG4gICAgICAgICAgW2FjY291bnRdKSlcXG5cXG4gICAgICAoZW5mb3JjZVxcbiAgICAgICAgKDw9IGFjY291bnQtbGVuZ3RoIE1BWElNVU1fQUNDT1VOVF9MRU5HVEgpXFxuICAgICAgICAoZm9ybWF0XFxuICAgICAgICAgIFxcXCJBY2NvdW50IG5hbWUgZG9lcyBub3QgY29uZm9ybSB0byB0aGUgbWF4IGxlbmd0aCByZXF1aXJlbWVudDoge31cXFwiXFxuICAgICAgICAgIFthY2NvdW50XSkpXFxuICAgICAgKVxcbiAgKVxcblxcbiAgOyAtLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLVxcbiAgOyBDb2luIENvbnRyYWN0XFxuXFxuICAoZGVmdW4gZ2FzLW9ubHkgKClcXG4gICAgXFxcIlByZWRpY2F0ZSBmb3IgZ2FzLW9ubHkgdXNlciBndWFyZHMuXFxcIlxcbiAgICAocmVxdWlyZS1jYXBhYmlsaXR5IChHQVMpKSlcXG5cXG4gIChkZWZ1biBnYXMtZ3VhcmQgKGd1YXJkOmd1YXJkKVxcbiAgICBcXFwiUHJlZGljYXRlIGZvciBnYXMgKyBzaW5nbGUga2V5IHVzZXIgZ3VhcmRzXFxcIlxcbiAgICAoZW5mb3JjZS1vbmVcXG4gICAgICBcXFwiRW5mb3JjZSBlaXRoZXIgdGhlIHByZXNlbmNlIG9mIGEgR0FTIGNhcCBvciBrZXlzZXRcXFwiXFxuICAgICAgWyAoZ2FzLW9ubHkpXFxuICAgICAgICAoZW5mb3JjZS1ndWFyZCBndWFyZClcXG4gICAgICBdKSlcXG5cXG4gIChkZWZ1biBidXktZ2FzOnN0cmluZyAoc2VuZGVyOnN0cmluZyB0b3RhbDpkZWNpbWFsKVxcbiAgICBAZG9jIFxcXCJUaGlzIGZ1bmN0aW9uIGRlc2NyaWJlcyB0aGUgbWFpbiAnZ2FzIGJ1eScgb3BlcmF0aW9uLiBBdCB0aGlzIHBvaW50IFxcXFxcXG4gICAgXFxcXE1JTkVSIGhhcyBiZWVuIGNob3NlbiBmcm9tIHRoZSBwb29sLCBhbmQgd2lsbCBiZSB2YWxpZGF0ZWQuIFRoZSBTRU5ERVIgICBcXFxcXFxuICAgIFxcXFxvZiB0aGlzIHRyYW5zYWN0aW9uIGhhcyBzcGVjaWZpZWQgYSBnYXMgbGltaXQgTElNSVQgKG1heGltdW0gZ2FzKSBmb3IgICAgXFxcXFxcbiAgICBcXFxcdGhlIHRyYW5zYWN0aW9uLCBhbmQgdGhlIHByaWNlIGlzIHRoZSBzcG90IHByaWNlIG9mIGdhcyBhdCB0aGF0IHRpbWUuICAgIFxcXFxcXG4gICAgXFxcXFRoZSBnYXMgYnV5IHdpbGwgYmUgZXhlY3V0ZWQgcHJpb3IgdG8gZXhlY3V0aW5nIFNFTkRFUidzIGNvZGUuXFxcIlxcblxcbiAgICBAbW9kZWwgWyAocHJvcGVydHkgKD4gdG90YWwgMC4wKSlcXG4gICAgICAgICAgICAgKHByb3BlcnR5ICh2YWxpZC1hY2NvdW50IHNlbmRlcikpXFxuICAgICAgICAgICBdXFxuXFxuICAgICh2YWxpZGF0ZS1hY2NvdW50IHNlbmRlcilcXG5cXG4gICAgKGVuZm9yY2UtdW5pdCB0b3RhbClcXG4gICAgKGVuZm9yY2UgKD4gdG90YWwgMC4wKSBcXFwiZ2FzIHN1cHBseSBtdXN0IGJlIGEgcG9zaXRpdmUgcXVhbnRpdHlcXFwiKVxcblxcbiAgICAocmVxdWlyZS1jYXBhYmlsaXR5IChHQVMpKVxcbiAgICAod2l0aC1jYXBhYmlsaXR5IChERUJJVCBzZW5kZXIpXFxuICAgICAgKGRlYml0IHNlbmRlciB0b3RhbCkpXFxuICAgIClcXG5cXG4gIChkZWZ1biByZWRlZW0tZ2FzOnN0cmluZyAobWluZXI6c3RyaW5nIG1pbmVyLWd1YXJkOmd1YXJkIHNlbmRlcjpzdHJpbmcgdG90YWw6ZGVjaW1hbClcXG4gICAgQGRvYyBcXFwiVGhpcyBmdW5jdGlvbiBkZXNjcmliZXMgdGhlIG1haW4gJ3JlZGVlbSBnYXMnIG9wZXJhdGlvbi4gQXQgdGhpcyAgICBcXFxcXFxuICAgIFxcXFxwb2ludCwgdGhlIFNFTkRFUidzIHRyYW5zYWN0aW9uIGhhcyBiZWVuIGV4ZWN1dGVkLCBhbmQgdGhlIGdhcyB0aGF0ICAgICAgXFxcXFxcbiAgICBcXFxcd2FzIGNoYXJnZWQgaGFzIGJlZW4gY2FsY3VsYXRlZC4gTUlORVIgd2lsbCBiZSBjcmVkaXRlZCB0aGUgZ2FzIGNvc3QsICAgIFxcXFxcXG4gICAgXFxcXGFuZCBTRU5ERVIgd2lsbCByZWNlaXZlIHRoZSByZW1haW5kZXIgdXAgdG8gdGhlIGxpbWl0XFxcIlxcblxcbiAgICBAbW9kZWwgWyAocHJvcGVydHkgKD4gdG90YWwgMC4wKSlcXG4gICAgICAgICAgICAgKHByb3BlcnR5ICh2YWxpZC1hY2NvdW50IHNlbmRlcikpXFxuICAgICAgICAgICAgIChwcm9wZXJ0eSAodmFsaWQtYWNjb3VudCBtaW5lcikpXFxuICAgICAgICAgICBdXFxuXFxuICAgICh2YWxpZGF0ZS1hY2NvdW50IHNlbmRlcilcXG4gICAgKHZhbGlkYXRlLWFjY291bnQgbWluZXIpXFxuICAgIChlbmZvcmNlLXVuaXQgdG90YWwpXFxuXFxuICAgIChyZXF1aXJlLWNhcGFiaWxpdHkgKEdBUykpXFxuICAgIChsZXQqXFxuICAgICAgKChmZWUgKHJlYWQtZGVjaW1hbCBcXFwiZmVlXFxcIikpXFxuICAgICAgIChyZWZ1bmQgKC0gdG90YWwgZmVlKSkpXFxuXFxuICAgICAgKGVuZm9yY2UtdW5pdCBmZWUpXFxuICAgICAgKGVuZm9yY2UgKD49IGZlZSAwLjApXFxuICAgICAgICBcXFwiZmVlIG11c3QgYmUgYSBub24tbmVnYXRpdmUgcXVhbnRpdHlcXFwiKVxcblxcbiAgICAgIChlbmZvcmNlICg-PSByZWZ1bmQgMC4wKVxcbiAgICAgICAgXFxcInJlZnVuZCBtdXN0IGJlIGEgbm9uLW5lZ2F0aXZlIHF1YW50aXR5XFxcIilcXG5cXG4gICAgICAoZW1pdC1ldmVudCAoVFJBTlNGRVIgc2VuZGVyIG1pbmVyIGZlZSkpIDt2M1xcblxcbiAgICAgICAgOyBkaXJlY3RseSB1cGRhdGUgaW5zdGVhZCBvZiBjcmVkaXRcXG4gICAgICAod2l0aC1jYXBhYmlsaXR5IChDUkVESVQgc2VuZGVyKVxcbiAgICAgICAgKGlmICg-IHJlZnVuZCAwLjApXFxuICAgICAgICAgICh3aXRoLXJlYWQgY29pbi10YWJsZSBzZW5kZXJcXG4gICAgICAgICAgICB7IFxcXCJiYWxhbmNlXFxcIiA6PSBiYWxhbmNlIH1cXG4gICAgICAgICAgICAodXBkYXRlIGNvaW4tdGFibGUgc2VuZGVyXFxuICAgICAgICAgICAgICB7IFxcXCJiYWxhbmNlXFxcIjogKCsgYmFsYW5jZSByZWZ1bmQpIH0pKVxcblxcbiAgICAgICAgICBcXFwibm9vcFxcXCIpKVxcblxcbiAgICAgICh3aXRoLWNhcGFiaWxpdHkgKENSRURJVCBtaW5lcilcXG4gICAgICAgIChpZiAoPiBmZWUgMC4wKVxcbiAgICAgICAgICAoY3JlZGl0IG1pbmVyIG1pbmVyLWd1YXJkIGZlZSlcXG4gICAgICAgICAgXFxcIm5vb3BcXFwiKSlcXG4gICAgICApXFxuXFxuICAgIClcXG5cXG4gIChkZWZ1biBjcmVhdGUtYWNjb3VudDpzdHJpbmcgKGFjY291bnQ6c3RyaW5nIGd1YXJkOmd1YXJkKVxcbiAgICBAbW9kZWwgWyAocHJvcGVydHkgKHZhbGlkLWFjY291bnQgYWNjb3VudCkpIF1cXG5cXG4gICAgKHZhbGlkYXRlLWFjY291bnQgYWNjb3VudClcXG4gICAgKGVuZm9yY2UtcmVzZXJ2ZWQgYWNjb3VudCBndWFyZClcXG5cXG4gICAgKGluc2VydCBjb2luLXRhYmxlIGFjY291bnRcXG4gICAgICB7IFxcXCJiYWxhbmNlXFxcIiA6IDAuMFxcbiAgICAgICwgXFxcImd1YXJkXFxcIiAgIDogZ3VhcmRcXG4gICAgICB9KVxcbiAgICApXFxuXFxuICAoZGVmdW4gZ2V0LWJhbGFuY2U6ZGVjaW1hbCAoYWNjb3VudDpzdHJpbmcpXFxuICAgICh3aXRoLXJlYWQgY29pbi10YWJsZSBhY2NvdW50XFxuICAgICAgeyBcXFwiYmFsYW5jZVxcXCIgOj0gYmFsYW5jZSB9XFxuICAgICAgYmFsYW5jZVxcbiAgICAgIClcXG4gICAgKVxcblxcbiAgKGRlZnVuIGRldGFpbHM6b2JqZWN0e2Z1bmdpYmxlLXYyLmFjY291bnQtZGV0YWlsc31cXG4gICAgKCBhY2NvdW50OnN0cmluZyApXFxuICAgICh3aXRoLXJlYWQgY29pbi10YWJsZSBhY2NvdW50XFxuICAgICAgeyBcXFwiYmFsYW5jZVxcXCIgOj0gYmFsXFxuICAgICAgLCBcXFwiZ3VhcmRcXFwiIDo9IGcgfVxcbiAgICAgIHsgXFxcImFjY291bnRcXFwiIDogYWNjb3VudFxcbiAgICAgICwgXFxcImJhbGFuY2VcXFwiIDogYmFsXFxuICAgICAgLCBcXFwiZ3VhcmRcXFwiOiBnIH0pXFxuICAgIClcXG5cXG4gIChkZWZ1biByb3RhdGU6c3RyaW5nIChhY2NvdW50OnN0cmluZyBuZXctZ3VhcmQ6Z3VhcmQpXFxuICAgICh3aXRoLWNhcGFiaWxpdHkgKFJPVEFURSBhY2NvdW50KVxcblxcbiAgICAgIDsgQWxsb3cgcm90YXRpb24gb25seSBmb3IgdmFuaXR5IGFjY291bnRzLCBvclxcbiAgICAgIDsgcmUtcm90YXRpbmcgYSBwcmluY2lwYWwgYWNjb3VudCBiYWNrIHRvIGl0cyBwcm9wZXIgZ3VhcmRcXG4gICAgICAoZW5mb3JjZSAob3IgKG5vdCAoaXMtcHJpbmNpcGFsIGFjY291bnQpKVxcbiAgICAgICAgICAgICAgICAgICh2YWxpZGF0ZS1wcmluY2lwYWwgbmV3LWd1YXJkIGFjY291bnQpKVxcbiAgICAgICAgXFxcIkl0IGlzIHVuc2FmZSBmb3IgcHJpbmNpcGFsIGFjY291bnRzIHRvIHJvdGF0ZSB0aGVpciBndWFyZFxcXCIpXFxuXFxuICAgICAgKHdpdGgtcmVhZCBjb2luLXRhYmxlIGFjY291bnRcXG4gICAgICAgIHsgXFxcImd1YXJkXFxcIiA6PSBvbGQtZ3VhcmQgfVxcbiAgICAgICAgKGVuZm9yY2UtZ3VhcmQgb2xkLWd1YXJkKVxcbiAgICAgICAgKHVwZGF0ZSBjb2luLXRhYmxlIGFjY291bnRcXG4gICAgICAgICAgeyBcXFwiZ3VhcmRcXFwiIDogbmV3LWd1YXJkIH1cXG4gICAgICAgICAgKSkpXFxuICAgIClcXG5cXG5cXG4gIChkZWZ1biBwcmVjaXNpb246aW50ZWdlclxcbiAgICAoKVxcbiAgICBNSU5JTVVNX1BSRUNJU0lPTilcXG5cXG4gIChkZWZ1biB0cmFuc2ZlcjpzdHJpbmcgKHNlbmRlcjpzdHJpbmcgcmVjZWl2ZXI6c3RyaW5nIGFtb3VudDpkZWNpbWFsKVxcbiAgICBAbW9kZWwgWyAocHJvcGVydHkgY29uc2VydmVzLW1hc3MpXFxuICAgICAgICAgICAgIChwcm9wZXJ0eSAoPiBhbW91bnQgMC4wKSlcXG4gICAgICAgICAgICAgKHByb3BlcnR5ICh2YWxpZC1hY2NvdW50IHNlbmRlcikpXFxuICAgICAgICAgICAgIChwcm9wZXJ0eSAodmFsaWQtYWNjb3VudCByZWNlaXZlcikpXFxuICAgICAgICAgICAgIChwcm9wZXJ0eSAoIT0gc2VuZGVyIHJlY2VpdmVyKSkgXVxcblxcbiAgICAoZW5mb3JjZSAoIT0gc2VuZGVyIHJlY2VpdmVyKVxcbiAgICAgIFxcXCJzZW5kZXIgY2Fubm90IGJlIHRoZSByZWNlaXZlciBvZiBhIHRyYW5zZmVyXFxcIilcXG5cXG4gICAgKHZhbGlkYXRlLWFjY291bnQgc2VuZGVyKVxcbiAgICAodmFsaWRhdGUtYWNjb3VudCByZWNlaXZlcilcXG5cXG4gICAgKGVuZm9yY2UgKD4gYW1vdW50IDAuMClcXG4gICAgICBcXFwidHJhbnNmZXIgYW1vdW50IG11c3QgYmUgcG9zaXRpdmVcXFwiKVxcblxcbiAgICAoZW5mb3JjZS11bml0IGFtb3VudClcXG5cXG4gICAgKHdpdGgtY2FwYWJpbGl0eSAoVFJBTlNGRVIgc2VuZGVyIHJlY2VpdmVyIGFtb3VudClcXG4gICAgICAoZGViaXQgc2VuZGVyIGFtb3VudClcXG4gICAgICAod2l0aC1yZWFkIGNvaW4tdGFibGUgcmVjZWl2ZXJcXG4gICAgICAgIHsgXFxcImd1YXJkXFxcIiA6PSBnIH1cXG5cXG4gICAgICAgIChjcmVkaXQgcmVjZWl2ZXIgZyBhbW91bnQpKVxcbiAgICAgIClcXG4gICAgKVxcblxcbiAgKGRlZnVuIHRyYW5zZmVyLWNyZWF0ZTpzdHJpbmdcXG4gICAgKCBzZW5kZXI6c3RyaW5nXFxuICAgICAgcmVjZWl2ZXI6c3RyaW5nXFxuICAgICAgcmVjZWl2ZXItZ3VhcmQ6Z3VhcmRcXG4gICAgICBhbW91bnQ6ZGVjaW1hbCApXFxuXFxuICAgIEBtb2RlbCBbIChwcm9wZXJ0eSBjb25zZXJ2ZXMtbWFzcykgXVxcblxcbiAgICAoZW5mb3JjZSAoIT0gc2VuZGVyIHJlY2VpdmVyKVxcbiAgICAgIFxcXCJzZW5kZXIgY2Fubm90IGJlIHRoZSByZWNlaXZlciBvZiBhIHRyYW5zZmVyXFxcIilcXG5cXG4gICAgKHZhbGlkYXRlLWFjY291bnQgc2VuZGVyKVxcbiAgICAodmFsaWRhdGUtYWNjb3VudCByZWNlaXZlcilcXG5cXG4gICAgKGVuZm9yY2UgKD4gYW1vdW50IDAuMClcXG4gICAgICBcXFwidHJhbnNmZXIgYW1vdW50IG11c3QgYmUgcG9zaXRpdmVcXFwiKVxcblxcbiAgICAoZW5mb3JjZS11bml0IGFtb3VudClcXG5cXG4gICAgKHdpdGgtY2FwYWJpbGl0eSAoVFJBTlNGRVIgc2VuZGVyIHJlY2VpdmVyIGFtb3VudClcXG4gICAgICAoZGViaXQgc2VuZGVyIGFtb3VudClcXG4gICAgICAoY3JlZGl0IHJlY2VpdmVyIHJlY2VpdmVyLWd1YXJkIGFtb3VudCkpXFxuICAgIClcXG5cXG4gIChkZWZ1biBjb2luYmFzZTpzdHJpbmcgKGFjY291bnQ6c3RyaW5nIGFjY291bnQtZ3VhcmQ6Z3VhcmQgYW1vdW50OmRlY2ltYWwpXFxuICAgIEBkb2MgXFxcIkludGVybmFsIGZ1bmN0aW9uIGZvciB0aGUgaW5pdGlhbCBjcmVhdGlvbiBvZiBjb2lucy4gIFRoaXMgZnVuY3Rpb24gXFxcXFxcbiAgICBcXFxcY2Fubm90IGJlIHVzZWQgb3V0c2lkZSBvZiB0aGUgY29pbiBjb250cmFjdC5cXFwiXFxuXFxuICAgIEBtb2RlbCBbIChwcm9wZXJ0eSAodmFsaWQtYWNjb3VudCBhY2NvdW50KSlcXG4gICAgICAgICAgICAgKHByb3BlcnR5ICg-IGFtb3VudCAwLjApKVxcbiAgICAgICAgICAgXVxcblxcbiAgICAodmFsaWRhdGUtYWNjb3VudCBhY2NvdW50KVxcbiAgICAoZW5mb3JjZS11bml0IGFtb3VudClcXG5cXG4gICAgKHJlcXVpcmUtY2FwYWJpbGl0eSAoQ09JTkJBU0UpKVxcbiAgICAoZW1pdC1ldmVudCAoVFJBTlNGRVIgXFxcIlxcXCIgYWNjb3VudCBhbW91bnQpKSA7djNcXG4gICAgKHdpdGgtY2FwYWJpbGl0eSAoQ1JFRElUIGFjY291bnQpXFxuICAgICAgKGNyZWRpdCBhY2NvdW50IGFjY291bnQtZ3VhcmQgYW1vdW50KSlcXG4gICAgKVxcblxcbiAgKGRlZnVuIHJlbWVkaWF0ZTpzdHJpbmcgKGFjY291bnQ6c3RyaW5nIGFtb3VudDpkZWNpbWFsKVxcbiAgICBAZG9jIFxcXCJBbGxvd3MgZm9yIHJlbWVkaWF0aW9uIHRyYW5zYWN0aW9ucy4gVGhpcyBmdW5jdGlvbiBcXFxcXFxuICAgICAgICAgXFxcXGlzIHByb3RlY3RlZCBieSB0aGUgUkVNRURJQVRFIGNhcGFiaWxpdHlcXFwiXFxuICAgIEBtb2RlbCBbIChwcm9wZXJ0eSAodmFsaWQtYWNjb3VudCBhY2NvdW50KSlcXG4gICAgICAgICAgICAgKHByb3BlcnR5ICg-IGFtb3VudCAwLjApKVxcbiAgICAgICAgICAgXVxcblxcbiAgICAodmFsaWRhdGUtYWNjb3VudCBhY2NvdW50KVxcblxcbiAgICAoZW5mb3JjZSAoPiBhbW91bnQgMC4wKVxcbiAgICAgIFxcXCJSZW1lZGlhdGlvbiBhbW91bnQgbXVzdCBiZSBwb3NpdGl2ZVxcXCIpXFxuXFxuICAgIChlbmZvcmNlLXVuaXQgYW1vdW50KVxcblxcbiAgICAocmVxdWlyZS1jYXBhYmlsaXR5IChSRU1FRElBVEUpKVxcbiAgICAoZW1pdC1ldmVudCAoVFJBTlNGRVIgXFxcIlxcXCIgYWNjb3VudCBhbW91bnQpKSA7djNcXG4gICAgKHdpdGgtcmVhZCBjb2luLXRhYmxlIGFjY291bnRcXG4gICAgICB7IFxcXCJiYWxhbmNlXFxcIiA6PSBiYWxhbmNlIH1cXG5cXG4gICAgICAoZW5mb3JjZSAoPD0gYW1vdW50IGJhbGFuY2UpIFxcXCJJbnN1ZmZpY2llbnQgZnVuZHNcXFwiKVxcblxcbiAgICAgICh1cGRhdGUgY29pbi10YWJsZSBhY2NvdW50XFxuICAgICAgICB7IFxcXCJiYWxhbmNlXFxcIiA6ICgtIGJhbGFuY2UgYW1vdW50KSB9XFxuICAgICAgICApKVxcbiAgICApXFxuXFxuICAoZGVmcGFjdCBmdW5kLXR4IChzZW5kZXI6c3RyaW5nIG1pbmVyOnN0cmluZyBtaW5lci1ndWFyZDpndWFyZCB0b3RhbDpkZWNpbWFsKVxcbiAgICBAZG9jIFxcXCInZnVuZC10eCcgaXMgYSBzcGVjaWFsIHBhY3QgdG8gZnVuZCBhIHRyYW5zYWN0aW9uIGluIHR3byBzdGVwcywgICAgIFxcXFxcXG4gICAgXFxcXHdpdGggdGhlIGFjdHVhbCB0cmFuc2FjdGlvbiB0cmFuc3BpcmluZyBpbiB0aGUgbWlkZGxlOiAgICAgICAgICAgICAgICAgICBcXFxcXFxuICAgIFxcXFwgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgXFxcXFxcbiAgICBcXFxcICAxKSBBIGJ1eWluZyBwaGFzZSwgZGViaXRpbmcgdGhlIHNlbmRlciBmb3IgdG90YWwgZ2FzIGFuZCBmZWUsIHlpZWxkaW5nIFxcXFxcXG4gICAgXFxcXCAgICAgVFhfTUFYX0NIQVJHRS4gICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICBcXFxcXFxuICAgIFxcXFwgIDIpIEEgc2V0dGxlbWVudCBwaGFzZSwgcmVzdW1pbmcgVFhfTUFYX0NIQVJHRSwgYW5kIGFsbG9jYXRpbmcgdG8gdGhlICAgXFxcXFxcbiAgICBcXFxcICAgICBjb2luYmFzZSBhY2NvdW50IGZvciB1c2VkIGdhcyBhbmQgZmVlLCBhbmQgc2VuZGVyIGFjY291bnQgZm9yIGJhbC0gIFxcXFxcXG4gICAgXFxcXCAgICAgYW5jZSAodW51c2VkIGdhcywgaWYgYW55KS5cXFwiXFxuXFxuICAgIEBtb2RlbCBbIChwcm9wZXJ0eSAoPiB0b3RhbCAwLjApKVxcbiAgICAgICAgICAgICAocHJvcGVydHkgKHZhbGlkLWFjY291bnQgc2VuZGVyKSlcXG4gICAgICAgICAgICAgKHByb3BlcnR5ICh2YWxpZC1hY2NvdW50IG1pbmVyKSlcXG4gICAgICAgICAgICAgOyhwcm9wZXJ0eSBjb25zZXJ2ZXMtbWFzcykgbm90IHN1cHBvcnRlZCB5ZXRcXG4gICAgICAgICAgIF1cXG5cXG4gICAgKHN0ZXAgKGJ1eS1nYXMgc2VuZGVyIHRvdGFsKSlcXG4gICAgKHN0ZXAgKHJlZGVlbS1nYXMgbWluZXIgbWluZXItZ3VhcmQgc2VuZGVyIHRvdGFsKSlcXG4gICAgKVxcblxcbiAgKGRlZnVuIGRlYml0OnN0cmluZyAoYWNjb3VudDpzdHJpbmcgYW1vdW50OmRlY2ltYWwpXFxuICAgIEBkb2MgXFxcIkRlYml0IEFNT1VOVCBmcm9tIEFDQ09VTlQgYmFsYW5jZVxcXCJcXG5cXG4gICAgQG1vZGVsIFsgKHByb3BlcnR5ICg-IGFtb3VudCAwLjApKVxcbiAgICAgICAgICAgICAocHJvcGVydHkgKHZhbGlkLWFjY291bnQgYWNjb3VudCkpXFxuICAgICAgICAgICBdXFxuXFxuICAgICh2YWxpZGF0ZS1hY2NvdW50IGFjY291bnQpXFxuXFxuICAgIChlbmZvcmNlICg-IGFtb3VudCAwLjApXFxuICAgICAgXFxcImRlYml0IGFtb3VudCBtdXN0IGJlIHBvc2l0aXZlXFxcIilcXG5cXG4gICAgKGVuZm9yY2UtdW5pdCBhbW91bnQpXFxuXFxuICAgIChyZXF1aXJlLWNhcGFiaWxpdHkgKERFQklUIGFjY291bnQpKVxcbiAgICAod2l0aC1yZWFkIGNvaW4tdGFibGUgYWNjb3VudFxcbiAgICAgIHsgXFxcImJhbGFuY2VcXFwiIDo9IGJhbGFuY2UgfVxcblxcbiAgICAgIChlbmZvcmNlICg8PSBhbW91bnQgYmFsYW5jZSkgXFxcIkluc3VmZmljaWVudCBmdW5kc1xcXCIpXFxuXFxuICAgICAgKHVwZGF0ZSBjb2luLXRhYmxlIGFjY291bnRcXG4gICAgICAgIHsgXFxcImJhbGFuY2VcXFwiIDogKC0gYmFsYW5jZSBhbW91bnQpIH1cXG4gICAgICAgICkpXFxuICAgIClcXG5cXG5cXG4gIChkZWZ1biBjcmVkaXQ6c3RyaW5nIChhY2NvdW50OnN0cmluZyBndWFyZDpndWFyZCBhbW91bnQ6ZGVjaW1hbClcXG4gICAgQGRvYyBcXFwiQ3JlZGl0IEFNT1VOVCB0byBBQ0NPVU5UIGJhbGFuY2VcXFwiXFxuXFxuICAgIEBtb2RlbCBbIChwcm9wZXJ0eSAoPiBhbW91bnQgMC4wKSlcXG4gICAgICAgICAgICAgKHByb3BlcnR5ICh2YWxpZC1hY2NvdW50IGFjY291bnQpKVxcbiAgICAgICAgICAgXVxcblxcbiAgICAodmFsaWRhdGUtYWNjb3VudCBhY2NvdW50KVxcblxcbiAgICAoZW5mb3JjZSAoPiBhbW91bnQgMC4wKSBcXFwiY3JlZGl0IGFtb3VudCBtdXN0IGJlIHBvc2l0aXZlXFxcIilcXG4gICAgKGVuZm9yY2UtdW5pdCBhbW91bnQpXFxuXFxuICAgIChyZXF1aXJlLWNhcGFiaWxpdHkgKENSRURJVCBhY2NvdW50KSlcXG4gICAgKHdpdGgtZGVmYXVsdC1yZWFkIGNvaW4tdGFibGUgYWNjb3VudFxcbiAgICAgIHsgXFxcImJhbGFuY2VcXFwiIDogLTEuMCwgXFxcImd1YXJkXFxcIiA6IGd1YXJkIH1cXG4gICAgICB7IFxcXCJiYWxhbmNlXFxcIiA6PSBiYWxhbmNlLCBcXFwiZ3VhcmRcXFwiIDo9IHJldGcgfVxcbiAgICAgIDsgd2UgZG9uJ3Qgd2FudCB0byBvdmVyd3JpdGUgYW4gZXhpc3RpbmcgZ3VhcmQgd2l0aCB0aGUgdXNlci1zdXBwbGllZCBvbmVcXG4gICAgICAoZW5mb3JjZSAoPSByZXRnIGd1YXJkKVxcbiAgICAgICAgXFxcImFjY291bnQgZ3VhcmRzIGRvIG5vdCBtYXRjaFxcXCIpXFxuXFxuICAgICAgKGxldCAoKGlzLW5ld1xcbiAgICAgICAgICAgICAoaWYgKD0gYmFsYW5jZSAtMS4wKVxcbiAgICAgICAgICAgICAgICAgKGVuZm9yY2UtcmVzZXJ2ZWQgYWNjb3VudCBndWFyZClcXG4gICAgICAgICAgICAgICBmYWxzZSkpKVxcblxcbiAgICAgICAgKHdyaXRlIGNvaW4tdGFibGUgYWNjb3VudFxcbiAgICAgICAgICB7IFxcXCJiYWxhbmNlXFxcIiA6IChpZiBpcy1uZXcgYW1vdW50ICgrIGJhbGFuY2UgYW1vdW50KSlcXG4gICAgICAgICAgLCBcXFwiZ3VhcmRcXFwiICAgOiByZXRnXFxuICAgICAgICAgIH0pKVxcbiAgICAgICkpXFxuXFxuICAoZGVmdW4gY2hlY2stcmVzZXJ2ZWQ6c3RyaW5nIChhY2NvdW50OnN0cmluZylcXG4gICAgXFxcIiBDaGVja3MgQUNDT1VOVCBmb3IgcmVzZXJ2ZWQgbmFtZSBhbmQgcmV0dXJucyB0eXBlIGlmIFxcXFxcXG4gICAgXFxcXCBmb3VuZCBvciBlbXB0eSBzdHJpbmcuIFJlc2VydmVkIG5hbWVzIHN0YXJ0IHdpdGggYSBcXFxcXFxuICAgIFxcXFwgc2luZ2xlIGNoYXIgYW5kIGNvbG9uLCBlLmcuICdjOmZvbycsIHdoaWNoIHdvdWxkIHJldHVybiAnYycgYXMgdHlwZS5cXFwiXFxuICAgIChsZXQgKChwZnggKHRha2UgMiBhY2NvdW50KSkpXFxuICAgICAgKGlmICg9IFxcXCI6XFxcIiAodGFrZSAtMSBwZngpKSAodGFrZSAxIHBmeCkgXFxcIlxcXCIpKSlcXG5cXG4gIChkZWZ1biBlbmZvcmNlLXJlc2VydmVkOmJvb2wgKGFjY291bnQ6c3RyaW5nIGd1YXJkOmd1YXJkKVxcbiAgICBAZG9jIFxcXCJFbmZvcmNlIHJlc2VydmVkIGFjY291bnQgbmFtZSBwcm90b2NvbHMuXFxcIlxcbiAgICAoaWYgKHZhbGlkYXRlLXByaW5jaXBhbCBndWFyZCBhY2NvdW50KVxcbiAgICAgIHRydWVcXG4gICAgICAobGV0ICgociAoY2hlY2stcmVzZXJ2ZWQgYWNjb3VudCkpKVxcbiAgICAgICAgKGlmICg9IHIgXFxcIlxcXCIpXFxuICAgICAgICAgIHRydWVcXG4gICAgICAgICAgKGlmICg9IHIgXFxcImtcXFwiKVxcbiAgICAgICAgICAgIChlbmZvcmNlIGZhbHNlIFxcXCJTaW5nbGUta2V5IGFjY291bnQgcHJvdG9jb2wgdmlvbGF0aW9uXFxcIilcXG4gICAgICAgICAgICAoZW5mb3JjZSBmYWxzZVxcbiAgICAgICAgICAgICAgKGZvcm1hdCBcXFwiUmVzZXJ2ZWQgcHJvdG9jb2wgZ3VhcmQgdmlvbGF0aW9uOiB7fVxcXCIgW3JdKSlcXG4gICAgICAgICAgICApKSkpKVxcblxcblxcbiAgKGRlZnNjaGVtYSBjcm9zc2NoYWluLXNjaGVtYVxcbiAgICBAZG9jIFxcXCJTY2hlbWEgZm9yIHlpZWxkZWQgdmFsdWUgaW4gY3Jvc3MtY2hhaW4gdHJhbnNmZXJzXFxcIlxcbiAgICByZWNlaXZlcjpzdHJpbmdcXG4gICAgcmVjZWl2ZXItZ3VhcmQ6Z3VhcmRcXG4gICAgYW1vdW50OmRlY2ltYWxcXG4gICAgc291cmNlLWNoYWluOnN0cmluZylcXG5cXG4gIChkZWZwYWN0IHRyYW5zZmVyLWNyb3NzY2hhaW46c3RyaW5nXFxuICAgICggc2VuZGVyOnN0cmluZ1xcbiAgICAgIHJlY2VpdmVyOnN0cmluZ1xcbiAgICAgIHJlY2VpdmVyLWd1YXJkOmd1YXJkXFxuICAgICAgdGFyZ2V0LWNoYWluOnN0cmluZ1xcbiAgICAgIGFtb3VudDpkZWNpbWFsIClcXG5cXG4gICAgQG1vZGVsIFsgKHByb3BlcnR5ICg-IGFtb3VudCAwLjApKVxcbiAgICAgICAgICAgICAocHJvcGVydHkgKHZhbGlkLWFjY291bnQgc2VuZGVyKSlcXG4gICAgICAgICAgICAgKHByb3BlcnR5ICh2YWxpZC1hY2NvdW50IHJlY2VpdmVyKSlcXG4gICAgICAgICAgIF1cXG5cXG4gICAgKHN0ZXBcXG4gICAgICAod2l0aC1jYXBhYmlsaXR5XFxuICAgICAgICAoVFJBTlNGRVJfWENIQUlOIHNlbmRlciByZWNlaXZlciBhbW91bnQgdGFyZ2V0LWNoYWluKVxcblxcbiAgICAgICAgKHZhbGlkYXRlLWFjY291bnQgc2VuZGVyKVxcbiAgICAgICAgKHZhbGlkYXRlLWFjY291bnQgcmVjZWl2ZXIpXFxuXFxuICAgICAgICAoZW5mb3JjZSAoIT0gXFxcIlxcXCIgdGFyZ2V0LWNoYWluKSBcXFwiZW1wdHkgdGFyZ2V0LWNoYWluXFxcIilcXG4gICAgICAgIChlbmZvcmNlICghPSAoYXQgJ2NoYWluLWlkIChjaGFpbi1kYXRhKSkgdGFyZ2V0LWNoYWluKVxcbiAgICAgICAgICBcXFwiY2Fubm90IHJ1biBjcm9zcy1jaGFpbiB0cmFuc2ZlcnMgdG8gdGhlIHNhbWUgY2hhaW5cXFwiKVxcblxcbiAgICAgICAgKGVuZm9yY2UgKD4gYW1vdW50IDAuMClcXG4gICAgICAgICAgXFxcInRyYW5zZmVyIHF1YW50aXR5IG11c3QgYmUgcG9zaXRpdmVcXFwiKVxcblxcbiAgICAgICAgKGVuZm9yY2UtdW5pdCBhbW91bnQpXFxuXFxuICAgICAgICAoZW5mb3JjZSAoY29udGFpbnMgdGFyZ2V0LWNoYWluIFZBTElEX0NIQUlOX0lEUylcXG4gICAgICAgICAgXFxcInRhcmdldCBjaGFpbiBpcyBub3QgYSB2YWxpZCBjaGFpbndlYiBjaGFpbiBpZFxcXCIpXFxuXFxuICAgICAgICA7OyBzdGVwIDEgLSBkZWJpdCBkZWxldGUtYWNjb3VudCBvbiBjdXJyZW50IGNoYWluXFxuICAgICAgICAoZGViaXQgc2VuZGVyIGFtb3VudClcXG4gICAgICAgIChlbWl0LWV2ZW50IChUUkFOU0ZFUiBzZW5kZXIgXFxcIlxcXCIgYW1vdW50KSlcXG5cXG4gICAgICAgIChsZXRcXG4gICAgICAgICAgKChjcm9zc2NoYWluLWRldGFpbHM6b2JqZWN0e2Nyb3NzY2hhaW4tc2NoZW1hfVxcbiAgICAgICAgICAgIHsgXFxcInJlY2VpdmVyXFxcIiA6IHJlY2VpdmVyXFxuICAgICAgICAgICAgLCBcXFwicmVjZWl2ZXItZ3VhcmRcXFwiIDogcmVjZWl2ZXItZ3VhcmRcXG4gICAgICAgICAgICAsIFxcXCJhbW91bnRcXFwiIDogYW1vdW50XFxuICAgICAgICAgICAgLCBcXFwic291cmNlLWNoYWluXFxcIiA6IChhdCAnY2hhaW4taWQgKGNoYWluLWRhdGEpKVxcbiAgICAgICAgICAgIH0pKVxcbiAgICAgICAgICAoeWllbGQgY3Jvc3NjaGFpbi1kZXRhaWxzIHRhcmdldC1jaGFpbilcXG4gICAgICAgICAgKSkpXFxuXFxuICAgIChzdGVwXFxuICAgICAgKHJlc3VtZVxcbiAgICAgICAgeyBcXFwicmVjZWl2ZXJcXFwiIDo9IHJlY2VpdmVyXFxuICAgICAgICAsIFxcXCJyZWNlaXZlci1ndWFyZFxcXCIgOj0gcmVjZWl2ZXItZ3VhcmRcXG4gICAgICAgICwgXFxcImFtb3VudFxcXCIgOj0gYW1vdW50XFxuICAgICAgICAsIFxcXCJzb3VyY2UtY2hhaW5cXFwiIDo9IHNvdXJjZS1jaGFpblxcbiAgICAgICAgfVxcblxcbiAgICAgICAgKGVtaXQtZXZlbnQgKFRSQU5TRkVSIFxcXCJcXFwiIHJlY2VpdmVyIGFtb3VudCkpXFxuICAgICAgICAoZW1pdC1ldmVudCAoVFJBTlNGRVJfWENIQUlOX1JFQ0QgXFxcIlxcXCIgcmVjZWl2ZXIgYW1vdW50IHNvdXJjZS1jaGFpbikpXFxuXFxuICAgICAgICA7OyBzdGVwIDIgLSBjcmVkaXQgY3JlYXRlIGFjY291bnQgb24gdGFyZ2V0IGNoYWluXFxuICAgICAgICAod2l0aC1jYXBhYmlsaXR5IChDUkVESVQgcmVjZWl2ZXIpXFxuICAgICAgICAgIChjcmVkaXQgcmVjZWl2ZXIgcmVjZWl2ZXItZ3VhcmQgYW1vdW50KSlcXG4gICAgICAgICkpXFxuICAgIClcXG5cXG5cXG4gIDsgLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS1cXG4gIDsgQ29pbiBhbGxvY2F0aW9uc1xcblxcbiAgKGRlZnNjaGVtYSBhbGxvY2F0aW9uLXNjaGVtYVxcbiAgICBAZG9jIFxcXCJHZW5lc2lzIGFsbG9jYXRpb24gcmVnaXN0cnlcXFwiXFxuICAgIDtAbW9kZWwgWyAoaW52YXJpYW50ICg-PSBiYWxhbmNlIDAuMCkpIF1cXG5cXG4gICAgYmFsYW5jZTpkZWNpbWFsXFxuICAgIGRhdGU6dGltZVxcbiAgICBndWFyZDpndWFyZFxcbiAgICByZWRlZW1lZDpib29sKVxcblxcbiAgKGRlZnRhYmxlIGFsbG9jYXRpb24tdGFibGU6e2FsbG9jYXRpb24tc2NoZW1hfSlcXG5cXG4gIChkZWZ1biBjcmVhdGUtYWxsb2NhdGlvbi1hY2NvdW50XFxuICAgICggYWNjb3VudDpzdHJpbmdcXG4gICAgICBkYXRlOnRpbWVcXG4gICAgICBrZXlzZXQtcmVmOnN0cmluZ1xcbiAgICAgIGFtb3VudDpkZWNpbWFsXFxuICAgIClcXG5cXG4gICAgQGRvYyBcXFwiQWRkIGFuIGVudHJ5IHRvIHRoZSBjb2luIGFsbG9jYXRpb24gdGFibGUuIFRoaXMgZnVuY3Rpb24gXFxcXFxcbiAgICAgICAgIFxcXFxhbHNvIGNyZWF0ZXMgYSBjb3JyZXNwb25kaW5nIGVtcHR5IGNvaW4gY29udHJhY3QgYWNjb3VudCBcXFxcXFxuICAgICAgICAgXFxcXG9mIHRoZSBzYW1lIG5hbWUgYW5kIGd1YXJkLiBSZXF1aXJlcyBHRU5FU0lTIGNhcGFiaWxpdHkuIFxcXCJcXG5cXG4gICAgQG1vZGVsIFsgKHByb3BlcnR5ICh2YWxpZC1hY2NvdW50IGFjY291bnQpKSBdXFxuXFxuICAgIChyZXF1aXJlLWNhcGFiaWxpdHkgKEdFTkVTSVMpKVxcblxcbiAgICAodmFsaWRhdGUtYWNjb3VudCBhY2NvdW50KVxcbiAgICAoZW5mb3JjZSAoPj0gYW1vdW50IDAuMClcXG4gICAgICBcXFwiYWxsb2NhdGlvbiBhbW91bnQgbXVzdCBiZSBub24tbmVnYXRpdmVcXFwiKVxcblxcbiAgICAoZW5mb3JjZS11bml0IGFtb3VudClcXG5cXG4gICAgKGxldFxcbiAgICAgICgoZ3VhcmQ6Z3VhcmQgKGtleXNldC1yZWYtZ3VhcmQga2V5c2V0LXJlZikpKVxcblxcbiAgICAgIChjcmVhdGUtYWNjb3VudCBhY2NvdW50IGd1YXJkKVxcblxcbiAgICAgIChpbnNlcnQgYWxsb2NhdGlvbi10YWJsZSBhY2NvdW50XFxuICAgICAgICB7IFxcXCJiYWxhbmNlXFxcIiA6IGFtb3VudFxcbiAgICAgICAgLCBcXFwiZGF0ZVxcXCIgOiBkYXRlXFxuICAgICAgICAsIFxcXCJndWFyZFxcXCIgOiBndWFyZFxcbiAgICAgICAgLCBcXFwicmVkZWVtZWRcXFwiIDogZmFsc2VcXG4gICAgICAgIH0pKSlcXG5cXG4gIChkZWZ1biByZWxlYXNlLWFsbG9jYXRpb25cXG4gICAgKCBhY2NvdW50OnN0cmluZyApXFxuXFxuICAgIEBkb2MgXFxcIlJlbGVhc2UgZnVuZHMgYXNzb2NpYXRlZCB3aXRoIGFsbG9jYXRpb24gQUNDT1VOVCBpbnRvIG1haW4gbGVkZ2VyLiAgIFxcXFxcXG4gICAgICAgICBcXFxcQUNDT1VOVCBtdXN0IGFscmVhZHkgZXhpc3QgaW4gbWFpbiBsZWRnZXIuIEFsbG9jYXRpb24gaXMgZGVhY3RpdmF0ZWQgXFxcXFxcbiAgICAgICAgIFxcXFxhZnRlciByZWxlYXNlLlxcXCJcXG4gICAgQG1vZGVsIFsgKHByb3BlcnR5ICh2YWxpZC1hY2NvdW50IGFjY291bnQpKSBdXFxuXFxuICAgICh2YWxpZGF0ZS1hY2NvdW50IGFjY291bnQpXFxuXFxuICAgICh3aXRoLXJlYWQgYWxsb2NhdGlvbi10YWJsZSBhY2NvdW50XFxuICAgICAgeyBcXFwiYmFsYW5jZVxcXCIgOj0gYmFsYW5jZVxcbiAgICAgICwgXFxcImRhdGVcXFwiIDo9IHJlbGVhc2UtdGltZVxcbiAgICAgICwgXFxcInJlZGVlbWVkXFxcIiA6PSByZWRlZW1lZFxcbiAgICAgICwgXFxcImd1YXJkXFxcIiA6PSBndWFyZFxcbiAgICAgIH1cXG5cXG4gICAgICAobGV0ICgoY3Vyci10aW1lOnRpbWUgKGF0ICdibG9jay10aW1lIChjaGFpbi1kYXRhKSkpKVxcblxcbiAgICAgICAgKGVuZm9yY2UgKG5vdCByZWRlZW1lZClcXG4gICAgICAgICAgXFxcImFsbG9jYXRpb24gZnVuZHMgaGF2ZSBhbHJlYWR5IGJlZW4gcmVkZWVtZWRcXFwiKVxcblxcbiAgICAgICAgKGVuZm9yY2VcXG4gICAgICAgICAgKD49IGN1cnItdGltZSByZWxlYXNlLXRpbWUpXFxuICAgICAgICAgIChmb3JtYXQgXFxcImZ1bmRzIGxvY2tlZCB1bnRpbCB7fS4gY3VycmVudCB0aW1lOiB7fVxcXCIgW3JlbGVhc2UtdGltZSBjdXJyLXRpbWVdKSlcXG5cXG4gICAgICAgICh3aXRoLWNhcGFiaWxpdHkgKFJFTEVBU0VfQUxMT0NBVElPTiBhY2NvdW50IGJhbGFuY2UpXFxuXFxuICAgICAgICAoZW5mb3JjZS1ndWFyZCBndWFyZClcXG5cXG4gICAgICAgICh3aXRoLWNhcGFiaWxpdHkgKENSRURJVCBhY2NvdW50KVxcbiAgICAgICAgICAoZW1pdC1ldmVudCAoVFJBTlNGRVIgXFxcIlxcXCIgYWNjb3VudCBiYWxhbmNlKSlcXG4gICAgICAgICAgKGNyZWRpdCBhY2NvdW50IGd1YXJkIGJhbGFuY2UpXFxuXFxuICAgICAgICAgICh1cGRhdGUgYWxsb2NhdGlvbi10YWJsZSBhY2NvdW50XFxuICAgICAgICAgICAgeyBcXFwicmVkZWVtZWRcXFwiIDogdHJ1ZVxcbiAgICAgICAgICAgICwgXFxcImJhbGFuY2VcXFwiIDogMC4wXFxuICAgICAgICAgICAgfSlcXG5cXG4gICAgICAgICAgXFxcIkFsbG9jYXRpb24gc3VjY2Vzc2Z1bGx5IHJlbGVhc2VkIHRvIG1haW4gbGVkZ2VyXFxcIikpXFxuICAgICkpKVxcblxcbilcXG5cXG4oY3JlYXRlLXRhYmxlIGNvaW4tdGFibGUpXFxuKGNyZWF0ZS10YWJsZSBhbGxvY2F0aW9uLXRhYmxlKVxcblwifX0sXCJzaWduZXJzXCI6W10sXCJtZXRhXCI6e1wiY3JlYXRpb25UaW1lXCI6MCxcInR0bFwiOjE3MjgwMCxcImdhc0xpbWl0XCI6MCxcImNoYWluSWRcIjpcIlwiLFwiZ2FzUHJpY2VcIjowLFwic2VuZGVyXCI6XCJcIn0sXCJub25jZVwiOlwiY29pbi1jb250cmFjdC12Ni1pbnN0YWxsXCJ9In0", unsafeFromText "eyJnYXMiOjAsInJlc3VsdCI6eyJzdGF0dXMiOiJzdWNjZXNzIiwiZGF0YSI6IlRhYmxlQ3JlYXRlZCJ9LCJyZXFLZXkiOiJHUklRdTRoQUtrMElEOUY4el8tMHlYeUFLSjMzTVB5VFlNWE9qbFBKbXBJIiwibG9ncyI6IlV5bUQ3bm5GUWZTMGF5aUVNT3RuWEdKWDhpbGpYX3JnQzdPbENMdHhZVEEiLCJtZXRhRGF0YSI6bnVsbCwiY29udGludWF0aW9uIjpudWxsLCJ0eElkIjozfQ") - , (unsafeFromText "eyJoYXNoIjoiU0IzVzVFTGl6azl4elNWWk9MX3dsem5VNjh5aUhPQzlwWUhreHBVXzBnbyIsInNpZ3MiOltdLCJjbWQiOiJ7XCJuZXR3b3JrSWRcIjpudWxsLFwicGF5bG9hZFwiOntcImV4ZWNcIjp7XCJkYXRhXCI6bnVsbCxcImNvZGVcIjpcIihpbnRlcmZhY2UgZ2FzLXBheWVyLXYxXFxuXFxuICAoZGVmY2FwIEdBU19QQVlFUjpib29sXFxuICAgICggdXNlcjpzdHJpbmdcXG4gICAgICBsaW1pdDppbnRlZ2VyXFxuICAgICAgcHJpY2U6ZGVjaW1hbFxcbiAgICApXFxuICAgIEBkb2NcXG4gICAgXFxcIiBQcm92aWRlIGEgY2FwYWJpbGl0eSBpbmRpY2F0aW5nIHRoYXQgZGVjbGFyaW5nIG1vZHVsZSBzdXBwb3J0cyBcXFxcXFxuICAgIFxcXFwgZ2FzIHBheW1lbnQgZm9yIFVTRVIgZm9yIGdhcyBMSU1JVCBhbmQgUFJJQ0UuIEZ1bmN0aW9uYWxpdHkgXFxcXFxcbiAgICBcXFxcIHNob3VsZCByZXF1aXJlIGNhcGFiaWxpdHkgKGNvaW4uRlVORF9UWCksIGFuZCBzaG91bGQgdmFsaWRhdGUgXFxcXFxcbiAgICBcXFxcIHRoZSBzcGVuZCBvZiAobGltaXQgKiBwcmljZSksIHBvc3NpYmx5IHVwZGF0aW5nIHNvbWUgZGF0YWJhc2UgXFxcXFxcbiAgICBcXFxcIGVudHJ5LiBcXFxcXFxuICAgIFxcXFwgU2hvdWxkIGNvbXBvc2UgY2FwYWJpbGl0eSByZXF1aXJlZCBmb3IgJ2NyZWF0ZS1nYXMtcGF5ZXItZ3VhcmQnLlxcXCJcXG4gICAgQG1vZGVsXFxuICAgIFsgKHByb3BlcnR5ICh1c2VyICE9IFxcXCJcXFwiKSlcXG4gICAgICAocHJvcGVydHkgKGxpbWl0ID4gMCkpXFxuICAgICAgKHByb3BlcnR5IChwcmljZSA-IDAuMCkpXFxuICAgIF1cXG4gIClcXG5cXG4gIChkZWZ1biBjcmVhdGUtZ2FzLXBheWVyLWd1YXJkOmd1YXJkICgpXFxuICAgIEBkb2NcXG4gICAgXFxcIiBQcm92aWRlIGEgZ3VhcmQgc3VpdGFibGUgZm9yIGNvbnRyb2xsaW5nIGEgY29pbiBhY2NvdW50IHRoYXQgY2FuIFxcXFxcXG4gICAgXFxcXCBwYXkgZ2FzIHZpYSBHQVNfUEFZRVIgbWVjaGFuaWNzLiBHZW5lcmFsbHkgdGhpcyBpcyBhY2NvbXBsaXNoZWQgXFxcXFxcbiAgICBcXFxcIGJ5IGhhdmluZyBHQVNfUEFZRVIgY29tcG9zZSBhbiB1bnBhcmFtZXRlcml6ZWQsIHVubWFuYWdlZCBjYXBhYmlsaXR5IFxcXFxcXG4gICAgXFxcXCB0aGF0IGlzIHJlcXVpcmVkIGluIHRoaXMgZ3VhcmQuIFRodXMsIGlmIGNvaW4gY29udHJhY3QgaXMgYWJsZSB0byBcXFxcXFxuICAgIFxcXFwgc3VjY2Vzc2Z1bGx5IGFjcXVpcmUgR0FTX1BBWUVSLCB0aGUgY29tcG9zZWQgJ2Fub255bW91cycgY2FwIHJlcXVpcmVkIFxcXFxcXG4gICAgXFxcXCBoZXJlIHdpbGwgYmUgaW4gc2NvcGUsIGFuZCBnYXMgYnV5IHdpbGwgc3VjY2VlZC5cXFwiXFxuICApXFxuXFxuKVxcblwifX0sXCJzaWduZXJzXCI6W10sXCJtZXRhXCI6e1wiY3JlYXRpb25UaW1lXCI6MCxcInR0bFwiOjE3MjgwMCxcImdhc0xpbWl0XCI6MCxcImNoYWluSWRcIjpcIlwiLFwiZ2FzUHJpY2VcIjowLFwic2VuZGVyXCI6XCJcIn0sXCJub25jZVwiOlwiZ2VuZXNpcy0wMVwifSJ9", unsafeFromText "eyJnYXMiOjAsInJlc3VsdCI6eyJzdGF0dXMiOiJzdWNjZXNzIiwiZGF0YSI6IkxvYWRlZCBpbnRlcmZhY2UgZ2FzLXBheWVyLXYxIn0sInJlcUtleSI6IlNCM1c1RUxpems5eHpTVlpPTF93bHpuVTY4eWlIT0M5cFlIa3hwVV8wZ28iLCJsb2dzIjoiZlZuSFlta19QNmJSY3VjeVg1RDdLamNLYkVsVDlEcU9vZW9yUFEtUXdsMCIsIm1ldGFEYXRhIjpudWxsLCJjb250aW51YXRpb24iOm51bGwsInR4SWQiOjR9") - , (unsafeFromText "eyJoYXNoIjoiQ1pteWxXZmllUk1CTXU1dzJFT21wRndLLXQ3YmNPVHM0bUsyYVQzM3VSNCIsInNpZ3MiOltdLCJjbWQiOiJ7XCJuZXR3b3JrSWRcIjpudWxsLFwicGF5bG9hZFwiOntcImV4ZWNcIjp7XCJkYXRhXCI6e1wibnMtYWRtaW4ta2V5c2V0XCI6W1wiMzY4ODIwZjgwYzMyNGJiYzdjMmIwNjEwNjg4YTdkYTQzZTM5ZjkxZDExODczMjY3MWNkOWM3NTAwZmY0M2NjYVwiXSxcIm5zLW9wZXJhdGUta2V5c2V0XCI6W1wiMzY4ODIwZjgwYzMyNGJiYzdjMmIwNjEwNjg4YTdkYTQzZTM5ZjkxZDExODczMjY3MWNkOWM3NTAwZmY0M2NjYVwiXSxcIm5zLWdlbmVzaXMta2V5c2V0XCI6e1wicHJlZFwiOlwiPVwiLFwia2V5c1wiOltdfX0sXCJjb2RlXCI6XCIoZGVmaW5lLWtleXNldCAnbnMtYWRtaW4ta2V5c2V0IChyZWFkLWtleXNldCAnbnMtYWRtaW4ta2V5c2V0KSlcXG4oZGVmaW5lLWtleXNldCAnbnMtb3BlcmF0ZS1rZXlzZXQgKHJlYWQta2V5c2V0ICducy1nZW5lc2lzLWtleXNldCkpXFxuXFxuKG1vZHVsZSBucyBHT1ZFUk5BTkNFXFxuICBcXFwiQWRtaW5pc3RlcnMgZGVmaW5pdGlvbiBvZiBuZXcgbmFtZXNwYWNlcyBpbiBDaGFpbndlYi5cXFwiXFxuXFxuICAoZGVmc2NoZW1hIHJlZy1lbnRyeVxcbiAgICBhZG1pbi1ndWFyZDpndWFyZFxcbiAgICBhY3RpdmU6Ym9vbClcXG5cXG4gIChkZWZ0YWJsZSByZWdpc3RyeTp7cmVnLWVudHJ5fSlcXG5cXG4gIChkZWZjYXAgR09WRVJOQU5DRSAoKVxcbiAgICAoZW5mb3JjZS1rZXlzZXQgJ25zLWFkbWluLWtleXNldCkpXFxuXFxuICAoZGVmY2FwIE9QRVJBVEUgKClcXG4gICAgKGVuZm9yY2Uta2V5c2V0ICducy1vcGVyYXRlLWtleXNldCkpXFxuXFxuICAoZGVmY29uc3QgR1VBUkRfU1VDQ0VTUyAoY3JlYXRlLXVzZXItZ3VhcmQgKHN1Y2Nlc3MpKSlcXG4gIChkZWZjb25zdCBHVUFSRF9GQUlMVVJFIChjcmVhdGUtdXNlci1ndWFyZCAoZmFpbHVyZSkpKVxcblxcbiAgKGRlZnVuIHN1Y2Nlc3MgKClcXG4gICAgdHJ1ZSlcXG4gIChkZWZ1biBmYWlsdXJlICgpXFxuICAgIChlbmZvcmNlIGZhbHNlIFxcXCJEaXNhYmxlZFxcXCIpKVxcblxcbiAgKGRlZnVuIHZhbGlkYXRlLW5hbWUgKG5hbWUpXFxuICAgIChlbmZvcmNlICghPSBcXFwiXFxcIiBuYW1lKSBcXFwiRW1wdHkgbmFtZSBub3QgYWxsb3dlZFxcXCIpXFxuICAgIChlbmZvcmNlICg8IChsZW5ndGggbmFtZSkgNjQpIFxcXCJOYW1lIG11c3QgYmUgbGVzcyB0aGFuIDY0IGNoYXJhY3RlcnMgbG9uZ1xcXCIpXFxuICAgIChlbmZvcmNlIChpcy1jaGFyc2V0IENIQVJTRVRfTEFUSU4xIG5hbWUpXFxuICAgICAgICAgICAgIFxcXCJOYW1lIG11c3QgYmUgaW4gbGF0aW4xIGNoYXJzZXRcXFwiKSlcXG5cXG4gIChkZWZ1biBjcmVhdGUtcHJpbmNpcGFsLW5hbWVzcGFjZTpzdHJpbmdcXG4gICAgICAoIGc6Z3VhcmRcXG4gICAgICAgIClcXG4gICAgXFxcIiBGb3JtYXQgcHJpbmNpcGFsIG5hbWVzcGFjZSBhcyBQYWN0IGhhc2ggKEJMQUtFMmIyNTYpIG9mIHByaW5jaXBhbCBcXFxcXFxuICAgIFxcXFwgaW4gaGV4IHRydW5jYXRlZCB0byAxNjAgYml0cyAoNDAgY2hhcmFjdGVycyksIHByZXBlbmRlZCB3aXRoICduXycuXFxcXFxcbiAgICBcXFxcIE9ubHkgdzogYW5kIGs6IGFjY291bnQgcHJvdG9jb2xzIGFyZSBzdXBwb3J0ZWQuIFxcXCJcXG5cXG4gICAgKGxldFxcbiAgICAgICgodHkgKHR5cGVvZi1wcmluY2lwYWwgKGNyZWF0ZS1wcmluY2lwYWwgZykpKSlcXG5cXG4gICAgICA7OyBvbmx5IHc6IGFuZCBrOiBjdXJyZW50bHkgc3VwcG9ydGVkXFxuICAgICAgKGlmIChvciAoPSB0eSBcXFwiazpcXFwiKSAoPSB0eSBcXFwidzpcXFwiKSlcXG4gICAgICAgICgrIFxcXCJuX1xcXCIgKHRha2UgNDAgKGludC10by1zdHIgMTYgKHN0ci10by1pbnQgNjQgKGhhc2ggZykpKSkpXFxuICAgICAgICAoZW5mb3JjZSBmYWxzZVxcbiAgICAgICAgICAoZm9ybWF0IFxcXCJVbnN1cHBvcnRlZCBndWFyZCBwcm90b2NvbDoge31cXFwiIFt0eV0pKVxcbiAgICAgICAgKSlcXG4gIClcXG5cXG4gIChkZWZ1biB2YWxpZGF0ZTpib29sXFxuICAgICAgKCBucy1uYW1lOnN0cmluZ1xcbiAgICAgICAgbnMtYWRtaW46Z3VhcmRcXG4gICAgICAgIClcXG4gICAgXFxcIiBNYW5hZ2VzIG5hbWVzcGFjZSBpbnN0YWxsIGZvciBDaGFpbndlYi4gXFxcXFxcbiAgICBcXFxcIEFsbG93cyBwcmluY2lwYWwgbmFtZXNwYWNlcy4gXFxcXFxcbiAgICBcXFxcIE5vbi1wcmluY2lwYWwgbmFtZXNwYWNlcyByZXF1aXJlIGFjdGl2ZSByb3cgaW4gcmVnaXN0cnkgXFxcXFxcbiAgICBcXFxcIGZvciBOUy1OQU1FIHdpdGggZ3VhcmQgbWF0Y2hpbmcgTlMtQURNSU4uXFxcIlxcblxcbiAgICAoaWYgKD0gKGNyZWF0ZS1wcmluY2lwYWwtbmFtZXNwYWNlIG5zLWFkbWluKSBucy1uYW1lKVxcblxcbiAgICAgIHRydWUgOzsgYWxsb3cgcHJpbmNpcGFsIG5hbWVzcGFjZXNcXG5cXG4gICAgICAod2l0aC1kZWZhdWx0LXJlYWQgcmVnaXN0cnkgbnMtbmFtZSAgICAgICA7OyBvdGhlcndpc2UgZW5mb3JjZSByZWdpc3RyeVxcbiAgICAgICAgeyAnYWRtaW4tZ3VhcmQgOiBucy1hZG1pblxcbiAgICAgICAgLCAnYWN0aXZlIDogZmFsc2UgfVxcbiAgICAgICAgeyAnYWRtaW4tZ3VhcmQgOj0gYWdcXG4gICAgICAgICwgJ2FjdGl2ZSA6PSBpcy1hY3RpdmUgfVxcblxcbiAgICAgICAgKGVuZm9yY2UgaXMtYWN0aXZlIFxcXCJJbmFjdGl2ZSBvciB1bnJlZ2lzdGVyZWQgbmFtZXNwYWNlXFxcIilcXG4gICAgICAgIChlbmZvcmNlICg9IG5zLWFkbWluIGFnKSBcXFwiQWRtaW4gZ3VhcmQgbXVzdCBtYXRjaCBndWFyZCBpbiByZWdpc3RyeVxcXCIpXFxuXFxuICAgICAgICB0cnVlKVxcbiAgICAgICkpXFxuXFxuICAoZGVmdW4gd3JpdGUtcmVnaXN0cnk6c3RyaW5nXFxuICAgICAgKCBucy1uYW1lOnN0cmluZ1xcbiAgICAgICAgZ3VhcmQ6Z3VhcmRcXG4gICAgICAgIGFjdGl2ZTpib29sXFxuICAgICAgICApXFxuICAgIFxcXCIgV3JpdGUgZW50cnkgd2l0aCBHVUFSRCBhbmQgQUNUSVZFIGludG8gcmVnaXN0cnkgZm9yIE5BTUUuIFxcXFxcXG4gICAgXFxcXCBHdWFyZGVkIGJ5IG9wZXJhdGUga2V5c2V0LiBcXFwiXFxuXFxuICAgICh3aXRoLWNhcGFiaWxpdHkgKE9QRVJBVEUpXFxuXFxuICAgICAgKHZhbGlkYXRlLW5hbWUgbnMtbmFtZSlcXG5cXG4gICAgICAod3JpdGUgcmVnaXN0cnkgbnMtbmFtZVxcbiAgICAgICAgeyAnYWRtaW4tZ3VhcmQ6IGd1YXJkXFxuICAgICAgICAsICdhY3RpdmU6IGFjdGl2ZSB9KVxcblxcbiAgICAgIFxcXCJSZWdpc3RlciBlbnRyeSB3cml0dGVuXFxcIikpXFxuXFxuICAoZGVmdW4gcXVlcnk6b2JqZWN0e3JlZy1lbnRyeX1cXG4gICAgICAoIG5zLW5hbWU6c3RyaW5nIClcXG4gICAgKHJlYWQgcmVnaXN0cnkgbnMtbmFtZSkpXFxuXFxuKVxcblxcbihjcmVhdGUtdGFibGUgcmVnaXN0cnkpXFxuXFxuKHdyaXRlLXJlZ2lzdHJ5IFxcXCJrYWRlbmFcXFwiXFxuICAoa2V5c2V0LXJlZi1ndWFyZCAnbnMtb3BlcmF0ZS1rZXlzZXQpIHRydWUpXFxuKHdyaXRlLXJlZ2lzdHJ5IFxcXCJ1c2VyXFxcIiBHVUFSRF9GQUlMVVJFIHRydWUpXFxuKHdyaXRlLXJlZ2lzdHJ5IFxcXCJmcmVlXFxcIiBHVUFSRF9GQUlMVVJFIHRydWUpXFxuXFxuKGRlZmluZS1uYW1lc3BhY2UgXFxcImthZGVuYVxcXCJcXG4gIChrZXlzZXQtcmVmLWd1YXJkICducy1vcGVyYXRlLWtleXNldClcXG4gIChrZXlzZXQtcmVmLWd1YXJkICducy1vcGVyYXRlLWtleXNldCkpXFxuXFxuKGRlZmluZS1uYW1lc3BhY2UgXFxcInVzZXJcXFwiIEdVQVJEX1NVQ0NFU1MgR1VBUkRfRkFJTFVSRSlcXG4oZGVmaW5lLW5hbWVzcGFjZSBcXFwiZnJlZVxcXCIgR1VBUkRfU1VDQ0VTUyBHVUFSRF9GQUlMVVJFKVxcbjs7cm90YXRlIHRvIHJlYWwgb3BlcmF0ZSBrZXlzZXRcXG4oZGVmaW5lLWtleXNldCAnbnMtb3BlcmF0ZS1rZXlzZXQgKHJlYWQta2V5c2V0ICducy1vcGVyYXRlLWtleXNldCkpXFxuXCJ9fSxcInNpZ25lcnNcIjpbXSxcIm1ldGFcIjp7XCJjcmVhdGlvblRpbWVcIjowLFwidHRsXCI6MTcyODAwLFwiZ2FzTGltaXRcIjowLFwiY2hhaW5JZFwiOlwiXCIsXCJnYXNQcmljZVwiOjAsXCJzZW5kZXJcIjpcIlwifSxcIm5vbmNlXCI6XCJsb2FkLW5zLWRldm5ldC1zZW5kZXIwMFwifSJ9", unsafeFromText "eyJnYXMiOjAsInJlc3VsdCI6eyJzdGF0dXMiOiJzdWNjZXNzIiwiZGF0YSI6IktleXNldCBkZWZpbmVkIn0sInJlcUtleSI6IkNabXlsV2ZpZVJNQk11NXcyRU9tcEZ3Sy10N2JjT1RzNG1LMmFUMzN1UjQiLCJsb2dzIjoiNHlRZEx6VWU5QUttdko3cnhEdkJtUnVIZjVic0lvSjNBMjZCaGdicl9NOCIsIm1ldGFEYXRhIjpudWxsLCJjb250aW51YXRpb24iOm51bGwsInR4SWQiOjV9") - , (unsafeFromText "eyJoYXNoIjoiWE5BNmxPSjFXLTdYWXY1WWI0QXFsNzRveFlJN09KcWpPUVQ1b1k0OHEtZyIsInNpZ3MiOltdLCJjbWQiOiJ7XCJuZXR3b3JrSWRcIjpudWxsLFwicGF5bG9hZFwiOntcImV4ZWNcIjp7XCJkYXRhXCI6e1wiYWxsb2NhdGlvbi10ZXN0MDFcIjpbXCI3MDExYzM3OTE0MGZmODk5ZjdlNjEzYWMwYTk3ODRhN2MwYTUxNWQzMGZlMGFiMmIwYzA3ZTVhYTE3NjM1ZTNlXCJdLFwiYWxsb2NhdGlvbjAyXCI6W1wiZTllNGU3MWJkMDYzZGNmN2UwNmJkNWIxYTE2Njg4ODk3ZDE1Y2E4YmQyZTUwOWM0NTNjNjE2MjE5YzE4NmNjNVwiXSxcImFsbG9jYXRpb24wMFwiOltcImQ4MmQwZGNkZTk4MjU1MDVkODZhZmI2ZGNjMTA0MTFkNmI2N2E0MjlhNzllMjFiZGE0YmIxMTliZjI4YWI4NzFcIl0sXCJhbGxvY2F0aW9uLXRlc3QwMlwiOltcIjA2NTQ0ZTIyYmZlZjIzMGQ2ZDIyZjk0ODZhYzZjYjc2YmYyNThlYmZiZjAxMzdlZTU4ZjY1NzQzZTFhNWI4YzRcIl0sXCJhbGxvY2F0aW9uMDFcIjpbXCJiNGM4YTNlYTkxZDMxNDZiMDU2MDk5NDc0MGYwZTNlZWQ5MWM1OWQyZWVjYTFkYzk5ZjBjMjg3Mjg0NWMyOTRkXCJdfSxcImNvZGVcIjpcIihkZWZpbmUta2V5c2V0IFxcXCJhbGxvY2F0aW9uMDBcXFwiIChyZWFkLWtleXNldCBcXFwiYWxsb2NhdGlvbjAwXFxcIikpXFxuKGRlZmluZS1rZXlzZXQgXFxcImFsbG9jYXRpb24wMVxcXCIgKHJlYWQta2V5c2V0IFxcXCJhbGxvY2F0aW9uMDFcXFwiKSlcXG4oZGVmaW5lLWtleXNldCBcXFwiYWxsb2NhdGlvbjAyXFxcIiAocmVhZC1rZXlzZXQgXFxcImFsbG9jYXRpb24wMlxcXCIpKVxcbihkZWZpbmUta2V5c2V0IFxcXCJhbGxvY2F0aW9uLXRlc3QwMVxcXCIgKHJlYWQta2V5c2V0IFxcXCJhbGxvY2F0aW9uLXRlc3QwMVxcXCIpKVxcbihkZWZpbmUta2V5c2V0IFxcXCJhbGxvY2F0aW9uLXRlc3QwMlxcXCIgKHJlYWQta2V5c2V0IFxcXCJhbGxvY2F0aW9uLXRlc3QwMlxcXCIpKVwifX0sXCJzaWduZXJzXCI6W10sXCJtZXRhXCI6e1wiY3JlYXRpb25UaW1lXCI6MCxcInR0bFwiOjE3MjgwMCxcImdhc0xpbWl0XCI6MCxcImNoYWluSWRcIjpcIlwiLFwiZ2FzUHJpY2VcIjowLFwic2VuZGVyXCI6XCJcIn0sXCJub25jZVwiOlwiZGV2bmV0LWtleXNldHNcIn0ifQ", unsafeFromText "eyJnYXMiOjAsInJlc3VsdCI6eyJzdGF0dXMiOiJzdWNjZXNzIiwiZGF0YSI6IktleXNldCBkZWZpbmVkIn0sInJlcUtleSI6IlhOQTZsT0oxVy03WFl2NVliNEFxbDc0b3hZSTdPSnFqT1FUNW9ZNDhxLWciLCJsb2dzIjoiU0t3RUk1NWN4M2pMdU16RWRZQ1NtZ1RSRWhmVjg2alQwVjd3WVdvZWxfQSIsIm1ldGFEYXRhIjpudWxsLCJjb250aW51YXRpb24iOm51bGwsInR4SWQiOjZ9") - , (unsafeFromText "eyJoYXNoIjoiNWtxZ0tzWWtwbjZCcS1KUnhNYnA1VG9jUWhRWGRJVVNiM1NGQm1Ba3VWcyIsInNpZ3MiOltdLCJjbWQiOiJ7XCJuZXR3b3JrSWRcIjpudWxsLFwicGF5bG9hZFwiOntcImV4ZWNcIjp7XCJkYXRhXCI6bnVsbCxcImNvZGVcIjpcIihjb2luLmNyZWF0ZS1hbGxvY2F0aW9uLWFjY291bnQgXFxcImFsbG9jYXRpb24wMFxcXCIgKHRpbWUgXFxcIjE5MDAtMTAtMTVUMTg6MDA6MDBaXFxcIikgXFxcImFsbG9jYXRpb24wMFxcXCIgMTAwMDAwMC4wKVxcbihjb2luLmNyZWF0ZS1hbGxvY2F0aW9uLWFjY291bnQgXFxcImFsbG9jYXRpb24wMVxcXCIgKHRpbWUgXFxcIjIxMDAtMTAtMzFUMTg6MDA6MDBaXFxcIikgXFxcImFsbG9jYXRpb24wMVxcXCIgMTAwMDAwMC4wKVxcbihjb2luLmNyZWF0ZS1hbGxvY2F0aW9uLWFjY291bnQgXFxcImFsbG9jYXRpb24wMlxcXCIgKHRpbWUgXFxcIjE5MDAtMTAtMzFUMTg6MDA6MDBaXFxcIikgXFxcImFsbG9jYXRpb24wMlxcXCIgMTAwMDAwMC4wKVxcbihjb2luLmNyZWF0ZS1hbGxvY2F0aW9uLWFjY291bnQgXFxcImFsbG9jYXRpb24tdGVzdDAxXFxcIiAodGltZSBcXFwiMTkwMC0xMC0zMVQxODowMDowMFpcXFwiKSBcXFwiYWxsb2NhdGlvbi10ZXN0MDFcXFwiIDEwMDAwMDAuMClcXG4oY29pbi5jcmVhdGUtYWxsb2NhdGlvbi1hY2NvdW50IFxcXCJhbGxvY2F0aW9uLXRlc3QwMlxcXCIgKHRpbWUgXFxcIjE5MDAtMTAtMzFUMTg6MDA6MDBaXFxcIikgXFxcImFsbG9jYXRpb24tdGVzdDAyXFxcIiAyMDAwMDAwLjApXCJ9fSxcInNpZ25lcnNcIjpbXSxcIm1ldGFcIjp7XCJjcmVhdGlvblRpbWVcIjowLFwidHRsXCI6MTcyODAwLFwiZ2FzTGltaXRcIjowLFwiY2hhaW5JZFwiOlwiXCIsXCJnYXNQcmljZVwiOjAsXCJzZW5kZXJcIjpcIlwifSxcIm5vbmNlXCI6XCJkZXZuZXQtYWxsb2NhdGlvbnNcIn0ifQ", unsafeFromText "eyJnYXMiOjAsInJlc3VsdCI6eyJzdGF0dXMiOiJzdWNjZXNzIiwiZGF0YSI6IldyaXRlIHN1Y2NlZWRlZCJ9LCJyZXFLZXkiOiI1a3FnS3NZa3BuNkJxLUpSeE1icDVUb2NRaFFYZElVU2IzU0ZCbUFrdVZzIiwibG9ncyI6IkRTeVFBWXBXSW9OazlOSUFNaTgzODRBTDhnSU9LRzc2Y1FaMzZNaGtkOGciLCJtZXRhRGF0YSI6bnVsbCwiY29udGludWF0aW9uIjpudWxsLCJ0eElkIjo3fQ") - , (unsafeFromText "eyJoYXNoIjoiY2tiMmZnNWVJeXRoS3U5YVN3TkhIWllsWVY2V1R1NGlYaUZDamc5WFFLWSIsInNpZ3MiOltdLCJjbWQiOiJ7XCJuZXR3b3JrSWRcIjpudWxsLFwicGF5bG9hZFwiOntcImV4ZWNcIjp7XCJkYXRhXCI6e1wic2VuZGVyMDdcIjpbXCI0YzMxZGM5ZWU3ZjI0MTc3Zjc4YjZmNTE4MDEyYTIwODMyNmUyYWYxZjM3YmIwYTI0MDViNTA1NmQwY2FkNjI4XCJdLFwic2VuZGVyMDFcIjpbXCI2YmUyZjQ4NWE3YWY3NWZlZGI0YjdmMTUzYTkwM2Y3ZTYwMDBjYTRhYTUwMTE3OWM5MWEyNDUwYjc3N2JkMmE3XCJdLFwic2VuZGVyMDZcIjpbXCI1ZmZjMWY3ZmVmN2E0NDczODYyNTc2MmY3NWE0MjI5NDU0OTUxZTAzZjJhZmM2ZjgxMzA5YzBjMWJkZjllZTZmXCJdLFwic2VuZGVyMDBcIjpbXCIzNjg4MjBmODBjMzI0YmJjN2MyYjA2MTA2ODhhN2RhNDNlMzlmOTFkMTE4NzMyNjcxY2Q5Yzc1MDBmZjQzY2NhXCJdLFwiZTdmN1wiOltcImU3Zjc2MzRlOTI1NTQxZjM2OGI4MjdhZDVjNzI0MjE5MDUxMDBmNjIwNTI4NWE3OGMxOWQ3YjRhMzg3MTE4MDVcIl0sXCJzZW5kZXIwNVwiOltcImYwOWQ4ZjYzOTRhZWE0MjVmZTY3ODNkODhjZDgxMzYzZDgwMTdmMTZhZmQzNzExYzU3NWJlMGY1Y2Q1YzliYjlcIl0sXCJzZW5kZXIwNFwiOltcIjJkNzBhYTRmNjk3YzNhM2I4ZGQ2ZDk3NzQ1YWMwNzRlZGNmZDBlYjY1YzM3Nzc0Y2RlMjUxMzU0ODNiZWE3MWVcIl0sXCJtdWx0aS0wMi0wMy0wNC1hbnlcIjp7XCJwcmVkXCI6XCJrZXlzLWFueVwiLFwia2V5c1wiOltcIjNhOWRkNTMyZDczZGFjZTE5NWRiYjY0ZDFkYmE2NTcyZmI3ODNkMGZkZDMyNDY4NWUzMmZiZGEyZjg5Zjk5YTZcIixcIjQzZjJhZGIxZGUxOTIwMDBjYjM3NzdiYWNjN2Y5ODNiNjYxNGZkOWMxNzE1Y2Q0NGNkNDg0YjZkM2EwZDM0YzhcIixcIjJkNzBhYTRmNjk3YzNhM2I4ZGQ2ZDk3NzQ1YWMwNzRlZGNmZDBlYjY1YzM3Nzc0Y2RlMjUxMzU0ODNiZWE3MWVcIl19LFwic2VuZGVyMDlcIjpbXCJjNTlkOTg0MGIwYjY2MDkwODM2NTQ2YjdlYjRhNzM2MDYyNTc1MjdlYzhjMmI0ODIzMDBmZDIyOTI2NGIwN2U2XCJdLFwic2VuZGVyMDNcIjpbXCI0M2YyYWRiMWRlMTkyMDAwY2IzNzc3YmFjYzdmOTgzYjY2MTRmZDljMTcxNWNkNDRjZDQ4NGI2ZDNhMGQzNGM4XCJdLFwibXVsdGktMDAtMDFcIjpbXCIzNjg4MjBmODBjMzI0YmJjN2MyYjA2MTA2ODhhN2RhNDNlMzlmOTFkMTE4NzMyNjcxY2Q5Yzc1MDBmZjQzY2NhXCIsXCI2YmUyZjQ4NWE3YWY3NWZlZGI0YjdmMTUzYTkwM2Y3ZTYwMDBjYTRhYTUwMTE3OWM5MWEyNDUwYjc3N2JkMmE3XCJdLFwic2VuZGVyMDhcIjpbXCI2M2IyZWJhNGVkNzBkNDYxMmQzZTdiYzkwZGIyZmJmNGM3NmY3YjA3NDM2M2U4NmQ3M2YwYmM2MTdmOGU4YjgxXCJdLFwic2VuZGVyMDJcIjpbXCIzYTlkZDUzMmQ3M2RhY2UxOTVkYmI2NGQxZGJhNjU3MmZiNzgzZDBmZGQzMjQ2ODVlMzJmYmRhMmY4OWY5OWE2XCJdfSxcImNvZGVcIjpcIihjb2luLmNvaW5iYXNlIFxcXCJzZW5kZXIwMFxcXCIgKHJlYWQta2V5c2V0IFxcXCJzZW5kZXIwMFxcXCIpIDEwMDAwMDAwMC4wKVxcbihjb2luLmNvaW5iYXNlIFxcXCJzZW5kZXIwMVxcXCIgKHJlYWQta2V5c2V0IFxcXCJzZW5kZXIwMVxcXCIpIDExMDAwMDAwMC4wKVxcbihjb2luLmNvaW5iYXNlIFxcXCJzZW5kZXIwMlxcXCIgKHJlYWQta2V5c2V0IFxcXCJzZW5kZXIwMlxcXCIpIDEyMDAwMDAwMC4wKVxcbihjb2luLmNvaW5iYXNlIFxcXCJzZW5kZXIwM1xcXCIgKHJlYWQta2V5c2V0IFxcXCJzZW5kZXIwM1xcXCIpIDEzMDAwMDAwMC4wKVxcbihjb2luLmNvaW5iYXNlIFxcXCJzZW5kZXIwNFxcXCIgKHJlYWQta2V5c2V0IFxcXCJzZW5kZXIwNFxcXCIpIDE0MDAwMDAwMC4wKVxcbihjb2luLmNvaW5iYXNlIFxcXCJzZW5kZXIwNVxcXCIgKHJlYWQta2V5c2V0IFxcXCJzZW5kZXIwNVxcXCIpIDE1MDAwMDAwMC4wKVxcbihjb2luLmNvaW5iYXNlIFxcXCJzZW5kZXIwNlxcXCIgKHJlYWQta2V5c2V0IFxcXCJzZW5kZXIwNlxcXCIpIDE2MDAwMDAwMC4wKVxcbihjb2luLmNvaW5iYXNlIFxcXCJzZW5kZXIwN1xcXCIgKHJlYWQta2V5c2V0IFxcXCJzZW5kZXIwN1xcXCIpIDE3MDAwMDAwMC4wKVxcbihjb2luLmNvaW5iYXNlIFxcXCJzZW5kZXIwOFxcXCIgKHJlYWQta2V5c2V0IFxcXCJzZW5kZXIwOFxcXCIpIDE4MDAwMDAwMC4wKVxcbihjb2luLmNvaW5iYXNlIFxcXCJzZW5kZXIwOVxcXCIgKHJlYWQta2V5c2V0IFxcXCJzZW5kZXIwOVxcXCIpIDE5MDAwMDAwMC4wKVxcbihjb2luLmNvaW5iYXNlIFxcXCJtdWx0aS0wMC0wMVxcXCIgKHJlYWQta2V5c2V0IFxcXCJtdWx0aS0wMC0wMVxcXCIpIDEwMTAwMDAwMC4wKVxcbihjb2luLmNvaW5iYXNlIFxcXCJtdWx0aS0wMi0wMy0wNC1hbnlcXFwiIChyZWFkLWtleXNldCBcXFwibXVsdGktMDItMDMtMDQtYW55XFxcIikgMTIzNDAwMDAwLjApXFxuXFxuKGNvaW4uY29pbmJhc2UgXFxcImU3Zjc2MzRlOTI1NTQxZjM2OGI4MjdhZDVjNzI0MjE5MDUxMDBmNjIwNTI4NWE3OGMxOWQ3YjRhMzg3MTE4MDVcXFwiIChyZWFkLWtleXNldCBcXFwiZTdmN1xcXCIpIDE1MC4wKVxcblxcbjsgZW5vdWdoIHRvIGNvdmVyIHRoZSBnYXMgY29zdHMgZm9yIGFsbG9jYXRpb24gcmVsZWFzZVxcbihjb2luLmNvaW5iYXNlIFxcXCJhbGxvY2F0aW9uMDBcXFwiIChrZXlzZXQtcmVmLWd1YXJkIFxcXCJhbGxvY2F0aW9uMDBcXFwiKSAxMDAwMDAuMClcXG4oY29pbi5jb2luYmFzZSBcXFwiYWxsb2NhdGlvbjAxXFxcIiAoa2V5c2V0LXJlZi1ndWFyZCBcXFwiYWxsb2NhdGlvbjAxXFxcIikgMTAwMDAwLjApXFxuKGNvaW4uY29pbmJhc2UgXFxcImFsbG9jYXRpb24wMlxcXCIgKGtleXNldC1yZWYtZ3VhcmQgXFxcImFsbG9jYXRpb24wMlxcXCIpIDEwMDAwMC4wKVwifX0sXCJzaWduZXJzXCI6W10sXCJtZXRhXCI6e1wiY3JlYXRpb25UaW1lXCI6MCxcInR0bFwiOjE3MjgwMCxcImdhc0xpbWl0XCI6MCxcImNoYWluSWRcIjpcIlwiLFwiZ2FzUHJpY2VcIjowLFwic2VuZGVyXCI6XCJcIn0sXCJub25jZVwiOlwiZGV2bmV0LWdyYW50czBcIn0ifQ", unsafeFromText "eyJnYXMiOjAsInJlc3VsdCI6eyJzdGF0dXMiOiJzdWNjZXNzIiwiZGF0YSI6IldyaXRlIHN1Y2NlZWRlZCJ9LCJyZXFLZXkiOiJja2IyZmc1ZUl5dGhLdTlhU3dOSEhaWWxZVjZXVHU0aVhpRkNqZzlYUUtZIiwibG9ncyI6ImdMVllyaXhlNHpPZWxpejNkYXlZTDhzWGd0RVVWczJQVndlWGRDYXBnVmsiLCJldmVudHMiOlt7InBhcmFtcyI6WyIiLCJzZW5kZXIwMCIsMTAwMDAwMDAwXSwibmFtZSI6IlRSQU5TRkVSIiwibW9kdWxlIjp7Im5hbWVzcGFjZSI6bnVsbCwibmFtZSI6ImNvaW4ifSwibW9kdWxlSGFzaCI6IndPVGpOQzNndE9BanFnQ1k4UzloUS1MQml3Y1BVRTdqNGlCREUwVG1kSm8ifSx7InBhcmFtcyI6WyIiLCJzZW5kZXIwMSIsMTEwMDAwMDAwXSwibmFtZSI6IlRSQU5TRkVSIiwibW9kdWxlIjp7Im5hbWVzcGFjZSI6bnVsbCwibmFtZSI6ImNvaW4ifSwibW9kdWxlSGFzaCI6IndPVGpOQzNndE9BanFnQ1k4UzloUS1MQml3Y1BVRTdqNGlCREUwVG1kSm8ifSx7InBhcmFtcyI6WyIiLCJzZW5kZXIwMiIsMTIwMDAwMDAwXSwibmFtZSI6IlRSQU5TRkVSIiwibW9kdWxlIjp7Im5hbWVzcGFjZSI6bnVsbCwibmFtZSI6ImNvaW4ifSwibW9kdWxlSGFzaCI6IndPVGpOQzNndE9BanFnQ1k4UzloUS1MQml3Y1BVRTdqNGlCREUwVG1kSm8ifSx7InBhcmFtcyI6WyIiLCJzZW5kZXIwMyIsMTMwMDAwMDAwXSwibmFtZSI6IlRSQU5TRkVSIiwibW9kdWxlIjp7Im5hbWVzcGFjZSI6bnVsbCwibmFtZSI6ImNvaW4ifSwibW9kdWxlSGFzaCI6IndPVGpOQzNndE9BanFnQ1k4UzloUS1MQml3Y1BVRTdqNGlCREUwVG1kSm8ifSx7InBhcmFtcyI6WyIiLCJzZW5kZXIwNCIsMTQwMDAwMDAwXSwibmFtZSI6IlRSQU5TRkVSIiwibW9kdWxlIjp7Im5hbWVzcGFjZSI6bnVsbCwibmFtZSI6ImNvaW4ifSwibW9kdWxlSGFzaCI6IndPVGpOQzNndE9BanFnQ1k4UzloUS1MQml3Y1BVRTdqNGlCREUwVG1kSm8ifSx7InBhcmFtcyI6WyIiLCJzZW5kZXIwNSIsMTUwMDAwMDAwXSwibmFtZSI6IlRSQU5TRkVSIiwibW9kdWxlIjp7Im5hbWVzcGFjZSI6bnVsbCwibmFtZSI6ImNvaW4ifSwibW9kdWxlSGFzaCI6IndPVGpOQzNndE9BanFnQ1k4UzloUS1MQml3Y1BVRTdqNGlCREUwVG1kSm8ifSx7InBhcmFtcyI6WyIiLCJzZW5kZXIwNiIsMTYwMDAwMDAwXSwibmFtZSI6IlRSQU5TRkVSIiwibW9kdWxlIjp7Im5hbWVzcGFjZSI6bnVsbCwibmFtZSI6ImNvaW4ifSwibW9kdWxlSGFzaCI6IndPVGpOQzNndE9BanFnQ1k4UzloUS1MQml3Y1BVRTdqNGlCREUwVG1kSm8ifSx7InBhcmFtcyI6WyIiLCJzZW5kZXIwNyIsMTcwMDAwMDAwXSwibmFtZSI6IlRSQU5TRkVSIiwibW9kdWxlIjp7Im5hbWVzcGFjZSI6bnVsbCwibmFtZSI6ImNvaW4ifSwibW9kdWxlSGFzaCI6IndPVGpOQzNndE9BanFnQ1k4UzloUS1MQml3Y1BVRTdqNGlCREUwVG1kSm8ifSx7InBhcmFtcyI6WyIiLCJzZW5kZXIwOCIsMTgwMDAwMDAwXSwibmFtZSI6IlRSQU5TRkVSIiwibW9kdWxlIjp7Im5hbWVzcGFjZSI6bnVsbCwibmFtZSI6ImNvaW4ifSwibW9kdWxlSGFzaCI6IndPVGpOQzNndE9BanFnQ1k4UzloUS1MQml3Y1BVRTdqNGlCREUwVG1kSm8ifSx7InBhcmFtcyI6WyIiLCJzZW5kZXIwOSIsMTkwMDAwMDAwXSwibmFtZSI6IlRSQU5TRkVSIiwibW9kdWxlIjp7Im5hbWVzcGFjZSI6bnVsbCwibmFtZSI6ImNvaW4ifSwibW9kdWxlSGFzaCI6IndPVGpOQzNndE9BanFnQ1k4UzloUS1MQml3Y1BVRTdqNGlCREUwVG1kSm8ifSx7InBhcmFtcyI6WyIiLCJtdWx0aS0wMC0wMSIsMTAxMDAwMDAwXSwibmFtZSI6IlRSQU5TRkVSIiwibW9kdWxlIjp7Im5hbWVzcGFjZSI6bnVsbCwibmFtZSI6ImNvaW4ifSwibW9kdWxlSGFzaCI6IndPVGpOQzNndE9BanFnQ1k4UzloUS1MQml3Y1BVRTdqNGlCREUwVG1kSm8ifSx7InBhcmFtcyI6WyIiLCJtdWx0aS0wMi0wMy0wNC1hbnkiLDEyMzQwMDAwMF0sIm5hbWUiOiJUUkFOU0ZFUiIsIm1vZHVsZSI6eyJuYW1lc3BhY2UiOm51bGwsIm5hbWUiOiJjb2luIn0sIm1vZHVsZUhhc2giOiJ3T1RqTkMzZ3RPQWpxZ0NZOFM5aFEtTEJpd2NQVUU3ajRpQkRFMFRtZEpvIn0seyJwYXJhbXMiOlsiIiwiZTdmNzYzNGU5MjU1NDFmMzY4YjgyN2FkNWM3MjQyMTkwNTEwMGY2MjA1Mjg1YTc4YzE5ZDdiNGEzODcxMTgwNSIsMTUwXSwibmFtZSI6IlRSQU5TRkVSIiwibW9kdWxlIjp7Im5hbWVzcGFjZSI6bnVsbCwibmFtZSI6ImNvaW4ifSwibW9kdWxlSGFzaCI6IndPVGpOQzNndE9BanFnQ1k4UzloUS1MQml3Y1BVRTdqNGlCREUwVG1kSm8ifSx7InBhcmFtcyI6WyIiLCJhbGxvY2F0aW9uMDAiLDEwMDAwMF0sIm5hbWUiOiJUUkFOU0ZFUiIsIm1vZHVsZSI6eyJuYW1lc3BhY2UiOm51bGwsIm5hbWUiOiJjb2luIn0sIm1vZHVsZUhhc2giOiJ3T1RqTkMzZ3RPQWpxZ0NZOFM5aFEtTEJpd2NQVUU3ajRpQkRFMFRtZEpvIn0seyJwYXJhbXMiOlsiIiwiYWxsb2NhdGlvbjAxIiwxMDAwMDBdLCJuYW1lIjoiVFJBTlNGRVIiLCJtb2R1bGUiOnsibmFtZXNwYWNlIjpudWxsLCJuYW1lIjoiY29pbiJ9LCJtb2R1bGVIYXNoIjoid09Uak5DM2d0T0FqcWdDWThTOWhRLUxCaXdjUFVFN2o0aUJERTBUbWRKbyJ9LHsicGFyYW1zIjpbIiIsImFsbG9jYXRpb24wMiIsMTAwMDAwXSwibmFtZSI6IlRSQU5TRkVSIiwibW9kdWxlIjp7Im5hbWVzcGFjZSI6bnVsbCwibmFtZSI6ImNvaW4ifSwibW9kdWxlSGFzaCI6IndPVGpOQzNndE9BanFnQ1k4UzloUS1MQml3Y1BVRTdqNGlCREUwVG1kSm8ifV0sIm1ldGFEYXRhIjpudWxsLCJjb250aW51YXRpb24iOm51bGwsInR4SWQiOjh9") + [ (unsafeFromText "eyJoYXNoIjoiNDhUMExqQW5TRnBGV3h2dmFQVi1fNkUtQ2pEQVBoV1lVRldidnlmMmxGcyIsInNpZ3MiOltdLCJjbWQiOiJ7XCJuZXR3b3JrSWRcIjpudWxsLFwicGF5bG9hZFwiOntcImV4ZWNcIjp7XCJkYXRhXCI6bnVsbCxcImNvZGVcIjpcIihpbnRlcmZhY2UgZnVuZ2libGUtdjFcXG5cXG4gIFxcXCIgU3RhbmRhcmQgZm9yIGZ1bmdpYmxlIGNvaW5zIGFuZCB0b2tlbnMgYXMgc3BlY2lmaWVkIGluIEtJUC0wMDAyLiBcXFwiXFxuXFxuICAgOyAtLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tXFxuICAgOyBTY2hlbWFcXG5cXG4gICAoZGVmc2NoZW1hIGFjY291bnQtZGV0YWlsc1xcbiAgICBAZG9jIFxcXCJTY2hlbWEgZm9yIHJlc3VsdHMgb2YgJ2FjY291bnQnIG9wZXJhdGlvbi5cXFwiXFxuICAgIEBtb2RlbCBbIChpbnZhcmlhbnQgKCE9IFxcXCJcXFwiIHNlbmRlcikpIF1cXG5cXG4gICAgYWNjb3VudDpzdHJpbmdcXG4gICAgYmFsYW5jZTpkZWNpbWFsXFxuICAgIGd1YXJkOmd1YXJkKVxcblxcblxcbiAgIDsgLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLVxcbiAgIDsgQ2Fwc1xcblxcbiAgIChkZWZjYXAgVFJBTlNGRVI6Ym9vbFxcbiAgICAgKCBzZW5kZXI6c3RyaW5nXFxuICAgICAgIHJlY2VpdmVyOnN0cmluZ1xcbiAgICAgICBhbW91bnQ6ZGVjaW1hbFxcbiAgICAgKVxcbiAgICAgQGRvYyBcXFwiIE1hbmFnZWQgY2FwYWJpbGl0eSBzZWFsaW5nIEFNT1VOVCBmb3IgdHJhbnNmZXIgZnJvbSBTRU5ERVIgdG8gXFxcXFxcbiAgICAgICAgICBcXFxcIFJFQ0VJVkVSLiBQZXJtaXRzIGFueSBudW1iZXIgb2YgdHJhbnNmZXJzIHVwIHRvIEFNT1VOVC5cXFwiXFxuICAgICBAbWFuYWdlZCBhbW91bnQgVFJBTlNGRVItbWdyXFxuICAgICApXFxuXFxuICAgKGRlZnVuIFRSQU5TRkVSLW1ncjpkZWNpbWFsXFxuICAgICAoIG1hbmFnZWQ6ZGVjaW1hbFxcbiAgICAgICByZXF1ZXN0ZWQ6ZGVjaW1hbFxcbiAgICAgKVxcbiAgICAgQGRvYyBcXFwiIE1hbmFnZXMgVFJBTlNGRVIgQU1PVU5UIGxpbmVhcmx5LCBcXFxcXFxuICAgICAgICAgIFxcXFwgc3VjaCB0aGF0IGEgcmVxdWVzdCBmb3IgMS4wIGFtb3VudCBvbiBhIDMuMCBcXFxcXFxuICAgICAgICAgIFxcXFwgbWFuYWdlZCBxdWFudGl0eSBlbWl0cyB1cGRhdGVkIGFtb3VudCAyLjAuXFxcIlxcbiAgICAgKVxcblxcbiAgIDsgLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLVxcbiAgIDsgRnVuY3Rpb25hbGl0eVxcblxcbiAgIChkZWZ1biB0cmFuc2Zlci1jcmVhdGU6c3RyaW5nXFxuICAgICAoIHNlbmRlcjpzdHJpbmdcXG4gICAgICAgcmVjZWl2ZXI6c3RyaW5nXFxuICAgICAgIHJlY2VpdmVyLWd1YXJkOmd1YXJkXFxuICAgICAgIGFtb3VudDpkZWNpbWFsXFxuICAgICApXFxuICAgICBAZG9jIFxcXCIgVHJhbnNmZXIgQU1PVU5UIGJldHdlZW4gYWNjb3VudHMgU0VOREVSIGFuZCBSRUNFSVZFUi4gXFxcXFxcbiAgICAgICAgICBcXFxcIEZhaWxzIGlmIFNFTkRFUiBkb2VzIG5vdCBleGlzdC4gSWYgUkVDRUlWRVIgZXhpc3RzLCBndWFyZCBcXFxcXFxuICAgICAgICAgIFxcXFwgbXVzdCBtYXRjaCBleGlzdGluZyB2YWx1ZS4gSWYgUkVDRUlWRVIgZG9lcyBub3QgZXhpc3QsIFxcXFxcXG4gICAgICAgICAgXFxcXCBSRUNFSVZFUiBhY2NvdW50IGlzIGNyZWF0ZWQgdXNpbmcgUkVDRUlWRVItR1VBUkQuIFxcXFxcXG4gICAgICAgICAgXFxcXCBTdWJqZWN0IHRvIG1hbmFnZW1lbnQgYnkgVFJBTlNGRVIgY2FwYWJpbGl0eS5cXFwiXFxuICAgICBAbW9kZWwgWyAocHJvcGVydHkgKD4gYW1vdW50IDAuMCkpXFxuICAgICAgICAgICAgICAocHJvcGVydHkgKCE9IHNlbmRlciBcXFwiXFxcIikpXFxuICAgICAgICAgICAgICAocHJvcGVydHkgKCE9IHJlY2VpdmVyIFxcXCJcXFwiKSlcXG4gICAgICAgICAgICAgIChwcm9wZXJ0eSAoIT0gc2VuZGVyIHJlY2VpdmVyKSlcXG4gICAgICAgICAgICBdXFxuICAgICApXFxuXFxuICAgKGRlZnBhY3QgdHJhbnNmZXItY3Jvc3NjaGFpbjpzdHJpbmdcXG4gICAgICggc2VuZGVyOnN0cmluZ1xcbiAgICAgICByZWNlaXZlcjpzdHJpbmdcXG4gICAgICAgcmVjZWl2ZXItZ3VhcmQ6Z3VhcmRcXG4gICAgICAgdGFyZ2V0LWNoYWluOnN0cmluZ1xcbiAgICAgICBhbW91bnQ6ZGVjaW1hbFxcbiAgICAgKVxcbiAgICAgQGRvYyBcXFwiIDItc3RlcCBwYWN0IHRvIHRyYW5zZmVyIEFNT1VOVCBmcm9tIFNFTkRFUiBvbiBjdXJyZW50IGNoYWluIFxcXFxcXG4gICAgICAgICAgXFxcXCB0byBSRUNFSVZFUiBvbiBUQVJHRVQtQ0hBSU4gdmlhIFNQViBwcm9vZi4gXFxcXFxcbiAgICAgICAgICBcXFxcIFRBUkdFVC1DSEFJTiBtdXN0IGJlIGRpZmZlcmVudCB0aGFuIGN1cnJlbnQgY2hhaW4gaWQuIFxcXFxcXG4gICAgICAgICAgXFxcXCBGaXJzdCBzdGVwIGRlYml0cyBBTU9VTlQgY29pbnMgaW4gU0VOREVSIGFjY291bnQgYW5kIHlpZWxkcyBcXFxcXFxuICAgICAgICAgIFxcXFwgUkVDRUlWRVIsIFJFQ0VJVkVSX0dVQVJEIGFuZCBBTU9VTlQgdG8gVEFSR0VULUNIQUlOLiBcXFxcXFxuICAgICAgICAgIFxcXFwgU2Vjb25kIHN0ZXAgY29udGludWF0aW9uIGlzIHNlbnQgaW50byBUQVJHRVQtQ0hBSU4gd2l0aCBwcm9vZiBcXFxcXFxuICAgICAgICAgIFxcXFwgb2J0YWluZWQgZnJvbSB0aGUgc3B2ICdvdXRwdXQnIGVuZHBvaW50IG9mIENoYWlud2ViLiBcXFxcXFxuICAgICAgICAgIFxcXFwgUHJvb2YgaXMgdmFsaWRhdGVkIGFuZCBSRUNFSVZFUiBpcyBjcmVkaXRlZCB3aXRoIEFNT1VOVCBcXFxcXFxuICAgICAgICAgIFxcXFwgY3JlYXRpbmcgYWNjb3VudCB3aXRoIFJFQ0VJVkVSX0dVQVJEIGFzIG5lY2Vzc2FyeS5cXFwiXFxuICAgICBAbW9kZWwgWyAocHJvcGVydHkgKD4gYW1vdW50IDAuMCkpXFxuICAgICAgICAgICAgICAocHJvcGVydHkgKCE9IHNlbmRlciBcXFwiXFxcIikpXFxuICAgICAgICAgICAgICAocHJvcGVydHkgKCE9IHJlY2VpdmVyIFxcXCJcXFwiKSlcXG4gICAgICAgICAgICAgIChwcm9wZXJ0eSAoIT0gc2VuZGVyIHJlY2VpdmVyKSlcXG4gICAgICAgICAgICAgIChwcm9wZXJ0eSAoIT0gdGFyZ2V0LWNoYWluIFxcXCJcXFwiKSlcXG4gICAgICAgICAgICBdXFxuICAgICApXFxuXFxuICAgKGRlZnVuIGdldC1iYWxhbmNlOmRlY2ltYWxcXG4gICAgICggYWNjb3VudDpzdHJpbmcgKVxcbiAgICAgXFxcIiBHZXQgYmFsYW5jZSBmb3IgQUNDT1VOVC4gRmFpbHMgaWYgYWNjb3VudCBkb2VzIG5vdCBleGlzdC5cXFwiXFxuICAgICApXFxuXFxuICAgKGRlZnVuIGRldGFpbHM6b2JqZWN0e2FjY291bnQtZGV0YWlsc31cXG4gICAgICggYWNjb3VudDogc3RyaW5nIClcXG4gICAgIFxcXCIgR2V0IGFuIG9iamVjdCB3aXRoIGRldGFpbHMgb2YgQUNDT1VOVC4gXFxcXFxcbiAgICAgXFxcXCBGYWlscyBpZiBhY2NvdW50IGRvZXMgbm90IGV4aXN0LlxcXCJcXG4gICAgIClcXG5cXG4gICAoZGVmdW4gcHJlY2lzaW9uOmludGVnZXJcXG4gICAgICgpXFxuICAgICBcXFwiUmV0dXJuIHRoZSBtYXhpbXVtIGFsbG93ZWQgZGVjaW1hbCBwcmVjaXNpb24uXFxcIlxcbiAgICAgKVxcblxcbiAgIChkZWZ1biBlbmZvcmNlLXVuaXQ6Ym9vbFxcbiAgICAgKCBhbW91bnQ6ZGVjaW1hbCApXFxuICAgICBcXFwiIEVuZm9yY2UgbWluaW11bSBwcmVjaXNpb24gYWxsb3dlZCBmb3IgdHJhbnNhY3Rpb25zLlxcXCJcXG4gICAgIClcXG5cXG4gICAoZGVmdW4gY3JlYXRlLWFjY291bnQ6c3RyaW5nXFxuICAgICAoIGFjY291bnQ6c3RyaW5nXFxuICAgICAgIGd1YXJkOmd1YXJkXFxuICAgICApXFxuICAgICBcXFwiIENyZWF0ZSBBQ0NPVU5UIHdpdGggMC4wIGJhbGFuY2UsIHdpdGggR1VBUkQgY29udHJvbGxpbmcgYWNjZXNzLlxcXCJcXG4gICAgIClcXG5cXG4gICAoZGVmdW4gcm90YXRlOnN0cmluZ1xcbiAgICAgKCBhY2NvdW50OnN0cmluZ1xcbiAgICAgICBuZXctZ3VhcmQ6Z3VhcmRcXG4gICAgIClcXG4gICAgIFxcXCIgUm90YXRlIGd1YXJkIGZvciBBQ0NPVU5ULiBUcmFuc2FjdGlvbiBpcyB2YWxpZGF0ZWQgYWdhaW5zdCBcXFxcXFxuICAgICBcXFxcIGV4aXN0aW5nIGd1YXJkIGJlZm9yZSBpbnN0YWxsaW5nIG5ldyBndWFyZC4gXFxcIlxcbiAgICAgKVxcblxcbilcXG5cIn19LFwic2lnbmVyc1wiOltdLFwibWV0YVwiOntcImNyZWF0aW9uVGltZVwiOjAsXCJ0dGxcIjoxNzI4MDAsXCJnYXNMaW1pdFwiOjAsXCJjaGFpbklkXCI6XCJcIixcImdhc1ByaWNlXCI6MCxcInNlbmRlclwiOlwiXCJ9LFwibm9uY2VcIjpcImdlbmVzaXMtMDFcIn0ifQ", unsafeFromText "eyJnYXMiOjAsInJlc3VsdCI6eyJzdGF0dXMiOiJzdWNjZXNzIiwiZGF0YSI6IkxvYWRlZCBpbnRlcmZhY2UgZnVuZ2libGUtdjEsIGhhc2ggTm1kUnRzekN3YWNqSEd5eUU5Tl9mbFFNUlJCaGNIVkZQNE9qaGlQZWoxRSJ9LCJyZXFLZXkiOiI0OFQwTGpBblNGcEZXeHZ2YVBWLV82RS1DakRBUGhXWVVGV2J2eWYybEZzIiwibG9ncyI6IlB3eDlycG9kS2prSGNPUlh2WFVRSUpjRVZRZDhPSXRNM0FlakNFRExMVXMiLCJtZXRhRGF0YSI6bnVsbCwiY29udGludWF0aW9uIjpudWxsLCJ0eElkIjowfQ") + , (unsafeFromText "eyJoYXNoIjoieW5ucDFYVVNSTjJrMUYwYTZ2dXM3RFp0SDZjcHN6MVhmX0d3V0xnTFhTTSIsInNpZ3MiOltdLCJjbWQiOiJ7XCJuZXR3b3JrSWRcIjpudWxsLFwicGF5bG9hZFwiOntcImV4ZWNcIjp7XCJkYXRhXCI6bnVsbCxcImNvZGVcIjpcIihpbnRlcmZhY2UgZnVuZ2libGUteGNoYWluLXYxXFxuXFxuICBcXFwiIFRoaXMgaW50ZXJmYWNlIG9mZmVycyBhIHN0YW5kYXJkIGNhcGFiaWxpdHkgZm9yIGNyb3NzLWNoYWluIFxcXFxcXG4gIFxcXFwgdHJhbnNmZXJzIGFuZCBhc3NvY2lhdGVkIGV2ZW50cy4gXFxcIlxcblxcbiAgKGRlZmNhcCBUUkFOU0ZFUl9YQ0hBSU46Ym9vbFxcbiAgICAoIHNlbmRlcjpzdHJpbmdcXG4gICAgICByZWNlaXZlcjpzdHJpbmdcXG4gICAgICBhbW91bnQ6ZGVjaW1hbFxcbiAgICAgIHRhcmdldC1jaGFpbjpzdHJpbmdcXG4gICAgKVxcbiAgICBAZG9jIFxcXCIgTWFuYWdlZCBjYXBhYmlsaXR5IHNlYWxpbmcgQU1PVU5UIGZvciB0cmFuc2ZlciBcXFxcXFxuICAgICAgICAgXFxcXCBmcm9tIFNFTkRFUiB0byBSRUNFSVZFUiBvbiBUQVJHRVQtQ0hBSU4uIFBlcm1pdHMgXFxcXFxcbiAgICAgICAgIFxcXFwgYW55IG51bWJlciBvZiBjcm9zcy1jaGFpbiB0cmFuc2ZlcnMgdXAgdG8gQU1PVU5ULlxcXCJcXG5cXG4gICAgQG1hbmFnZWQgYW1vdW50IFRSQU5TRkVSX1hDSEFJTi1tZ3JcXG4gICAgKVxcblxcbiAgKGRlZnVuIFRSQU5TRkVSX1hDSEFJTi1tZ3I6ZGVjaW1hbFxcbiAgICAoIG1hbmFnZWQ6ZGVjaW1hbFxcbiAgICAgIHJlcXVlc3RlZDpkZWNpbWFsXFxuICAgIClcXG4gICAgQGRvYyBcXFwiIEFsbG93cyBUUkFOU0ZFUi1YQ0hBSU4gQU1PVU5UIHRvIGJlIGxlc3MgdGhhbiBvciBcXFxcXFxuICAgICAgICAgXFxcXCBlcXVhbCBtYW5hZ2VkIHF1YW50aXR5IGFzIGEgb25lLXNob3QsIHJldHVybmluZyAwLjAuXFxcIlxcbiAgKVxcblxcbiAgKGRlZmNhcCBUUkFOU0ZFUl9YQ0hBSU5fUkVDRDpib29sXFxuICAgICggc2VuZGVyOnN0cmluZ1xcbiAgICAgIHJlY2VpdmVyOnN0cmluZ1xcbiAgICAgIGFtb3VudDpkZWNpbWFsXFxuICAgICAgc291cmNlLWNoYWluOnN0cmluZ1xcbiAgICApXFxuICAgIEBkb2MgXFxcIkV2ZW50IGVtaXR0ZWQgb24gcmVjZWlwdCBvZiBjcm9zcy1jaGFpbiB0cmFuc2Zlci5cXFwiXFxuICAgIEBldmVudFxcbiAgKVxcbilcXG5cIn19LFwic2lnbmVyc1wiOltdLFwibWV0YVwiOntcImNyZWF0aW9uVGltZVwiOjAsXCJ0dGxcIjoxNzI4MDAsXCJnYXNMaW1pdFwiOjAsXCJjaGFpbklkXCI6XCJcIixcImdhc1ByaWNlXCI6MCxcInNlbmRlclwiOlwiXCJ9LFwibm9uY2VcIjpcImdlbmVzaXMteGNoYWluXCJ9In0", unsafeFromText "eyJnYXMiOjAsInJlc3VsdCI6eyJzdGF0dXMiOiJzdWNjZXNzIiwiZGF0YSI6IkxvYWRlZCBpbnRlcmZhY2UgZnVuZ2libGUteGNoYWluLXYxLCBoYXNoIGg4OWljM2doejIzUmprMHBITkt0Rk93cnZTczdtYm11cWxvVlhPaGwyR0kifSwicmVxS2V5IjoieW5ucDFYVVNSTjJrMUYwYTZ2dXM3RFp0SDZjcHN6MVhmX0d3V0xnTFhTTSIsImxvZ3MiOiJSUDhnMUJrZnkyQjN1bHE0WWU4amF1VlRZcGpqRXlaLWtydGJ5SVg2STRnIiwibWV0YURhdGEiOm51bGwsImNvbnRpbnVhdGlvbiI6bnVsbCwidHhJZCI6MX0") + , (unsafeFromText "eyJoYXNoIjoiMDVCdGo3ZUJaQlc3by1TYUxvVmhBaWNNVVBaVUJiRzZRVDhfTEFrQ3hIcyIsInNpZ3MiOltdLCJjbWQiOiJ7XCJuZXR3b3JrSWRcIjpudWxsLFwicGF5bG9hZFwiOntcImV4ZWNcIjp7XCJkYXRhXCI6bnVsbCxcImNvZGVcIjpcIihpbnRlcmZhY2UgZnVuZ2libGUtdjJcXG5cXG4gIFxcXCIgU3RhbmRhcmQgZm9yIGZ1bmdpYmxlIGNvaW5zIGFuZCB0b2tlbnMgYXMgc3BlY2lmaWVkIGluIEtJUC0wMDAyLiBcXFwiXFxuXFxuICAgOyAtLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tXFxuICAgOyBTY2hlbWFcXG5cXG4gICAoZGVmc2NoZW1hIGFjY291bnQtZGV0YWlsc1xcbiAgICBAZG9jIFxcXCJTY2hlbWEgZm9yIHJlc3VsdHMgb2YgJ2FjY291bnQnIG9wZXJhdGlvbi5cXFwiXFxuICAgIEBtb2RlbCBbIChpbnZhcmlhbnQgKCE9IFxcXCJcXFwiIHNlbmRlcikpIF1cXG5cXG4gICAgYWNjb3VudDpzdHJpbmdcXG4gICAgYmFsYW5jZTpkZWNpbWFsXFxuICAgIGd1YXJkOmd1YXJkKVxcblxcblxcbiAgIDsgLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLVxcbiAgIDsgQ2Fwc1xcblxcbiAgIChkZWZjYXAgVFJBTlNGRVI6Ym9vbFxcbiAgICAgKCBzZW5kZXI6c3RyaW5nXFxuICAgICAgIHJlY2VpdmVyOnN0cmluZ1xcbiAgICAgICBhbW91bnQ6ZGVjaW1hbFxcbiAgICAgKVxcbiAgICAgQGRvYyBcXFwiIE1hbmFnZWQgY2FwYWJpbGl0eSBzZWFsaW5nIEFNT1VOVCBmb3IgdHJhbnNmZXIgZnJvbSBTRU5ERVIgdG8gXFxcXFxcbiAgICAgICAgICBcXFxcIFJFQ0VJVkVSLiBQZXJtaXRzIGFueSBudW1iZXIgb2YgdHJhbnNmZXJzIHVwIHRvIEFNT1VOVC5cXFwiXFxuICAgICBAbWFuYWdlZCBhbW91bnQgVFJBTlNGRVItbWdyXFxuICAgICApXFxuXFxuICAgKGRlZnVuIFRSQU5TRkVSLW1ncjpkZWNpbWFsXFxuICAgICAoIG1hbmFnZWQ6ZGVjaW1hbFxcbiAgICAgICByZXF1ZXN0ZWQ6ZGVjaW1hbFxcbiAgICAgKVxcbiAgICAgQGRvYyBcXFwiIE1hbmFnZXMgVFJBTlNGRVIgQU1PVU5UIGxpbmVhcmx5LCBcXFxcXFxuICAgICAgICAgIFxcXFwgc3VjaCB0aGF0IGEgcmVxdWVzdCBmb3IgMS4wIGFtb3VudCBvbiBhIDMuMCBcXFxcXFxuICAgICAgICAgIFxcXFwgbWFuYWdlZCBxdWFudGl0eSBlbWl0cyB1cGRhdGVkIGFtb3VudCAyLjAuXFxcIlxcbiAgICAgKVxcblxcbiAgIDsgLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLVxcbiAgIDsgRnVuY3Rpb25hbGl0eVxcblxcblxcbiAgKGRlZnVuIHRyYW5zZmVyOnN0cmluZ1xcbiAgICAoIHNlbmRlcjpzdHJpbmdcXG4gICAgICByZWNlaXZlcjpzdHJpbmdcXG4gICAgICBhbW91bnQ6ZGVjaW1hbFxcbiAgICApXFxuICAgIEBkb2MgXFxcIiBUcmFuc2ZlciBBTU9VTlQgYmV0d2VlbiBhY2NvdW50cyBTRU5ERVIgYW5kIFJFQ0VJVkVSLiBcXFxcXFxuICAgICAgICAgXFxcXCBGYWlscyBpZiBlaXRoZXIgU0VOREVSIG9yIFJFQ0VJVkVSIGRvZXMgbm90IGV4aXN0LlxcXCJcXG4gICAgQG1vZGVsIFsgKHByb3BlcnR5ICg-IGFtb3VudCAwLjApKVxcbiAgICAgICAgICAgICAocHJvcGVydHkgKCE9IHNlbmRlciBcXFwiXFxcIikpXFxuICAgICAgICAgICAgIChwcm9wZXJ0eSAoIT0gcmVjZWl2ZXIgXFxcIlxcXCIpKVxcbiAgICAgICAgICAgICAocHJvcGVydHkgKCE9IHNlbmRlciByZWNlaXZlcikpXFxuICAgICAgICAgICBdXFxuICAgIClcXG5cXG4gICAoZGVmdW4gdHJhbnNmZXItY3JlYXRlOnN0cmluZ1xcbiAgICAgKCBzZW5kZXI6c3RyaW5nXFxuICAgICAgIHJlY2VpdmVyOnN0cmluZ1xcbiAgICAgICByZWNlaXZlci1ndWFyZDpndWFyZFxcbiAgICAgICBhbW91bnQ6ZGVjaW1hbFxcbiAgICAgKVxcbiAgICAgQGRvYyBcXFwiIFRyYW5zZmVyIEFNT1VOVCBiZXR3ZWVuIGFjY291bnRzIFNFTkRFUiBhbmQgUkVDRUlWRVIuIFxcXFxcXG4gICAgICAgICAgXFxcXCBGYWlscyBpZiBTRU5ERVIgZG9lcyBub3QgZXhpc3QuIElmIFJFQ0VJVkVSIGV4aXN0cywgZ3VhcmQgXFxcXFxcbiAgICAgICAgICBcXFxcIG11c3QgbWF0Y2ggZXhpc3RpbmcgdmFsdWUuIElmIFJFQ0VJVkVSIGRvZXMgbm90IGV4aXN0LCBcXFxcXFxuICAgICAgICAgIFxcXFwgUkVDRUlWRVIgYWNjb3VudCBpcyBjcmVhdGVkIHVzaW5nIFJFQ0VJVkVSLUdVQVJELiBcXFxcXFxuICAgICAgICAgIFxcXFwgU3ViamVjdCB0byBtYW5hZ2VtZW50IGJ5IFRSQU5TRkVSIGNhcGFiaWxpdHkuXFxcIlxcbiAgICAgQG1vZGVsIFsgKHByb3BlcnR5ICg-IGFtb3VudCAwLjApKVxcbiAgICAgICAgICAgICAgKHByb3BlcnR5ICghPSBzZW5kZXIgXFxcIlxcXCIpKVxcbiAgICAgICAgICAgICAgKHByb3BlcnR5ICghPSByZWNlaXZlciBcXFwiXFxcIikpXFxuICAgICAgICAgICAgICAocHJvcGVydHkgKCE9IHNlbmRlciByZWNlaXZlcikpXFxuICAgICAgICAgICAgXVxcbiAgICAgKVxcblxcbiAgIChkZWZwYWN0IHRyYW5zZmVyLWNyb3NzY2hhaW46c3RyaW5nXFxuICAgICAoIHNlbmRlcjpzdHJpbmdcXG4gICAgICAgcmVjZWl2ZXI6c3RyaW5nXFxuICAgICAgIHJlY2VpdmVyLWd1YXJkOmd1YXJkXFxuICAgICAgIHRhcmdldC1jaGFpbjpzdHJpbmdcXG4gICAgICAgYW1vdW50OmRlY2ltYWxcXG4gICAgIClcXG4gICAgIEBkb2MgXFxcIiAyLXN0ZXAgcGFjdCB0byB0cmFuc2ZlciBBTU9VTlQgZnJvbSBTRU5ERVIgb24gY3VycmVudCBjaGFpbiBcXFxcXFxuICAgICAgICAgIFxcXFwgdG8gUkVDRUlWRVIgb24gVEFSR0VULUNIQUlOIHZpYSBTUFYgcHJvb2YuIFxcXFxcXG4gICAgICAgICAgXFxcXCBUQVJHRVQtQ0hBSU4gbXVzdCBiZSBkaWZmZXJlbnQgdGhhbiBjdXJyZW50IGNoYWluIGlkLiBcXFxcXFxuICAgICAgICAgIFxcXFwgRmlyc3Qgc3RlcCBkZWJpdHMgQU1PVU5UIGNvaW5zIGluIFNFTkRFUiBhY2NvdW50IGFuZCB5aWVsZHMgXFxcXFxcbiAgICAgICAgICBcXFxcIFJFQ0VJVkVSLCBSRUNFSVZFUl9HVUFSRCBhbmQgQU1PVU5UIHRvIFRBUkdFVC1DSEFJTi4gXFxcXFxcbiAgICAgICAgICBcXFxcIFNlY29uZCBzdGVwIGNvbnRpbnVhdGlvbiBpcyBzZW50IGludG8gVEFSR0VULUNIQUlOIHdpdGggcHJvb2YgXFxcXFxcbiAgICAgICAgICBcXFxcIG9idGFpbmVkIGZyb20gdGhlIHNwdiAnb3V0cHV0JyBlbmRwb2ludCBvZiBDaGFpbndlYi4gXFxcXFxcbiAgICAgICAgICBcXFxcIFByb29mIGlzIHZhbGlkYXRlZCBhbmQgUkVDRUlWRVIgaXMgY3JlZGl0ZWQgd2l0aCBBTU9VTlQgXFxcXFxcbiAgICAgICAgICBcXFxcIGNyZWF0aW5nIGFjY291bnQgd2l0aCBSRUNFSVZFUl9HVUFSRCBhcyBuZWNlc3NhcnkuXFxcIlxcbiAgICAgQG1vZGVsIFsgKHByb3BlcnR5ICg-IGFtb3VudCAwLjApKVxcbiAgICAgICAgICAgICAgKHByb3BlcnR5ICghPSBzZW5kZXIgXFxcIlxcXCIpKVxcbiAgICAgICAgICAgICAgKHByb3BlcnR5ICghPSByZWNlaXZlciBcXFwiXFxcIikpXFxuICAgICAgICAgICAgICAocHJvcGVydHkgKCE9IHNlbmRlciByZWNlaXZlcikpXFxuICAgICAgICAgICAgICAocHJvcGVydHkgKCE9IHRhcmdldC1jaGFpbiBcXFwiXFxcIikpXFxuICAgICAgICAgICAgXVxcbiAgICAgKVxcblxcbiAgIChkZWZ1biBnZXQtYmFsYW5jZTpkZWNpbWFsXFxuICAgICAoIGFjY291bnQ6c3RyaW5nIClcXG4gICAgIFxcXCIgR2V0IGJhbGFuY2UgZm9yIEFDQ09VTlQuIEZhaWxzIGlmIGFjY291bnQgZG9lcyBub3QgZXhpc3QuXFxcIlxcbiAgICAgKVxcblxcbiAgIChkZWZ1biBkZXRhaWxzOm9iamVjdHthY2NvdW50LWRldGFpbHN9XFxuICAgICAoIGFjY291bnQ6IHN0cmluZyApXFxuICAgICBcXFwiIEdldCBhbiBvYmplY3Qgd2l0aCBkZXRhaWxzIG9mIEFDQ09VTlQuIFxcXFxcXG4gICAgIFxcXFwgRmFpbHMgaWYgYWNjb3VudCBkb2VzIG5vdCBleGlzdC5cXFwiXFxuICAgICApXFxuXFxuICAgKGRlZnVuIHByZWNpc2lvbjppbnRlZ2VyXFxuICAgICAoKVxcbiAgICAgXFxcIlJldHVybiB0aGUgbWF4aW11bSBhbGxvd2VkIGRlY2ltYWwgcHJlY2lzaW9uLlxcXCJcXG4gICAgIClcXG5cXG4gICAoZGVmdW4gZW5mb3JjZS11bml0OmJvb2xcXG4gICAgICggYW1vdW50OmRlY2ltYWwgKVxcbiAgICAgXFxcIiBFbmZvcmNlIG1pbmltdW0gcHJlY2lzaW9uIGFsbG93ZWQgZm9yIHRyYW5zYWN0aW9ucy5cXFwiXFxuICAgICApXFxuXFxuICAgKGRlZnVuIGNyZWF0ZS1hY2NvdW50OnN0cmluZ1xcbiAgICAgKCBhY2NvdW50OnN0cmluZ1xcbiAgICAgICBndWFyZDpndWFyZFxcbiAgICAgKVxcbiAgICAgXFxcIiBDcmVhdGUgQUNDT1VOVCB3aXRoIDAuMCBiYWxhbmNlLCB3aXRoIEdVQVJEIGNvbnRyb2xsaW5nIGFjY2Vzcy5cXFwiXFxuICAgICApXFxuXFxuICAgKGRlZnVuIHJvdGF0ZTpzdHJpbmdcXG4gICAgICggYWNjb3VudDpzdHJpbmdcXG4gICAgICAgbmV3LWd1YXJkOmd1YXJkXFxuICAgICApXFxuICAgICBcXFwiIFJvdGF0ZSBndWFyZCBmb3IgQUNDT1VOVC4gVHJhbnNhY3Rpb24gaXMgdmFsaWRhdGVkIGFnYWluc3QgXFxcXFxcbiAgICAgXFxcXCBleGlzdGluZyBndWFyZCBiZWZvcmUgaW5zdGFsbGluZyBuZXcgZ3VhcmQuIFxcXCJcXG4gICAgIClcXG5cXG4pXFxuXCJ9fSxcInNpZ25lcnNcIjpbXSxcIm1ldGFcIjp7XCJjcmVhdGlvblRpbWVcIjowLFwidHRsXCI6MTcyODAwLFwiZ2FzTGltaXRcIjowLFwiY2hhaW5JZFwiOlwiXCIsXCJnYXNQcmljZVwiOjAsXCJzZW5kZXJcIjpcIlwifSxcIm5vbmNlXCI6XCJmdW5naWJsZS1hc3NldC12MlwifSJ9", unsafeFromText "eyJnYXMiOjAsInJlc3VsdCI6eyJzdGF0dXMiOiJzdWNjZXNzIiwiZGF0YSI6IkxvYWRlZCBpbnRlcmZhY2UgZnVuZ2libGUtdjIsIGhhc2ggWXhFLUtnQzZKbUttQ2NnS1RKbWxFbl9JNThJNEVYbWhmcnZ6WDdiZXJZayJ9LCJyZXFLZXkiOiIwNUJ0ajdlQlpCVzdvLVNhTG9WaEFpY01VUFpVQmJHNlFUOF9MQWtDeEhzIiwibG9ncyI6IjFTQmJBNHVzS0E5OFNlX09WRUdkcVk5WjJoSW1jVmcydWpISDJkM1ZmeEkiLCJtZXRhRGF0YSI6bnVsbCwiY29udGludWF0aW9uIjpudWxsLCJ0eElkIjoyfQ") + , (unsafeFromText "eyJoYXNoIjoiR1JJUXU0aEFLazBJRDlGOHpfLTB5WHlBS0ozM01QeVRZTVhPamxQSm1wSSIsInNpZ3MiOltdLCJjbWQiOiJ7XCJuZXR3b3JrSWRcIjpudWxsLFwicGF5bG9hZFwiOntcImV4ZWNcIjp7XCJkYXRhXCI6bnVsbCxcImNvZGVcIjpcIlxcbihtb2R1bGUgY29pbiBHT1ZFUk5BTkNFXFxuXFxuICBAZG9jIFxcXCInY29pbicgcmVwcmVzZW50cyB0aGUgS2FkZW5hIENvaW4gQ29udHJhY3QuIFRoaXMgY29udHJhY3QgcHJvdmlkZXMgYm90aCB0aGUgXFxcXFxcbiAgXFxcXGJ1eS9yZWRlZW0gZ2FzIHN1cHBvcnQgaW4gdGhlIGZvcm0gb2YgJ2Z1bmQtdHgnLCBhcyB3ZWxsIGFzIHRyYW5zZmVyLCAgICAgICBcXFxcXFxuICBcXFxcY3JlZGl0LCBkZWJpdCwgY29pbmJhc2UsIGFjY291bnQgY3JlYXRpb24gYW5kIHF1ZXJ5LCBhcyB3ZWxsIGFzIFNQViBidXJuICAgIFxcXFxcXG4gIFxcXFxjcmVhdGUuIFRvIGFjY2VzcyB0aGUgY29pbiBjb250cmFjdCwgeW91IG1heSB1c2UgaXRzIGZ1bGx5LXF1YWxpZmllZCBuYW1lLCAgXFxcXFxcbiAgXFxcXG9yIGlzc3VlIHRoZSAnKHVzZSBjb2luKScgY29tbWFuZCBpbiB0aGUgYm9keSBvZiBhIG1vZHVsZSBkZWNsYXJhdGlvbi5cXFwiXFxuXFxuICBAbW9kZWxcXG4gICAgWyAoZGVmcHJvcGVydHkgY29uc2VydmVzLW1hc3NcXG4gICAgICAgICg9IChjb2x1bW4tZGVsdGEgY29pbi10YWJsZSAnYmFsYW5jZSkgMC4wKSlcXG5cXG4gICAgICAoZGVmcHJvcGVydHkgdmFsaWQtYWNjb3VudCAoYWNjb3VudDpzdHJpbmcpXFxuICAgICAgICAoYW5kXFxuICAgICAgICAgICg-PSAobGVuZ3RoIGFjY291bnQpIDMpXFxuICAgICAgICAgICg8PSAobGVuZ3RoIGFjY291bnQpIDI1NikpKVxcbiAgICBdXFxuXFxuICAoaW1wbGVtZW50cyBmdW5naWJsZS12MilcXG4gIChpbXBsZW1lbnRzIGZ1bmdpYmxlLXhjaGFpbi12MSlcXG5cXG4gIDs7IGNvaW4tdjJcXG4gIChibGVzcyBcXFwidXRfSl9aTmtveWFQVUVKaGl3VmVXbmtTUW45SlQ5c1FDV0tkampWVnJXb1xcXCIpXFxuXFxuICA7OyBjb2luIHYzXFxuICAoYmxlc3MgXFxcIjFvc19zTEFVWXZCenNwbjVqamF3dFJwSldpSDFXUGZoeU5yYWVWdlNJd1VcXFwiKVxcblxcbiAgOzsgY29pbiB2NFxcbiAgKGJsZXNzIFxcXCJCalpXMFQyYWM2cUVfSTVYOEdFNGZhbDZ0VHFqaExUQzdteTB5dFFTeExVXFxcIilcXG5cXG4gIDs7IGNvaW4gdjVcXG4gIChibGVzcyBcXFwickU3RFU4amxRTDl4X01QWXVuaVpKZjVJQ0JUQUVIQUlGUUNCNGJsb2ZQNFxcXCIpXFxuXFxuICA7IC0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tXFxuICA7IFNjaGVtYXMgYW5kIFRhYmxlc1xcblxcbiAgKGRlZnNjaGVtYSBjb2luLXNjaGVtYVxcbiAgICBAZG9jIFxcXCJUaGUgY29pbiBjb250cmFjdCB0b2tlbiBzY2hlbWFcXFwiXFxuICAgIEBtb2RlbCBbIChpbnZhcmlhbnQgKD49IGJhbGFuY2UgMC4wKSkgXVxcblxcbiAgICBiYWxhbmNlOmRlY2ltYWxcXG4gICAgZ3VhcmQ6Z3VhcmQpXFxuXFxuICAoZGVmdGFibGUgY29pbi10YWJsZTp7Y29pbi1zY2hlbWF9KVxcblxcbiAgOyAtLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLVxcbiAgOyBDYXBhYmlsaXRpZXNcXG5cXG4gIChkZWZjYXAgR09WRVJOQU5DRSAoKVxcbiAgICAoZW5mb3JjZSBmYWxzZSBcXFwiRW5mb3JjZSBub24tdXBncmFkZWFiaWxpdHlcXFwiKSlcXG5cXG4gIChkZWZjYXAgR0FTICgpXFxuICAgIFxcXCJNYWdpYyBjYXBhYmlsaXR5IHRvIHByb3RlY3QgZ2FzIGJ1eSBhbmQgcmVkZWVtXFxcIlxcbiAgICB0cnVlKVxcblxcbiAgKGRlZmNhcCBDT0lOQkFTRSAoKVxcbiAgICBcXFwiTWFnaWMgY2FwYWJpbGl0eSB0byBwcm90ZWN0IG1pbmVyIHJld2FyZFxcXCJcXG4gICAgdHJ1ZSlcXG5cXG4gIChkZWZjYXAgR0VORVNJUyAoKVxcbiAgICBcXFwiTWFnaWMgY2FwYWJpbGl0eSBjb25zdHJhaW5pbmcgZ2VuZXNpcyB0cmFuc2FjdGlvbnNcXFwiXFxuICAgIHRydWUpXFxuXFxuICAoZGVmY2FwIFJFTUVESUFURSAoKVxcbiAgICBcXFwiTWFnaWMgY2FwYWJpbGl0eSBmb3IgcmVtZWRpYXRpb24gdHJhbnNhY3Rpb25zXFxcIlxcbiAgICB0cnVlKVxcblxcbiAgKGRlZmNhcCBERUJJVCAoc2VuZGVyOnN0cmluZylcXG4gICAgXFxcIkNhcGFiaWxpdHkgZm9yIG1hbmFnaW5nIGRlYml0aW5nIG9wZXJhdGlvbnNcXFwiXFxuICAgIChlbmZvcmNlLWd1YXJkIChhdCAnZ3VhcmQgKHJlYWQgY29pbi10YWJsZSBzZW5kZXIpKSlcXG4gICAgKGVuZm9yY2UgKCE9IHNlbmRlciBcXFwiXFxcIikgXFxcInZhbGlkIHNlbmRlclxcXCIpKVxcblxcbiAgKGRlZmNhcCBDUkVESVQgKHJlY2VpdmVyOnN0cmluZylcXG4gICAgXFxcIkNhcGFiaWxpdHkgZm9yIG1hbmFnaW5nIGNyZWRpdGluZyBvcGVyYXRpb25zXFxcIlxcbiAgICAoZW5mb3JjZSAoIT0gcmVjZWl2ZXIgXFxcIlxcXCIpIFxcXCJ2YWxpZCByZWNlaXZlclxcXCIpKVxcblxcbiAgKGRlZmNhcCBST1RBVEUgKGFjY291bnQ6c3RyaW5nKVxcbiAgICBAZG9jIFxcXCJBdXRvbm9tb3VzbHkgbWFuYWdlZCBjYXBhYmlsaXR5IGZvciBndWFyZCByb3RhdGlvblxcXCJcXG4gICAgQG1hbmFnZWRcXG4gICAgdHJ1ZSlcXG5cXG4gIChkZWZjYXAgVFJBTlNGRVI6Ym9vbFxcbiAgICAoIHNlbmRlcjpzdHJpbmdcXG4gICAgICByZWNlaXZlcjpzdHJpbmdcXG4gICAgICBhbW91bnQ6ZGVjaW1hbFxcbiAgICApXFxuICAgIEBtYW5hZ2VkIGFtb3VudCBUUkFOU0ZFUi1tZ3JcXG4gICAgKGVuZm9yY2UgKCE9IHNlbmRlciByZWNlaXZlcikgXFxcInNhbWUgc2VuZGVyIGFuZCByZWNlaXZlclxcXCIpXFxuICAgIChlbmZvcmNlLXVuaXQgYW1vdW50KVxcbiAgICAoZW5mb3JjZSAoPiBhbW91bnQgMC4wKSBcXFwiUG9zaXRpdmUgYW1vdW50XFxcIilcXG4gICAgKGNvbXBvc2UtY2FwYWJpbGl0eSAoREVCSVQgc2VuZGVyKSlcXG4gICAgKGNvbXBvc2UtY2FwYWJpbGl0eSAoQ1JFRElUIHJlY2VpdmVyKSlcXG4gIClcXG5cXG4gIChkZWZ1biBUUkFOU0ZFUi1tZ3I6ZGVjaW1hbFxcbiAgICAoIG1hbmFnZWQ6ZGVjaW1hbFxcbiAgICAgIHJlcXVlc3RlZDpkZWNpbWFsXFxuICAgIClcXG5cXG4gICAgKGxldCAoKG5ld2JhbCAoLSBtYW5hZ2VkIHJlcXVlc3RlZCkpKVxcbiAgICAgIChlbmZvcmNlICg-PSBuZXdiYWwgMC4wKVxcbiAgICAgICAgKGZvcm1hdCBcXFwiVFJBTlNGRVIgZXhjZWVkZWQgZm9yIGJhbGFuY2Uge31cXFwiIFttYW5hZ2VkXSkpXFxuICAgICAgbmV3YmFsKVxcbiAgKVxcblxcbiAgKGRlZmNhcCBUUkFOU0ZFUl9YQ0hBSU46Ym9vbFxcbiAgICAoIHNlbmRlcjpzdHJpbmdcXG4gICAgICByZWNlaXZlcjpzdHJpbmdcXG4gICAgICBhbW91bnQ6ZGVjaW1hbFxcbiAgICAgIHRhcmdldC1jaGFpbjpzdHJpbmdcXG4gICAgKVxcblxcbiAgICBAbWFuYWdlZCBhbW91bnQgVFJBTlNGRVJfWENIQUlOLW1nclxcbiAgICAoZW5mb3JjZS11bml0IGFtb3VudClcXG4gICAgKGVuZm9yY2UgKD4gYW1vdW50IDAuMCkgXFxcIkNyb3NzLWNoYWluIHRyYW5zZmVycyByZXF1aXJlIGEgcG9zaXRpdmUgYW1vdW50XFxcIilcXG4gICAgKGNvbXBvc2UtY2FwYWJpbGl0eSAoREVCSVQgc2VuZGVyKSlcXG4gIClcXG5cXG4gIChkZWZ1biBUUkFOU0ZFUl9YQ0hBSU4tbWdyOmRlY2ltYWxcXG4gICAgKCBtYW5hZ2VkOmRlY2ltYWxcXG4gICAgICByZXF1ZXN0ZWQ6ZGVjaW1hbFxcbiAgICApXFxuXFxuICAgIChlbmZvcmNlICg-PSBtYW5hZ2VkIHJlcXVlc3RlZClcXG4gICAgICAoZm9ybWF0IFxcXCJUUkFOU0ZFUl9YQ0hBSU4gZXhjZWVkZWQgZm9yIGJhbGFuY2Uge31cXFwiIFttYW5hZ2VkXSkpXFxuICAgIDAuMFxcbiAgKVxcblxcbiAgKGRlZmNhcCBUUkFOU0ZFUl9YQ0hBSU5fUkVDRDpib29sXFxuICAgICggc2VuZGVyOnN0cmluZ1xcbiAgICAgIHJlY2VpdmVyOnN0cmluZ1xcbiAgICAgIGFtb3VudDpkZWNpbWFsXFxuICAgICAgc291cmNlLWNoYWluOnN0cmluZ1xcbiAgICApXFxuICAgIEBldmVudCB0cnVlXFxuICApXFxuXFxuICA7IHYzIGNhcGFiaWxpdGllc1xcbiAgKGRlZmNhcCBSRUxFQVNFX0FMTE9DQVRJT05cXG4gICAgKCBhY2NvdW50OnN0cmluZ1xcbiAgICAgIGFtb3VudDpkZWNpbWFsXFxuICAgIClcXG4gICAgQGRvYyBcXFwiRXZlbnQgZm9yIGFsbG9jYXRpb24gcmVsZWFzZSwgY2FuIGJlIHVzZWQgZm9yIHNpZyBzY29waW5nLlxcXCJcXG4gICAgQGV2ZW50IHRydWVcXG4gIClcXG5cXG4gIDsgLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS1cXG4gIDsgQ29uc3RhbnRzXFxuXFxuICAoZGVmY29uc3QgQ09JTl9DSEFSU0VUIENIQVJTRVRfTEFUSU4xXFxuICAgIFxcXCJUaGUgZGVmYXVsdCBjb2luIGNvbnRyYWN0IGNoYXJhY3RlciBzZXRcXFwiKVxcblxcbiAgKGRlZmNvbnN0IE1JTklNVU1fUFJFQ0lTSU9OIDEyXFxuICAgIFxcXCJNaW5pbXVtIGFsbG93ZWQgcHJlY2lzaW9uIGZvciBjb2luIHRyYW5zYWN0aW9uc1xcXCIpXFxuXFxuICAoZGVmY29uc3QgTUlOSU1VTV9BQ0NPVU5UX0xFTkdUSCAzXFxuICAgIFxcXCJNaW5pbXVtIGFjY291bnQgbGVuZ3RoIGFkbWlzc2libGUgZm9yIGNvaW4gYWNjb3VudHNcXFwiKVxcblxcbiAgKGRlZmNvbnN0IE1BWElNVU1fQUNDT1VOVF9MRU5HVEggMjU2XFxuICAgIFxcXCJNYXhpbXVtIGFjY291bnQgbmFtZSBsZW5ndGggYWRtaXNzaWJsZSBmb3IgY29pbiBhY2NvdW50c1xcXCIpXFxuXFxuICAoZGVmY29uc3QgVkFMSURfQ0hBSU5fSURTIChtYXAgKGludC10by1zdHIgMTApIChlbnVtZXJhdGUgMCAxOSkpXFxuICAgIFxcXCJMaXN0IG9mIGFsbCB2YWxpZCBDaGFpbndlYiBjaGFpbiBpZHNcXFwiKVxcblxcbiAgOyAtLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLVxcbiAgOyBVdGlsaXRpZXNcXG5cXG4gIChkZWZ1biBlbmZvcmNlLXVuaXQ6Ym9vbCAoYW1vdW50OmRlY2ltYWwpXFxuICAgIEBkb2MgXFxcIkVuZm9yY2UgbWluaW11bSBwcmVjaXNpb24gYWxsb3dlZCBmb3IgY29pbiB0cmFuc2FjdGlvbnNcXFwiXFxuXFxuICAgIChlbmZvcmNlXFxuICAgICAgKD0gKGZsb29yIGFtb3VudCBNSU5JTVVNX1BSRUNJU0lPTilcXG4gICAgICAgICBhbW91bnQpXFxuICAgICAgKGZvcm1hdCBcXFwiQW1vdW50IHZpb2xhdGVzIG1pbmltdW0gcHJlY2lzaW9uOiB7fVxcXCIgW2Ftb3VudF0pKVxcbiAgICApXFxuXFxuICAoZGVmdW4gdmFsaWRhdGUtYWNjb3VudCAoYWNjb3VudDpzdHJpbmcpXFxuICAgIEBkb2MgXFxcIkVuZm9yY2UgdGhhdCBhbiBhY2NvdW50IG5hbWUgY29uZm9ybXMgdG8gdGhlIGNvaW4gY29udHJhY3QgXFxcXFxcbiAgICAgICAgIFxcXFxtaW5pbXVtIGFuZCBtYXhpbXVtIGxlbmd0aCByZXF1aXJlbWVudHMsIGFzIHdlbGwgYXMgdGhlICAgIFxcXFxcXG4gICAgICAgICBcXFxcbGF0aW4tMSBjaGFyYWN0ZXIgc2V0LlxcXCJcXG5cXG4gICAgKGVuZm9yY2VcXG4gICAgICAoaXMtY2hhcnNldCBDT0lOX0NIQVJTRVQgYWNjb3VudClcXG4gICAgICAoZm9ybWF0XFxuICAgICAgICBcXFwiQWNjb3VudCBkb2VzIG5vdCBjb25mb3JtIHRvIHRoZSBjb2luIGNvbnRyYWN0IGNoYXJzZXQ6IHt9XFxcIlxcbiAgICAgICAgW2FjY291bnRdKSlcXG5cXG4gICAgKGxldCAoKGFjY291bnQtbGVuZ3RoIChsZW5ndGggYWNjb3VudCkpKVxcblxcbiAgICAgIChlbmZvcmNlXFxuICAgICAgICAoPj0gYWNjb3VudC1sZW5ndGggTUlOSU1VTV9BQ0NPVU5UX0xFTkdUSClcXG4gICAgICAgIChmb3JtYXRcXG4gICAgICAgICAgXFxcIkFjY291bnQgbmFtZSBkb2VzIG5vdCBjb25mb3JtIHRvIHRoZSBtaW4gbGVuZ3RoIHJlcXVpcmVtZW50OiB7fVxcXCJcXG4gICAgICAgICAgW2FjY291bnRdKSlcXG5cXG4gICAgICAoZW5mb3JjZVxcbiAgICAgICAgKDw9IGFjY291bnQtbGVuZ3RoIE1BWElNVU1fQUNDT1VOVF9MRU5HVEgpXFxuICAgICAgICAoZm9ybWF0XFxuICAgICAgICAgIFxcXCJBY2NvdW50IG5hbWUgZG9lcyBub3QgY29uZm9ybSB0byB0aGUgbWF4IGxlbmd0aCByZXF1aXJlbWVudDoge31cXFwiXFxuICAgICAgICAgIFthY2NvdW50XSkpXFxuICAgICAgKVxcbiAgKVxcblxcbiAgOyAtLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLVxcbiAgOyBDb2luIENvbnRyYWN0XFxuXFxuICAoZGVmdW4gZ2FzLW9ubHkgKClcXG4gICAgXFxcIlByZWRpY2F0ZSBmb3IgZ2FzLW9ubHkgdXNlciBndWFyZHMuXFxcIlxcbiAgICAocmVxdWlyZS1jYXBhYmlsaXR5IChHQVMpKSlcXG5cXG4gIChkZWZ1biBnYXMtZ3VhcmQgKGd1YXJkOmd1YXJkKVxcbiAgICBcXFwiUHJlZGljYXRlIGZvciBnYXMgKyBzaW5nbGUga2V5IHVzZXIgZ3VhcmRzXFxcIlxcbiAgICAoZW5mb3JjZS1vbmVcXG4gICAgICBcXFwiRW5mb3JjZSBlaXRoZXIgdGhlIHByZXNlbmNlIG9mIGEgR0FTIGNhcCBvciBrZXlzZXRcXFwiXFxuICAgICAgWyAoZ2FzLW9ubHkpXFxuICAgICAgICAoZW5mb3JjZS1ndWFyZCBndWFyZClcXG4gICAgICBdKSlcXG5cXG4gIChkZWZ1biBidXktZ2FzOnN0cmluZyAoc2VuZGVyOnN0cmluZyB0b3RhbDpkZWNpbWFsKVxcbiAgICBAZG9jIFxcXCJUaGlzIGZ1bmN0aW9uIGRlc2NyaWJlcyB0aGUgbWFpbiAnZ2FzIGJ1eScgb3BlcmF0aW9uLiBBdCB0aGlzIHBvaW50IFxcXFxcXG4gICAgXFxcXE1JTkVSIGhhcyBiZWVuIGNob3NlbiBmcm9tIHRoZSBwb29sLCBhbmQgd2lsbCBiZSB2YWxpZGF0ZWQuIFRoZSBTRU5ERVIgICBcXFxcXFxuICAgIFxcXFxvZiB0aGlzIHRyYW5zYWN0aW9uIGhhcyBzcGVjaWZpZWQgYSBnYXMgbGltaXQgTElNSVQgKG1heGltdW0gZ2FzKSBmb3IgICAgXFxcXFxcbiAgICBcXFxcdGhlIHRyYW5zYWN0aW9uLCBhbmQgdGhlIHByaWNlIGlzIHRoZSBzcG90IHByaWNlIG9mIGdhcyBhdCB0aGF0IHRpbWUuICAgIFxcXFxcXG4gICAgXFxcXFRoZSBnYXMgYnV5IHdpbGwgYmUgZXhlY3V0ZWQgcHJpb3IgdG8gZXhlY3V0aW5nIFNFTkRFUidzIGNvZGUuXFxcIlxcblxcbiAgICBAbW9kZWwgWyAocHJvcGVydHkgKD4gdG90YWwgMC4wKSlcXG4gICAgICAgICAgICAgKHByb3BlcnR5ICh2YWxpZC1hY2NvdW50IHNlbmRlcikpXFxuICAgICAgICAgICBdXFxuXFxuICAgICh2YWxpZGF0ZS1hY2NvdW50IHNlbmRlcilcXG5cXG4gICAgKGVuZm9yY2UtdW5pdCB0b3RhbClcXG4gICAgKGVuZm9yY2UgKD4gdG90YWwgMC4wKSBcXFwiZ2FzIHN1cHBseSBtdXN0IGJlIGEgcG9zaXRpdmUgcXVhbnRpdHlcXFwiKVxcblxcbiAgICAocmVxdWlyZS1jYXBhYmlsaXR5IChHQVMpKVxcbiAgICAod2l0aC1jYXBhYmlsaXR5IChERUJJVCBzZW5kZXIpXFxuICAgICAgKGRlYml0IHNlbmRlciB0b3RhbCkpXFxuICAgIClcXG5cXG4gIChkZWZ1biByZWRlZW0tZ2FzOnN0cmluZyAobWluZXI6c3RyaW5nIG1pbmVyLWd1YXJkOmd1YXJkIHNlbmRlcjpzdHJpbmcgdG90YWw6ZGVjaW1hbClcXG4gICAgQGRvYyBcXFwiVGhpcyBmdW5jdGlvbiBkZXNjcmliZXMgdGhlIG1haW4gJ3JlZGVlbSBnYXMnIG9wZXJhdGlvbi4gQXQgdGhpcyAgICBcXFxcXFxuICAgIFxcXFxwb2ludCwgdGhlIFNFTkRFUidzIHRyYW5zYWN0aW9uIGhhcyBiZWVuIGV4ZWN1dGVkLCBhbmQgdGhlIGdhcyB0aGF0ICAgICAgXFxcXFxcbiAgICBcXFxcd2FzIGNoYXJnZWQgaGFzIGJlZW4gY2FsY3VsYXRlZC4gTUlORVIgd2lsbCBiZSBjcmVkaXRlZCB0aGUgZ2FzIGNvc3QsICAgIFxcXFxcXG4gICAgXFxcXGFuZCBTRU5ERVIgd2lsbCByZWNlaXZlIHRoZSByZW1haW5kZXIgdXAgdG8gdGhlIGxpbWl0XFxcIlxcblxcbiAgICBAbW9kZWwgWyAocHJvcGVydHkgKD4gdG90YWwgMC4wKSlcXG4gICAgICAgICAgICAgKHByb3BlcnR5ICh2YWxpZC1hY2NvdW50IHNlbmRlcikpXFxuICAgICAgICAgICAgIChwcm9wZXJ0eSAodmFsaWQtYWNjb3VudCBtaW5lcikpXFxuICAgICAgICAgICBdXFxuXFxuICAgICh2YWxpZGF0ZS1hY2NvdW50IHNlbmRlcilcXG4gICAgKHZhbGlkYXRlLWFjY291bnQgbWluZXIpXFxuICAgIChlbmZvcmNlLXVuaXQgdG90YWwpXFxuXFxuICAgIChyZXF1aXJlLWNhcGFiaWxpdHkgKEdBUykpXFxuICAgIChsZXQqXFxuICAgICAgKChmZWUgKHJlYWQtZGVjaW1hbCBcXFwiZmVlXFxcIikpXFxuICAgICAgIChyZWZ1bmQgKC0gdG90YWwgZmVlKSkpXFxuXFxuICAgICAgKGVuZm9yY2UtdW5pdCBmZWUpXFxuICAgICAgKGVuZm9yY2UgKD49IGZlZSAwLjApXFxuICAgICAgICBcXFwiZmVlIG11c3QgYmUgYSBub24tbmVnYXRpdmUgcXVhbnRpdHlcXFwiKVxcblxcbiAgICAgIChlbmZvcmNlICg-PSByZWZ1bmQgMC4wKVxcbiAgICAgICAgXFxcInJlZnVuZCBtdXN0IGJlIGEgbm9uLW5lZ2F0aXZlIHF1YW50aXR5XFxcIilcXG5cXG4gICAgICAoZW1pdC1ldmVudCAoVFJBTlNGRVIgc2VuZGVyIG1pbmVyIGZlZSkpIDt2M1xcblxcbiAgICAgICAgOyBkaXJlY3RseSB1cGRhdGUgaW5zdGVhZCBvZiBjcmVkaXRcXG4gICAgICAod2l0aC1jYXBhYmlsaXR5IChDUkVESVQgc2VuZGVyKVxcbiAgICAgICAgKGlmICg-IHJlZnVuZCAwLjApXFxuICAgICAgICAgICh3aXRoLXJlYWQgY29pbi10YWJsZSBzZW5kZXJcXG4gICAgICAgICAgICB7IFxcXCJiYWxhbmNlXFxcIiA6PSBiYWxhbmNlIH1cXG4gICAgICAgICAgICAodXBkYXRlIGNvaW4tdGFibGUgc2VuZGVyXFxuICAgICAgICAgICAgICB7IFxcXCJiYWxhbmNlXFxcIjogKCsgYmFsYW5jZSByZWZ1bmQpIH0pKVxcblxcbiAgICAgICAgICBcXFwibm9vcFxcXCIpKVxcblxcbiAgICAgICh3aXRoLWNhcGFiaWxpdHkgKENSRURJVCBtaW5lcilcXG4gICAgICAgIChpZiAoPiBmZWUgMC4wKVxcbiAgICAgICAgICAoY3JlZGl0IG1pbmVyIG1pbmVyLWd1YXJkIGZlZSlcXG4gICAgICAgICAgXFxcIm5vb3BcXFwiKSlcXG4gICAgICApXFxuXFxuICAgIClcXG5cXG4gIChkZWZ1biBjcmVhdGUtYWNjb3VudDpzdHJpbmcgKGFjY291bnQ6c3RyaW5nIGd1YXJkOmd1YXJkKVxcbiAgICBAbW9kZWwgWyAocHJvcGVydHkgKHZhbGlkLWFjY291bnQgYWNjb3VudCkpIF1cXG5cXG4gICAgKHZhbGlkYXRlLWFjY291bnQgYWNjb3VudClcXG4gICAgKGVuZm9yY2UtcmVzZXJ2ZWQgYWNjb3VudCBndWFyZClcXG5cXG4gICAgKGluc2VydCBjb2luLXRhYmxlIGFjY291bnRcXG4gICAgICB7IFxcXCJiYWxhbmNlXFxcIiA6IDAuMFxcbiAgICAgICwgXFxcImd1YXJkXFxcIiAgIDogZ3VhcmRcXG4gICAgICB9KVxcbiAgICApXFxuXFxuICAoZGVmdW4gZ2V0LWJhbGFuY2U6ZGVjaW1hbCAoYWNjb3VudDpzdHJpbmcpXFxuICAgICh3aXRoLXJlYWQgY29pbi10YWJsZSBhY2NvdW50XFxuICAgICAgeyBcXFwiYmFsYW5jZVxcXCIgOj0gYmFsYW5jZSB9XFxuICAgICAgYmFsYW5jZVxcbiAgICAgIClcXG4gICAgKVxcblxcbiAgKGRlZnVuIGRldGFpbHM6b2JqZWN0e2Z1bmdpYmxlLXYyLmFjY291bnQtZGV0YWlsc31cXG4gICAgKCBhY2NvdW50OnN0cmluZyApXFxuICAgICh3aXRoLXJlYWQgY29pbi10YWJsZSBhY2NvdW50XFxuICAgICAgeyBcXFwiYmFsYW5jZVxcXCIgOj0gYmFsXFxuICAgICAgLCBcXFwiZ3VhcmRcXFwiIDo9IGcgfVxcbiAgICAgIHsgXFxcImFjY291bnRcXFwiIDogYWNjb3VudFxcbiAgICAgICwgXFxcImJhbGFuY2VcXFwiIDogYmFsXFxuICAgICAgLCBcXFwiZ3VhcmRcXFwiOiBnIH0pXFxuICAgIClcXG5cXG4gIChkZWZ1biByb3RhdGU6c3RyaW5nIChhY2NvdW50OnN0cmluZyBuZXctZ3VhcmQ6Z3VhcmQpXFxuICAgICh3aXRoLWNhcGFiaWxpdHkgKFJPVEFURSBhY2NvdW50KVxcblxcbiAgICAgIDsgQWxsb3cgcm90YXRpb24gb25seSBmb3IgdmFuaXR5IGFjY291bnRzLCBvclxcbiAgICAgIDsgcmUtcm90YXRpbmcgYSBwcmluY2lwYWwgYWNjb3VudCBiYWNrIHRvIGl0cyBwcm9wZXIgZ3VhcmRcXG4gICAgICAoZW5mb3JjZSAob3IgKG5vdCAoaXMtcHJpbmNpcGFsIGFjY291bnQpKVxcbiAgICAgICAgICAgICAgICAgICh2YWxpZGF0ZS1wcmluY2lwYWwgbmV3LWd1YXJkIGFjY291bnQpKVxcbiAgICAgICAgXFxcIkl0IGlzIHVuc2FmZSBmb3IgcHJpbmNpcGFsIGFjY291bnRzIHRvIHJvdGF0ZSB0aGVpciBndWFyZFxcXCIpXFxuXFxuICAgICAgKHdpdGgtcmVhZCBjb2luLXRhYmxlIGFjY291bnRcXG4gICAgICAgIHsgXFxcImd1YXJkXFxcIiA6PSBvbGQtZ3VhcmQgfVxcbiAgICAgICAgKGVuZm9yY2UtZ3VhcmQgb2xkLWd1YXJkKVxcbiAgICAgICAgKHVwZGF0ZSBjb2luLXRhYmxlIGFjY291bnRcXG4gICAgICAgICAgeyBcXFwiZ3VhcmRcXFwiIDogbmV3LWd1YXJkIH1cXG4gICAgICAgICAgKSkpXFxuICAgIClcXG5cXG5cXG4gIChkZWZ1biBwcmVjaXNpb246aW50ZWdlclxcbiAgICAoKVxcbiAgICBNSU5JTVVNX1BSRUNJU0lPTilcXG5cXG4gIChkZWZ1biB0cmFuc2ZlcjpzdHJpbmcgKHNlbmRlcjpzdHJpbmcgcmVjZWl2ZXI6c3RyaW5nIGFtb3VudDpkZWNpbWFsKVxcbiAgICBAbW9kZWwgWyAocHJvcGVydHkgY29uc2VydmVzLW1hc3MpXFxuICAgICAgICAgICAgIChwcm9wZXJ0eSAoPiBhbW91bnQgMC4wKSlcXG4gICAgICAgICAgICAgKHByb3BlcnR5ICh2YWxpZC1hY2NvdW50IHNlbmRlcikpXFxuICAgICAgICAgICAgIChwcm9wZXJ0eSAodmFsaWQtYWNjb3VudCByZWNlaXZlcikpXFxuICAgICAgICAgICAgIChwcm9wZXJ0eSAoIT0gc2VuZGVyIHJlY2VpdmVyKSkgXVxcblxcbiAgICAoZW5mb3JjZSAoIT0gc2VuZGVyIHJlY2VpdmVyKVxcbiAgICAgIFxcXCJzZW5kZXIgY2Fubm90IGJlIHRoZSByZWNlaXZlciBvZiBhIHRyYW5zZmVyXFxcIilcXG5cXG4gICAgKHZhbGlkYXRlLWFjY291bnQgc2VuZGVyKVxcbiAgICAodmFsaWRhdGUtYWNjb3VudCByZWNlaXZlcilcXG5cXG4gICAgKGVuZm9yY2UgKD4gYW1vdW50IDAuMClcXG4gICAgICBcXFwidHJhbnNmZXIgYW1vdW50IG11c3QgYmUgcG9zaXRpdmVcXFwiKVxcblxcbiAgICAoZW5mb3JjZS11bml0IGFtb3VudClcXG5cXG4gICAgKHdpdGgtY2FwYWJpbGl0eSAoVFJBTlNGRVIgc2VuZGVyIHJlY2VpdmVyIGFtb3VudClcXG4gICAgICAoZGViaXQgc2VuZGVyIGFtb3VudClcXG4gICAgICAod2l0aC1yZWFkIGNvaW4tdGFibGUgcmVjZWl2ZXJcXG4gICAgICAgIHsgXFxcImd1YXJkXFxcIiA6PSBnIH1cXG5cXG4gICAgICAgIChjcmVkaXQgcmVjZWl2ZXIgZyBhbW91bnQpKVxcbiAgICAgIClcXG4gICAgKVxcblxcbiAgKGRlZnVuIHRyYW5zZmVyLWNyZWF0ZTpzdHJpbmdcXG4gICAgKCBzZW5kZXI6c3RyaW5nXFxuICAgICAgcmVjZWl2ZXI6c3RyaW5nXFxuICAgICAgcmVjZWl2ZXItZ3VhcmQ6Z3VhcmRcXG4gICAgICBhbW91bnQ6ZGVjaW1hbCApXFxuXFxuICAgIEBtb2RlbCBbIChwcm9wZXJ0eSBjb25zZXJ2ZXMtbWFzcykgXVxcblxcbiAgICAoZW5mb3JjZSAoIT0gc2VuZGVyIHJlY2VpdmVyKVxcbiAgICAgIFxcXCJzZW5kZXIgY2Fubm90IGJlIHRoZSByZWNlaXZlciBvZiBhIHRyYW5zZmVyXFxcIilcXG5cXG4gICAgKHZhbGlkYXRlLWFjY291bnQgc2VuZGVyKVxcbiAgICAodmFsaWRhdGUtYWNjb3VudCByZWNlaXZlcilcXG5cXG4gICAgKGVuZm9yY2UgKD4gYW1vdW50IDAuMClcXG4gICAgICBcXFwidHJhbnNmZXIgYW1vdW50IG11c3QgYmUgcG9zaXRpdmVcXFwiKVxcblxcbiAgICAoZW5mb3JjZS11bml0IGFtb3VudClcXG5cXG4gICAgKHdpdGgtY2FwYWJpbGl0eSAoVFJBTlNGRVIgc2VuZGVyIHJlY2VpdmVyIGFtb3VudClcXG4gICAgICAoZGViaXQgc2VuZGVyIGFtb3VudClcXG4gICAgICAoY3JlZGl0IHJlY2VpdmVyIHJlY2VpdmVyLWd1YXJkIGFtb3VudCkpXFxuICAgIClcXG5cXG4gIChkZWZ1biBjb2luYmFzZTpzdHJpbmcgKGFjY291bnQ6c3RyaW5nIGFjY291bnQtZ3VhcmQ6Z3VhcmQgYW1vdW50OmRlY2ltYWwpXFxuICAgIEBkb2MgXFxcIkludGVybmFsIGZ1bmN0aW9uIGZvciB0aGUgaW5pdGlhbCBjcmVhdGlvbiBvZiBjb2lucy4gIFRoaXMgZnVuY3Rpb24gXFxcXFxcbiAgICBcXFxcY2Fubm90IGJlIHVzZWQgb3V0c2lkZSBvZiB0aGUgY29pbiBjb250cmFjdC5cXFwiXFxuXFxuICAgIEBtb2RlbCBbIChwcm9wZXJ0eSAodmFsaWQtYWNjb3VudCBhY2NvdW50KSlcXG4gICAgICAgICAgICAgKHByb3BlcnR5ICg-IGFtb3VudCAwLjApKVxcbiAgICAgICAgICAgXVxcblxcbiAgICAodmFsaWRhdGUtYWNjb3VudCBhY2NvdW50KVxcbiAgICAoZW5mb3JjZS11bml0IGFtb3VudClcXG5cXG4gICAgKHJlcXVpcmUtY2FwYWJpbGl0eSAoQ09JTkJBU0UpKVxcbiAgICAoZW1pdC1ldmVudCAoVFJBTlNGRVIgXFxcIlxcXCIgYWNjb3VudCBhbW91bnQpKSA7djNcXG4gICAgKHdpdGgtY2FwYWJpbGl0eSAoQ1JFRElUIGFjY291bnQpXFxuICAgICAgKGNyZWRpdCBhY2NvdW50IGFjY291bnQtZ3VhcmQgYW1vdW50KSlcXG4gICAgKVxcblxcbiAgKGRlZnVuIHJlbWVkaWF0ZTpzdHJpbmcgKGFjY291bnQ6c3RyaW5nIGFtb3VudDpkZWNpbWFsKVxcbiAgICBAZG9jIFxcXCJBbGxvd3MgZm9yIHJlbWVkaWF0aW9uIHRyYW5zYWN0aW9ucy4gVGhpcyBmdW5jdGlvbiBcXFxcXFxuICAgICAgICAgXFxcXGlzIHByb3RlY3RlZCBieSB0aGUgUkVNRURJQVRFIGNhcGFiaWxpdHlcXFwiXFxuICAgIEBtb2RlbCBbIChwcm9wZXJ0eSAodmFsaWQtYWNjb3VudCBhY2NvdW50KSlcXG4gICAgICAgICAgICAgKHByb3BlcnR5ICg-IGFtb3VudCAwLjApKVxcbiAgICAgICAgICAgXVxcblxcbiAgICAodmFsaWRhdGUtYWNjb3VudCBhY2NvdW50KVxcblxcbiAgICAoZW5mb3JjZSAoPiBhbW91bnQgMC4wKVxcbiAgICAgIFxcXCJSZW1lZGlhdGlvbiBhbW91bnQgbXVzdCBiZSBwb3NpdGl2ZVxcXCIpXFxuXFxuICAgIChlbmZvcmNlLXVuaXQgYW1vdW50KVxcblxcbiAgICAocmVxdWlyZS1jYXBhYmlsaXR5IChSRU1FRElBVEUpKVxcbiAgICAoZW1pdC1ldmVudCAoVFJBTlNGRVIgXFxcIlxcXCIgYWNjb3VudCBhbW91bnQpKSA7djNcXG4gICAgKHdpdGgtcmVhZCBjb2luLXRhYmxlIGFjY291bnRcXG4gICAgICB7IFxcXCJiYWxhbmNlXFxcIiA6PSBiYWxhbmNlIH1cXG5cXG4gICAgICAoZW5mb3JjZSAoPD0gYW1vdW50IGJhbGFuY2UpIFxcXCJJbnN1ZmZpY2llbnQgZnVuZHNcXFwiKVxcblxcbiAgICAgICh1cGRhdGUgY29pbi10YWJsZSBhY2NvdW50XFxuICAgICAgICB7IFxcXCJiYWxhbmNlXFxcIiA6ICgtIGJhbGFuY2UgYW1vdW50KSB9XFxuICAgICAgICApKVxcbiAgICApXFxuXFxuICAoZGVmcGFjdCBmdW5kLXR4IChzZW5kZXI6c3RyaW5nIG1pbmVyOnN0cmluZyBtaW5lci1ndWFyZDpndWFyZCB0b3RhbDpkZWNpbWFsKVxcbiAgICBAZG9jIFxcXCInZnVuZC10eCcgaXMgYSBzcGVjaWFsIHBhY3QgdG8gZnVuZCBhIHRyYW5zYWN0aW9uIGluIHR3byBzdGVwcywgICAgIFxcXFxcXG4gICAgXFxcXHdpdGggdGhlIGFjdHVhbCB0cmFuc2FjdGlvbiB0cmFuc3BpcmluZyBpbiB0aGUgbWlkZGxlOiAgICAgICAgICAgICAgICAgICBcXFxcXFxuICAgIFxcXFwgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgXFxcXFxcbiAgICBcXFxcICAxKSBBIGJ1eWluZyBwaGFzZSwgZGViaXRpbmcgdGhlIHNlbmRlciBmb3IgdG90YWwgZ2FzIGFuZCBmZWUsIHlpZWxkaW5nIFxcXFxcXG4gICAgXFxcXCAgICAgVFhfTUFYX0NIQVJHRS4gICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICBcXFxcXFxuICAgIFxcXFwgIDIpIEEgc2V0dGxlbWVudCBwaGFzZSwgcmVzdW1pbmcgVFhfTUFYX0NIQVJHRSwgYW5kIGFsbG9jYXRpbmcgdG8gdGhlICAgXFxcXFxcbiAgICBcXFxcICAgICBjb2luYmFzZSBhY2NvdW50IGZvciB1c2VkIGdhcyBhbmQgZmVlLCBhbmQgc2VuZGVyIGFjY291bnQgZm9yIGJhbC0gIFxcXFxcXG4gICAgXFxcXCAgICAgYW5jZSAodW51c2VkIGdhcywgaWYgYW55KS5cXFwiXFxuXFxuICAgIEBtb2RlbCBbIChwcm9wZXJ0eSAoPiB0b3RhbCAwLjApKVxcbiAgICAgICAgICAgICAocHJvcGVydHkgKHZhbGlkLWFjY291bnQgc2VuZGVyKSlcXG4gICAgICAgICAgICAgKHByb3BlcnR5ICh2YWxpZC1hY2NvdW50IG1pbmVyKSlcXG4gICAgICAgICAgICAgOyhwcm9wZXJ0eSBjb25zZXJ2ZXMtbWFzcykgbm90IHN1cHBvcnRlZCB5ZXRcXG4gICAgICAgICAgIF1cXG5cXG4gICAgKHN0ZXAgKGJ1eS1nYXMgc2VuZGVyIHRvdGFsKSlcXG4gICAgKHN0ZXAgKHJlZGVlbS1nYXMgbWluZXIgbWluZXItZ3VhcmQgc2VuZGVyIHRvdGFsKSlcXG4gICAgKVxcblxcbiAgKGRlZnVuIGRlYml0OnN0cmluZyAoYWNjb3VudDpzdHJpbmcgYW1vdW50OmRlY2ltYWwpXFxuICAgIEBkb2MgXFxcIkRlYml0IEFNT1VOVCBmcm9tIEFDQ09VTlQgYmFsYW5jZVxcXCJcXG5cXG4gICAgQG1vZGVsIFsgKHByb3BlcnR5ICg-IGFtb3VudCAwLjApKVxcbiAgICAgICAgICAgICAocHJvcGVydHkgKHZhbGlkLWFjY291bnQgYWNjb3VudCkpXFxuICAgICAgICAgICBdXFxuXFxuICAgICh2YWxpZGF0ZS1hY2NvdW50IGFjY291bnQpXFxuXFxuICAgIChlbmZvcmNlICg-IGFtb3VudCAwLjApXFxuICAgICAgXFxcImRlYml0IGFtb3VudCBtdXN0IGJlIHBvc2l0aXZlXFxcIilcXG5cXG4gICAgKGVuZm9yY2UtdW5pdCBhbW91bnQpXFxuXFxuICAgIChyZXF1aXJlLWNhcGFiaWxpdHkgKERFQklUIGFjY291bnQpKVxcbiAgICAod2l0aC1yZWFkIGNvaW4tdGFibGUgYWNjb3VudFxcbiAgICAgIHsgXFxcImJhbGFuY2VcXFwiIDo9IGJhbGFuY2UgfVxcblxcbiAgICAgIChlbmZvcmNlICg8PSBhbW91bnQgYmFsYW5jZSkgXFxcIkluc3VmZmljaWVudCBmdW5kc1xcXCIpXFxuXFxuICAgICAgKHVwZGF0ZSBjb2luLXRhYmxlIGFjY291bnRcXG4gICAgICAgIHsgXFxcImJhbGFuY2VcXFwiIDogKC0gYmFsYW5jZSBhbW91bnQpIH1cXG4gICAgICAgICkpXFxuICAgIClcXG5cXG5cXG4gIChkZWZ1biBjcmVkaXQ6c3RyaW5nIChhY2NvdW50OnN0cmluZyBndWFyZDpndWFyZCBhbW91bnQ6ZGVjaW1hbClcXG4gICAgQGRvYyBcXFwiQ3JlZGl0IEFNT1VOVCB0byBBQ0NPVU5UIGJhbGFuY2VcXFwiXFxuXFxuICAgIEBtb2RlbCBbIChwcm9wZXJ0eSAoPiBhbW91bnQgMC4wKSlcXG4gICAgICAgICAgICAgKHByb3BlcnR5ICh2YWxpZC1hY2NvdW50IGFjY291bnQpKVxcbiAgICAgICAgICAgXVxcblxcbiAgICAodmFsaWRhdGUtYWNjb3VudCBhY2NvdW50KVxcblxcbiAgICAoZW5mb3JjZSAoPiBhbW91bnQgMC4wKSBcXFwiY3JlZGl0IGFtb3VudCBtdXN0IGJlIHBvc2l0aXZlXFxcIilcXG4gICAgKGVuZm9yY2UtdW5pdCBhbW91bnQpXFxuXFxuICAgIChyZXF1aXJlLWNhcGFiaWxpdHkgKENSRURJVCBhY2NvdW50KSlcXG4gICAgKHdpdGgtZGVmYXVsdC1yZWFkIGNvaW4tdGFibGUgYWNjb3VudFxcbiAgICAgIHsgXFxcImJhbGFuY2VcXFwiIDogLTEuMCwgXFxcImd1YXJkXFxcIiA6IGd1YXJkIH1cXG4gICAgICB7IFxcXCJiYWxhbmNlXFxcIiA6PSBiYWxhbmNlLCBcXFwiZ3VhcmRcXFwiIDo9IHJldGcgfVxcbiAgICAgIDsgd2UgZG9uJ3Qgd2FudCB0byBvdmVyd3JpdGUgYW4gZXhpc3RpbmcgZ3VhcmQgd2l0aCB0aGUgdXNlci1zdXBwbGllZCBvbmVcXG4gICAgICAoZW5mb3JjZSAoPSByZXRnIGd1YXJkKVxcbiAgICAgICAgXFxcImFjY291bnQgZ3VhcmRzIGRvIG5vdCBtYXRjaFxcXCIpXFxuXFxuICAgICAgKGxldCAoKGlzLW5ld1xcbiAgICAgICAgICAgICAoaWYgKD0gYmFsYW5jZSAtMS4wKVxcbiAgICAgICAgICAgICAgICAgKGVuZm9yY2UtcmVzZXJ2ZWQgYWNjb3VudCBndWFyZClcXG4gICAgICAgICAgICAgICBmYWxzZSkpKVxcblxcbiAgICAgICAgKHdyaXRlIGNvaW4tdGFibGUgYWNjb3VudFxcbiAgICAgICAgICB7IFxcXCJiYWxhbmNlXFxcIiA6IChpZiBpcy1uZXcgYW1vdW50ICgrIGJhbGFuY2UgYW1vdW50KSlcXG4gICAgICAgICAgLCBcXFwiZ3VhcmRcXFwiICAgOiByZXRnXFxuICAgICAgICAgIH0pKVxcbiAgICAgICkpXFxuXFxuICAoZGVmdW4gY2hlY2stcmVzZXJ2ZWQ6c3RyaW5nIChhY2NvdW50OnN0cmluZylcXG4gICAgXFxcIiBDaGVja3MgQUNDT1VOVCBmb3IgcmVzZXJ2ZWQgbmFtZSBhbmQgcmV0dXJucyB0eXBlIGlmIFxcXFxcXG4gICAgXFxcXCBmb3VuZCBvciBlbXB0eSBzdHJpbmcuIFJlc2VydmVkIG5hbWVzIHN0YXJ0IHdpdGggYSBcXFxcXFxuICAgIFxcXFwgc2luZ2xlIGNoYXIgYW5kIGNvbG9uLCBlLmcuICdjOmZvbycsIHdoaWNoIHdvdWxkIHJldHVybiAnYycgYXMgdHlwZS5cXFwiXFxuICAgIChsZXQgKChwZnggKHRha2UgMiBhY2NvdW50KSkpXFxuICAgICAgKGlmICg9IFxcXCI6XFxcIiAodGFrZSAtMSBwZngpKSAodGFrZSAxIHBmeCkgXFxcIlxcXCIpKSlcXG5cXG4gIChkZWZ1biBlbmZvcmNlLXJlc2VydmVkOmJvb2wgKGFjY291bnQ6c3RyaW5nIGd1YXJkOmd1YXJkKVxcbiAgICBAZG9jIFxcXCJFbmZvcmNlIHJlc2VydmVkIGFjY291bnQgbmFtZSBwcm90b2NvbHMuXFxcIlxcbiAgICAoaWYgKHZhbGlkYXRlLXByaW5jaXBhbCBndWFyZCBhY2NvdW50KVxcbiAgICAgIHRydWVcXG4gICAgICAobGV0ICgociAoY2hlY2stcmVzZXJ2ZWQgYWNjb3VudCkpKVxcbiAgICAgICAgKGlmICg9IHIgXFxcIlxcXCIpXFxuICAgICAgICAgIHRydWVcXG4gICAgICAgICAgKGlmICg9IHIgXFxcImtcXFwiKVxcbiAgICAgICAgICAgIChlbmZvcmNlIGZhbHNlIFxcXCJTaW5nbGUta2V5IGFjY291bnQgcHJvdG9jb2wgdmlvbGF0aW9uXFxcIilcXG4gICAgICAgICAgICAoZW5mb3JjZSBmYWxzZVxcbiAgICAgICAgICAgICAgKGZvcm1hdCBcXFwiUmVzZXJ2ZWQgcHJvdG9jb2wgZ3VhcmQgdmlvbGF0aW9uOiB7fVxcXCIgW3JdKSlcXG4gICAgICAgICAgICApKSkpKVxcblxcblxcbiAgKGRlZnNjaGVtYSBjcm9zc2NoYWluLXNjaGVtYVxcbiAgICBAZG9jIFxcXCJTY2hlbWEgZm9yIHlpZWxkZWQgdmFsdWUgaW4gY3Jvc3MtY2hhaW4gdHJhbnNmZXJzXFxcIlxcbiAgICByZWNlaXZlcjpzdHJpbmdcXG4gICAgcmVjZWl2ZXItZ3VhcmQ6Z3VhcmRcXG4gICAgYW1vdW50OmRlY2ltYWxcXG4gICAgc291cmNlLWNoYWluOnN0cmluZylcXG5cXG4gIChkZWZwYWN0IHRyYW5zZmVyLWNyb3NzY2hhaW46c3RyaW5nXFxuICAgICggc2VuZGVyOnN0cmluZ1xcbiAgICAgIHJlY2VpdmVyOnN0cmluZ1xcbiAgICAgIHJlY2VpdmVyLWd1YXJkOmd1YXJkXFxuICAgICAgdGFyZ2V0LWNoYWluOnN0cmluZ1xcbiAgICAgIGFtb3VudDpkZWNpbWFsIClcXG5cXG4gICAgQG1vZGVsIFsgKHByb3BlcnR5ICg-IGFtb3VudCAwLjApKVxcbiAgICAgICAgICAgICAocHJvcGVydHkgKHZhbGlkLWFjY291bnQgc2VuZGVyKSlcXG4gICAgICAgICAgICAgKHByb3BlcnR5ICh2YWxpZC1hY2NvdW50IHJlY2VpdmVyKSlcXG4gICAgICAgICAgIF1cXG5cXG4gICAgKHN0ZXBcXG4gICAgICAod2l0aC1jYXBhYmlsaXR5XFxuICAgICAgICAoVFJBTlNGRVJfWENIQUlOIHNlbmRlciByZWNlaXZlciBhbW91bnQgdGFyZ2V0LWNoYWluKVxcblxcbiAgICAgICAgKHZhbGlkYXRlLWFjY291bnQgc2VuZGVyKVxcbiAgICAgICAgKHZhbGlkYXRlLWFjY291bnQgcmVjZWl2ZXIpXFxuXFxuICAgICAgICAoZW5mb3JjZSAoIT0gXFxcIlxcXCIgdGFyZ2V0LWNoYWluKSBcXFwiZW1wdHkgdGFyZ2V0LWNoYWluXFxcIilcXG4gICAgICAgIChlbmZvcmNlICghPSAoYXQgJ2NoYWluLWlkIChjaGFpbi1kYXRhKSkgdGFyZ2V0LWNoYWluKVxcbiAgICAgICAgICBcXFwiY2Fubm90IHJ1biBjcm9zcy1jaGFpbiB0cmFuc2ZlcnMgdG8gdGhlIHNhbWUgY2hhaW5cXFwiKVxcblxcbiAgICAgICAgKGVuZm9yY2UgKD4gYW1vdW50IDAuMClcXG4gICAgICAgICAgXFxcInRyYW5zZmVyIHF1YW50aXR5IG11c3QgYmUgcG9zaXRpdmVcXFwiKVxcblxcbiAgICAgICAgKGVuZm9yY2UtdW5pdCBhbW91bnQpXFxuXFxuICAgICAgICAoZW5mb3JjZSAoY29udGFpbnMgdGFyZ2V0LWNoYWluIFZBTElEX0NIQUlOX0lEUylcXG4gICAgICAgICAgXFxcInRhcmdldCBjaGFpbiBpcyBub3QgYSB2YWxpZCBjaGFpbndlYiBjaGFpbiBpZFxcXCIpXFxuXFxuICAgICAgICA7OyBzdGVwIDEgLSBkZWJpdCBkZWxldGUtYWNjb3VudCBvbiBjdXJyZW50IGNoYWluXFxuICAgICAgICAoZGViaXQgc2VuZGVyIGFtb3VudClcXG4gICAgICAgIChlbWl0LWV2ZW50IChUUkFOU0ZFUiBzZW5kZXIgXFxcIlxcXCIgYW1vdW50KSlcXG5cXG4gICAgICAgIChsZXRcXG4gICAgICAgICAgKChjcm9zc2NoYWluLWRldGFpbHM6b2JqZWN0e2Nyb3NzY2hhaW4tc2NoZW1hfVxcbiAgICAgICAgICAgIHsgXFxcInJlY2VpdmVyXFxcIiA6IHJlY2VpdmVyXFxuICAgICAgICAgICAgLCBcXFwicmVjZWl2ZXItZ3VhcmRcXFwiIDogcmVjZWl2ZXItZ3VhcmRcXG4gICAgICAgICAgICAsIFxcXCJhbW91bnRcXFwiIDogYW1vdW50XFxuICAgICAgICAgICAgLCBcXFwic291cmNlLWNoYWluXFxcIiA6IChhdCAnY2hhaW4taWQgKGNoYWluLWRhdGEpKVxcbiAgICAgICAgICAgIH0pKVxcbiAgICAgICAgICAoeWllbGQgY3Jvc3NjaGFpbi1kZXRhaWxzIHRhcmdldC1jaGFpbilcXG4gICAgICAgICAgKSkpXFxuXFxuICAgIChzdGVwXFxuICAgICAgKHJlc3VtZVxcbiAgICAgICAgeyBcXFwicmVjZWl2ZXJcXFwiIDo9IHJlY2VpdmVyXFxuICAgICAgICAsIFxcXCJyZWNlaXZlci1ndWFyZFxcXCIgOj0gcmVjZWl2ZXItZ3VhcmRcXG4gICAgICAgICwgXFxcImFtb3VudFxcXCIgOj0gYW1vdW50XFxuICAgICAgICAsIFxcXCJzb3VyY2UtY2hhaW5cXFwiIDo9IHNvdXJjZS1jaGFpblxcbiAgICAgICAgfVxcblxcbiAgICAgICAgKGVtaXQtZXZlbnQgKFRSQU5TRkVSIFxcXCJcXFwiIHJlY2VpdmVyIGFtb3VudCkpXFxuICAgICAgICAoZW1pdC1ldmVudCAoVFJBTlNGRVJfWENIQUlOX1JFQ0QgXFxcIlxcXCIgcmVjZWl2ZXIgYW1vdW50IHNvdXJjZS1jaGFpbikpXFxuXFxuICAgICAgICA7OyBzdGVwIDIgLSBjcmVkaXQgY3JlYXRlIGFjY291bnQgb24gdGFyZ2V0IGNoYWluXFxuICAgICAgICAod2l0aC1jYXBhYmlsaXR5IChDUkVESVQgcmVjZWl2ZXIpXFxuICAgICAgICAgIChjcmVkaXQgcmVjZWl2ZXIgcmVjZWl2ZXItZ3VhcmQgYW1vdW50KSlcXG4gICAgICAgICkpXFxuICAgIClcXG5cXG5cXG4gIDsgLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS1cXG4gIDsgQ29pbiBhbGxvY2F0aW9uc1xcblxcbiAgKGRlZnNjaGVtYSBhbGxvY2F0aW9uLXNjaGVtYVxcbiAgICBAZG9jIFxcXCJHZW5lc2lzIGFsbG9jYXRpb24gcmVnaXN0cnlcXFwiXFxuICAgIDtAbW9kZWwgWyAoaW52YXJpYW50ICg-PSBiYWxhbmNlIDAuMCkpIF1cXG5cXG4gICAgYmFsYW5jZTpkZWNpbWFsXFxuICAgIGRhdGU6dGltZVxcbiAgICBndWFyZDpndWFyZFxcbiAgICByZWRlZW1lZDpib29sKVxcblxcbiAgKGRlZnRhYmxlIGFsbG9jYXRpb24tdGFibGU6e2FsbG9jYXRpb24tc2NoZW1hfSlcXG5cXG4gIChkZWZ1biBjcmVhdGUtYWxsb2NhdGlvbi1hY2NvdW50XFxuICAgICggYWNjb3VudDpzdHJpbmdcXG4gICAgICBkYXRlOnRpbWVcXG4gICAgICBrZXlzZXQtcmVmOnN0cmluZ1xcbiAgICAgIGFtb3VudDpkZWNpbWFsXFxuICAgIClcXG5cXG4gICAgQGRvYyBcXFwiQWRkIGFuIGVudHJ5IHRvIHRoZSBjb2luIGFsbG9jYXRpb24gdGFibGUuIFRoaXMgZnVuY3Rpb24gXFxcXFxcbiAgICAgICAgIFxcXFxhbHNvIGNyZWF0ZXMgYSBjb3JyZXNwb25kaW5nIGVtcHR5IGNvaW4gY29udHJhY3QgYWNjb3VudCBcXFxcXFxuICAgICAgICAgXFxcXG9mIHRoZSBzYW1lIG5hbWUgYW5kIGd1YXJkLiBSZXF1aXJlcyBHRU5FU0lTIGNhcGFiaWxpdHkuIFxcXCJcXG5cXG4gICAgQG1vZGVsIFsgKHByb3BlcnR5ICh2YWxpZC1hY2NvdW50IGFjY291bnQpKSBdXFxuXFxuICAgIChyZXF1aXJlLWNhcGFiaWxpdHkgKEdFTkVTSVMpKVxcblxcbiAgICAodmFsaWRhdGUtYWNjb3VudCBhY2NvdW50KVxcbiAgICAoZW5mb3JjZSAoPj0gYW1vdW50IDAuMClcXG4gICAgICBcXFwiYWxsb2NhdGlvbiBhbW91bnQgbXVzdCBiZSBub24tbmVnYXRpdmVcXFwiKVxcblxcbiAgICAoZW5mb3JjZS11bml0IGFtb3VudClcXG5cXG4gICAgKGxldFxcbiAgICAgICgoZ3VhcmQ6Z3VhcmQgKGtleXNldC1yZWYtZ3VhcmQga2V5c2V0LXJlZikpKVxcblxcbiAgICAgIChjcmVhdGUtYWNjb3VudCBhY2NvdW50IGd1YXJkKVxcblxcbiAgICAgIChpbnNlcnQgYWxsb2NhdGlvbi10YWJsZSBhY2NvdW50XFxuICAgICAgICB7IFxcXCJiYWxhbmNlXFxcIiA6IGFtb3VudFxcbiAgICAgICAgLCBcXFwiZGF0ZVxcXCIgOiBkYXRlXFxuICAgICAgICAsIFxcXCJndWFyZFxcXCIgOiBndWFyZFxcbiAgICAgICAgLCBcXFwicmVkZWVtZWRcXFwiIDogZmFsc2VcXG4gICAgICAgIH0pKSlcXG5cXG4gIChkZWZ1biByZWxlYXNlLWFsbG9jYXRpb25cXG4gICAgKCBhY2NvdW50OnN0cmluZyApXFxuXFxuICAgIEBkb2MgXFxcIlJlbGVhc2UgZnVuZHMgYXNzb2NpYXRlZCB3aXRoIGFsbG9jYXRpb24gQUNDT1VOVCBpbnRvIG1haW4gbGVkZ2VyLiAgIFxcXFxcXG4gICAgICAgICBcXFxcQUNDT1VOVCBtdXN0IGFscmVhZHkgZXhpc3QgaW4gbWFpbiBsZWRnZXIuIEFsbG9jYXRpb24gaXMgZGVhY3RpdmF0ZWQgXFxcXFxcbiAgICAgICAgIFxcXFxhZnRlciByZWxlYXNlLlxcXCJcXG4gICAgQG1vZGVsIFsgKHByb3BlcnR5ICh2YWxpZC1hY2NvdW50IGFjY291bnQpKSBdXFxuXFxuICAgICh2YWxpZGF0ZS1hY2NvdW50IGFjY291bnQpXFxuXFxuICAgICh3aXRoLXJlYWQgYWxsb2NhdGlvbi10YWJsZSBhY2NvdW50XFxuICAgICAgeyBcXFwiYmFsYW5jZVxcXCIgOj0gYmFsYW5jZVxcbiAgICAgICwgXFxcImRhdGVcXFwiIDo9IHJlbGVhc2UtdGltZVxcbiAgICAgICwgXFxcInJlZGVlbWVkXFxcIiA6PSByZWRlZW1lZFxcbiAgICAgICwgXFxcImd1YXJkXFxcIiA6PSBndWFyZFxcbiAgICAgIH1cXG5cXG4gICAgICAobGV0ICgoY3Vyci10aW1lOnRpbWUgKGF0ICdibG9jay10aW1lIChjaGFpbi1kYXRhKSkpKVxcblxcbiAgICAgICAgKGVuZm9yY2UgKG5vdCByZWRlZW1lZClcXG4gICAgICAgICAgXFxcImFsbG9jYXRpb24gZnVuZHMgaGF2ZSBhbHJlYWR5IGJlZW4gcmVkZWVtZWRcXFwiKVxcblxcbiAgICAgICAgKGVuZm9yY2VcXG4gICAgICAgICAgKD49IGN1cnItdGltZSByZWxlYXNlLXRpbWUpXFxuICAgICAgICAgIChmb3JtYXQgXFxcImZ1bmRzIGxvY2tlZCB1bnRpbCB7fS4gY3VycmVudCB0aW1lOiB7fVxcXCIgW3JlbGVhc2UtdGltZSBjdXJyLXRpbWVdKSlcXG5cXG4gICAgICAgICh3aXRoLWNhcGFiaWxpdHkgKFJFTEVBU0VfQUxMT0NBVElPTiBhY2NvdW50IGJhbGFuY2UpXFxuXFxuICAgICAgICAoZW5mb3JjZS1ndWFyZCBndWFyZClcXG5cXG4gICAgICAgICh3aXRoLWNhcGFiaWxpdHkgKENSRURJVCBhY2NvdW50KVxcbiAgICAgICAgICAoZW1pdC1ldmVudCAoVFJBTlNGRVIgXFxcIlxcXCIgYWNjb3VudCBiYWxhbmNlKSlcXG4gICAgICAgICAgKGNyZWRpdCBhY2NvdW50IGd1YXJkIGJhbGFuY2UpXFxuXFxuICAgICAgICAgICh1cGRhdGUgYWxsb2NhdGlvbi10YWJsZSBhY2NvdW50XFxuICAgICAgICAgICAgeyBcXFwicmVkZWVtZWRcXFwiIDogdHJ1ZVxcbiAgICAgICAgICAgICwgXFxcImJhbGFuY2VcXFwiIDogMC4wXFxuICAgICAgICAgICAgfSlcXG5cXG4gICAgICAgICAgXFxcIkFsbG9jYXRpb24gc3VjY2Vzc2Z1bGx5IHJlbGVhc2VkIHRvIG1haW4gbGVkZ2VyXFxcIikpXFxuICAgICkpKVxcblxcbilcXG5cXG4oY3JlYXRlLXRhYmxlIGNvaW4tdGFibGUpXFxuKGNyZWF0ZS10YWJsZSBhbGxvY2F0aW9uLXRhYmxlKVxcblwifX0sXCJzaWduZXJzXCI6W10sXCJtZXRhXCI6e1wiY3JlYXRpb25UaW1lXCI6MCxcInR0bFwiOjE3MjgwMCxcImdhc0xpbWl0XCI6MCxcImNoYWluSWRcIjpcIlwiLFwiZ2FzUHJpY2VcIjowLFwic2VuZGVyXCI6XCJcIn0sXCJub25jZVwiOlwiY29pbi1jb250cmFjdC12Ni1pbnN0YWxsXCJ9In0", unsafeFromText "eyJnYXMiOjAsInJlc3VsdCI6eyJzdGF0dXMiOiJzdWNjZXNzIiwiZGF0YSI6IlRhYmxlQ3JlYXRlZCJ9LCJyZXFLZXkiOiJHUklRdTRoQUtrMElEOUY4el8tMHlYeUFLSjMzTVB5VFlNWE9qbFBKbXBJIiwibG9ncyI6IkxKWlA1V2ZFN1VfNGZINWltQm56dE94ZndyWWN0enQtdmNoSkRvUXN2T1EiLCJtZXRhRGF0YSI6bnVsbCwiY29udGludWF0aW9uIjpudWxsLCJ0eElkIjozfQ") + , (unsafeFromText "eyJoYXNoIjoiU0IzVzVFTGl6azl4elNWWk9MX3dsem5VNjh5aUhPQzlwWUhreHBVXzBnbyIsInNpZ3MiOltdLCJjbWQiOiJ7XCJuZXR3b3JrSWRcIjpudWxsLFwicGF5bG9hZFwiOntcImV4ZWNcIjp7XCJkYXRhXCI6bnVsbCxcImNvZGVcIjpcIihpbnRlcmZhY2UgZ2FzLXBheWVyLXYxXFxuXFxuICAoZGVmY2FwIEdBU19QQVlFUjpib29sXFxuICAgICggdXNlcjpzdHJpbmdcXG4gICAgICBsaW1pdDppbnRlZ2VyXFxuICAgICAgcHJpY2U6ZGVjaW1hbFxcbiAgICApXFxuICAgIEBkb2NcXG4gICAgXFxcIiBQcm92aWRlIGEgY2FwYWJpbGl0eSBpbmRpY2F0aW5nIHRoYXQgZGVjbGFyaW5nIG1vZHVsZSBzdXBwb3J0cyBcXFxcXFxuICAgIFxcXFwgZ2FzIHBheW1lbnQgZm9yIFVTRVIgZm9yIGdhcyBMSU1JVCBhbmQgUFJJQ0UuIEZ1bmN0aW9uYWxpdHkgXFxcXFxcbiAgICBcXFxcIHNob3VsZCByZXF1aXJlIGNhcGFiaWxpdHkgKGNvaW4uRlVORF9UWCksIGFuZCBzaG91bGQgdmFsaWRhdGUgXFxcXFxcbiAgICBcXFxcIHRoZSBzcGVuZCBvZiAobGltaXQgKiBwcmljZSksIHBvc3NpYmx5IHVwZGF0aW5nIHNvbWUgZGF0YWJhc2UgXFxcXFxcbiAgICBcXFxcIGVudHJ5LiBcXFxcXFxuICAgIFxcXFwgU2hvdWxkIGNvbXBvc2UgY2FwYWJpbGl0eSByZXF1aXJlZCBmb3IgJ2NyZWF0ZS1nYXMtcGF5ZXItZ3VhcmQnLlxcXCJcXG4gICAgQG1vZGVsXFxuICAgIFsgKHByb3BlcnR5ICh1c2VyICE9IFxcXCJcXFwiKSlcXG4gICAgICAocHJvcGVydHkgKGxpbWl0ID4gMCkpXFxuICAgICAgKHByb3BlcnR5IChwcmljZSA-IDAuMCkpXFxuICAgIF1cXG4gIClcXG5cXG4gIChkZWZ1biBjcmVhdGUtZ2FzLXBheWVyLWd1YXJkOmd1YXJkICgpXFxuICAgIEBkb2NcXG4gICAgXFxcIiBQcm92aWRlIGEgZ3VhcmQgc3VpdGFibGUgZm9yIGNvbnRyb2xsaW5nIGEgY29pbiBhY2NvdW50IHRoYXQgY2FuIFxcXFxcXG4gICAgXFxcXCBwYXkgZ2FzIHZpYSBHQVNfUEFZRVIgbWVjaGFuaWNzLiBHZW5lcmFsbHkgdGhpcyBpcyBhY2NvbXBsaXNoZWQgXFxcXFxcbiAgICBcXFxcIGJ5IGhhdmluZyBHQVNfUEFZRVIgY29tcG9zZSBhbiB1bnBhcmFtZXRlcml6ZWQsIHVubWFuYWdlZCBjYXBhYmlsaXR5IFxcXFxcXG4gICAgXFxcXCB0aGF0IGlzIHJlcXVpcmVkIGluIHRoaXMgZ3VhcmQuIFRodXMsIGlmIGNvaW4gY29udHJhY3QgaXMgYWJsZSB0byBcXFxcXFxuICAgIFxcXFwgc3VjY2Vzc2Z1bGx5IGFjcXVpcmUgR0FTX1BBWUVSLCB0aGUgY29tcG9zZWQgJ2Fub255bW91cycgY2FwIHJlcXVpcmVkIFxcXFxcXG4gICAgXFxcXCBoZXJlIHdpbGwgYmUgaW4gc2NvcGUsIGFuZCBnYXMgYnV5IHdpbGwgc3VjY2VlZC5cXFwiXFxuICApXFxuXFxuKVxcblwifX0sXCJzaWduZXJzXCI6W10sXCJtZXRhXCI6e1wiY3JlYXRpb25UaW1lXCI6MCxcInR0bFwiOjE3MjgwMCxcImdhc0xpbWl0XCI6MCxcImNoYWluSWRcIjpcIlwiLFwiZ2FzUHJpY2VcIjowLFwic2VuZGVyXCI6XCJcIn0sXCJub25jZVwiOlwiZ2VuZXNpcy0wMVwifSJ9", unsafeFromText "eyJnYXMiOjAsInJlc3VsdCI6eyJzdGF0dXMiOiJzdWNjZXNzIiwiZGF0YSI6IkxvYWRlZCBpbnRlcmZhY2UgZ2FzLXBheWVyLXYxLCBoYXNoIGlJV0FQMW9lbl9rcFhqRmJuUU04N0FKUlpJZ3RzZlpjQXdZckV5MjFSV1EifSwicmVxS2V5IjoiU0IzVzVFTGl6azl4elNWWk9MX3dsem5VNjh5aUhPQzlwWUhreHBVXzBnbyIsImxvZ3MiOiJ3TXdXV3hkSFVuU1VOWXJ1RXlISEtTTzUyeGtkVXU0TXBmbE1FcHYyT05FIiwibWV0YURhdGEiOm51bGwsImNvbnRpbnVhdGlvbiI6bnVsbCwidHhJZCI6NH0") + , (unsafeFromText "eyJoYXNoIjoiQ1pteWxXZmllUk1CTXU1dzJFT21wRndLLXQ3YmNPVHM0bUsyYVQzM3VSNCIsInNpZ3MiOltdLCJjbWQiOiJ7XCJuZXR3b3JrSWRcIjpudWxsLFwicGF5bG9hZFwiOntcImV4ZWNcIjp7XCJkYXRhXCI6e1wibnMtYWRtaW4ta2V5c2V0XCI6W1wiMzY4ODIwZjgwYzMyNGJiYzdjMmIwNjEwNjg4YTdkYTQzZTM5ZjkxZDExODczMjY3MWNkOWM3NTAwZmY0M2NjYVwiXSxcIm5zLW9wZXJhdGUta2V5c2V0XCI6W1wiMzY4ODIwZjgwYzMyNGJiYzdjMmIwNjEwNjg4YTdkYTQzZTM5ZjkxZDExODczMjY3MWNkOWM3NTAwZmY0M2NjYVwiXSxcIm5zLWdlbmVzaXMta2V5c2V0XCI6e1wicHJlZFwiOlwiPVwiLFwia2V5c1wiOltdfX0sXCJjb2RlXCI6XCIoZGVmaW5lLWtleXNldCAnbnMtYWRtaW4ta2V5c2V0IChyZWFkLWtleXNldCAnbnMtYWRtaW4ta2V5c2V0KSlcXG4oZGVmaW5lLWtleXNldCAnbnMtb3BlcmF0ZS1rZXlzZXQgKHJlYWQta2V5c2V0ICducy1nZW5lc2lzLWtleXNldCkpXFxuXFxuKG1vZHVsZSBucyBHT1ZFUk5BTkNFXFxuICBcXFwiQWRtaW5pc3RlcnMgZGVmaW5pdGlvbiBvZiBuZXcgbmFtZXNwYWNlcyBpbiBDaGFpbndlYi5cXFwiXFxuXFxuICAoZGVmc2NoZW1hIHJlZy1lbnRyeVxcbiAgICBhZG1pbi1ndWFyZDpndWFyZFxcbiAgICBhY3RpdmU6Ym9vbClcXG5cXG4gIChkZWZ0YWJsZSByZWdpc3RyeTp7cmVnLWVudHJ5fSlcXG5cXG4gIChkZWZjYXAgR09WRVJOQU5DRSAoKVxcbiAgICAoZW5mb3JjZS1rZXlzZXQgJ25zLWFkbWluLWtleXNldCkpXFxuXFxuICAoZGVmY2FwIE9QRVJBVEUgKClcXG4gICAgKGVuZm9yY2Uta2V5c2V0ICducy1vcGVyYXRlLWtleXNldCkpXFxuXFxuICAoZGVmY29uc3QgR1VBUkRfU1VDQ0VTUyAoY3JlYXRlLXVzZXItZ3VhcmQgKHN1Y2Nlc3MpKSlcXG4gIChkZWZjb25zdCBHVUFSRF9GQUlMVVJFIChjcmVhdGUtdXNlci1ndWFyZCAoZmFpbHVyZSkpKVxcblxcbiAgKGRlZnVuIHN1Y2Nlc3MgKClcXG4gICAgdHJ1ZSlcXG4gIChkZWZ1biBmYWlsdXJlICgpXFxuICAgIChlbmZvcmNlIGZhbHNlIFxcXCJEaXNhYmxlZFxcXCIpKVxcblxcbiAgKGRlZnVuIHZhbGlkYXRlLW5hbWUgKG5hbWUpXFxuICAgIChlbmZvcmNlICghPSBcXFwiXFxcIiBuYW1lKSBcXFwiRW1wdHkgbmFtZSBub3QgYWxsb3dlZFxcXCIpXFxuICAgIChlbmZvcmNlICg8IChsZW5ndGggbmFtZSkgNjQpIFxcXCJOYW1lIG11c3QgYmUgbGVzcyB0aGFuIDY0IGNoYXJhY3RlcnMgbG9uZ1xcXCIpXFxuICAgIChlbmZvcmNlIChpcy1jaGFyc2V0IENIQVJTRVRfTEFUSU4xIG5hbWUpXFxuICAgICAgICAgICAgIFxcXCJOYW1lIG11c3QgYmUgaW4gbGF0aW4xIGNoYXJzZXRcXFwiKSlcXG5cXG4gIChkZWZ1biBjcmVhdGUtcHJpbmNpcGFsLW5hbWVzcGFjZTpzdHJpbmdcXG4gICAgICAoIGc6Z3VhcmRcXG4gICAgICAgIClcXG4gICAgXFxcIiBGb3JtYXQgcHJpbmNpcGFsIG5hbWVzcGFjZSBhcyBQYWN0IGhhc2ggKEJMQUtFMmIyNTYpIG9mIHByaW5jaXBhbCBcXFxcXFxuICAgIFxcXFwgaW4gaGV4IHRydW5jYXRlZCB0byAxNjAgYml0cyAoNDAgY2hhcmFjdGVycyksIHByZXBlbmRlZCB3aXRoICduXycuXFxcXFxcbiAgICBcXFxcIE9ubHkgdzogYW5kIGs6IGFjY291bnQgcHJvdG9jb2xzIGFyZSBzdXBwb3J0ZWQuIFxcXCJcXG5cXG4gICAgKGxldFxcbiAgICAgICgodHkgKHR5cGVvZi1wcmluY2lwYWwgKGNyZWF0ZS1wcmluY2lwYWwgZykpKSlcXG5cXG4gICAgICA7OyBvbmx5IHc6IGFuZCBrOiBjdXJyZW50bHkgc3VwcG9ydGVkXFxuICAgICAgKGlmIChvciAoPSB0eSBcXFwiazpcXFwiKSAoPSB0eSBcXFwidzpcXFwiKSlcXG4gICAgICAgICgrIFxcXCJuX1xcXCIgKHRha2UgNDAgKGludC10by1zdHIgMTYgKHN0ci10by1pbnQgNjQgKGhhc2ggZykpKSkpXFxuICAgICAgICAoZW5mb3JjZSBmYWxzZVxcbiAgICAgICAgICAoZm9ybWF0IFxcXCJVbnN1cHBvcnRlZCBndWFyZCBwcm90b2NvbDoge31cXFwiIFt0eV0pKVxcbiAgICAgICAgKSlcXG4gIClcXG5cXG4gIChkZWZ1biB2YWxpZGF0ZTpib29sXFxuICAgICAgKCBucy1uYW1lOnN0cmluZ1xcbiAgICAgICAgbnMtYWRtaW46Z3VhcmRcXG4gICAgICAgIClcXG4gICAgXFxcIiBNYW5hZ2VzIG5hbWVzcGFjZSBpbnN0YWxsIGZvciBDaGFpbndlYi4gXFxcXFxcbiAgICBcXFxcIEFsbG93cyBwcmluY2lwYWwgbmFtZXNwYWNlcy4gXFxcXFxcbiAgICBcXFxcIE5vbi1wcmluY2lwYWwgbmFtZXNwYWNlcyByZXF1aXJlIGFjdGl2ZSByb3cgaW4gcmVnaXN0cnkgXFxcXFxcbiAgICBcXFxcIGZvciBOUy1OQU1FIHdpdGggZ3VhcmQgbWF0Y2hpbmcgTlMtQURNSU4uXFxcIlxcblxcbiAgICAoaWYgKD0gKGNyZWF0ZS1wcmluY2lwYWwtbmFtZXNwYWNlIG5zLWFkbWluKSBucy1uYW1lKVxcblxcbiAgICAgIHRydWUgOzsgYWxsb3cgcHJpbmNpcGFsIG5hbWVzcGFjZXNcXG5cXG4gICAgICAod2l0aC1kZWZhdWx0LXJlYWQgcmVnaXN0cnkgbnMtbmFtZSAgICAgICA7OyBvdGhlcndpc2UgZW5mb3JjZSByZWdpc3RyeVxcbiAgICAgICAgeyAnYWRtaW4tZ3VhcmQgOiBucy1hZG1pblxcbiAgICAgICAgLCAnYWN0aXZlIDogZmFsc2UgfVxcbiAgICAgICAgeyAnYWRtaW4tZ3VhcmQgOj0gYWdcXG4gICAgICAgICwgJ2FjdGl2ZSA6PSBpcy1hY3RpdmUgfVxcblxcbiAgICAgICAgKGVuZm9yY2UgaXMtYWN0aXZlIFxcXCJJbmFjdGl2ZSBvciB1bnJlZ2lzdGVyZWQgbmFtZXNwYWNlXFxcIilcXG4gICAgICAgIChlbmZvcmNlICg9IG5zLWFkbWluIGFnKSBcXFwiQWRtaW4gZ3VhcmQgbXVzdCBtYXRjaCBndWFyZCBpbiByZWdpc3RyeVxcXCIpXFxuXFxuICAgICAgICB0cnVlKVxcbiAgICAgICkpXFxuXFxuICAoZGVmdW4gd3JpdGUtcmVnaXN0cnk6c3RyaW5nXFxuICAgICAgKCBucy1uYW1lOnN0cmluZ1xcbiAgICAgICAgZ3VhcmQ6Z3VhcmRcXG4gICAgICAgIGFjdGl2ZTpib29sXFxuICAgICAgICApXFxuICAgIFxcXCIgV3JpdGUgZW50cnkgd2l0aCBHVUFSRCBhbmQgQUNUSVZFIGludG8gcmVnaXN0cnkgZm9yIE5BTUUuIFxcXFxcXG4gICAgXFxcXCBHdWFyZGVkIGJ5IG9wZXJhdGUga2V5c2V0LiBcXFwiXFxuXFxuICAgICh3aXRoLWNhcGFiaWxpdHkgKE9QRVJBVEUpXFxuXFxuICAgICAgKHZhbGlkYXRlLW5hbWUgbnMtbmFtZSlcXG5cXG4gICAgICAod3JpdGUgcmVnaXN0cnkgbnMtbmFtZVxcbiAgICAgICAgeyAnYWRtaW4tZ3VhcmQ6IGd1YXJkXFxuICAgICAgICAsICdhY3RpdmU6IGFjdGl2ZSB9KVxcblxcbiAgICAgIFxcXCJSZWdpc3RlciBlbnRyeSB3cml0dGVuXFxcIikpXFxuXFxuICAoZGVmdW4gcXVlcnk6b2JqZWN0e3JlZy1lbnRyeX1cXG4gICAgICAoIG5zLW5hbWU6c3RyaW5nIClcXG4gICAgKHJlYWQgcmVnaXN0cnkgbnMtbmFtZSkpXFxuXFxuKVxcblxcbihjcmVhdGUtdGFibGUgcmVnaXN0cnkpXFxuXFxuKHdyaXRlLXJlZ2lzdHJ5IFxcXCJrYWRlbmFcXFwiXFxuICAoa2V5c2V0LXJlZi1ndWFyZCAnbnMtb3BlcmF0ZS1rZXlzZXQpIHRydWUpXFxuKHdyaXRlLXJlZ2lzdHJ5IFxcXCJ1c2VyXFxcIiBHVUFSRF9GQUlMVVJFIHRydWUpXFxuKHdyaXRlLXJlZ2lzdHJ5IFxcXCJmcmVlXFxcIiBHVUFSRF9GQUlMVVJFIHRydWUpXFxuXFxuKGRlZmluZS1uYW1lc3BhY2UgXFxcImthZGVuYVxcXCJcXG4gIChrZXlzZXQtcmVmLWd1YXJkICducy1vcGVyYXRlLWtleXNldClcXG4gIChrZXlzZXQtcmVmLWd1YXJkICducy1vcGVyYXRlLWtleXNldCkpXFxuXFxuKGRlZmluZS1uYW1lc3BhY2UgXFxcInVzZXJcXFwiIEdVQVJEX1NVQ0NFU1MgR1VBUkRfRkFJTFVSRSlcXG4oZGVmaW5lLW5hbWVzcGFjZSBcXFwiZnJlZVxcXCIgR1VBUkRfU1VDQ0VTUyBHVUFSRF9GQUlMVVJFKVxcbjs7cm90YXRlIHRvIHJlYWwgb3BlcmF0ZSBrZXlzZXRcXG4oZGVmaW5lLWtleXNldCAnbnMtb3BlcmF0ZS1rZXlzZXQgKHJlYWQta2V5c2V0ICducy1vcGVyYXRlLWtleXNldCkpXFxuXCJ9fSxcInNpZ25lcnNcIjpbXSxcIm1ldGFcIjp7XCJjcmVhdGlvblRpbWVcIjowLFwidHRsXCI6MTcyODAwLFwiZ2FzTGltaXRcIjowLFwiY2hhaW5JZFwiOlwiXCIsXCJnYXNQcmljZVwiOjAsXCJzZW5kZXJcIjpcIlwifSxcIm5vbmNlXCI6XCJsb2FkLW5zLWRldm5ldC1zZW5kZXIwMFwifSJ9", unsafeFromText "eyJnYXMiOjAsInJlc3VsdCI6eyJzdGF0dXMiOiJzdWNjZXNzIiwiZGF0YSI6IktleXNldCB3cml0ZSBzdWNjZXNzIn0sInJlcUtleSI6IkNabXlsV2ZpZVJNQk11NXcyRU9tcEZ3Sy10N2JjT1RzNG1LMmFUMzN1UjQiLCJsb2dzIjoidDdzQzg1Y1hlWFdSdG90M1lEb2pSejZibWtncEN6enJQQ0Z6QThzTkg3OCIsIm1ldGFEYXRhIjpudWxsLCJjb250aW51YXRpb24iOm51bGwsInR4SWQiOjV9") + , (unsafeFromText "eyJoYXNoIjoiWE5BNmxPSjFXLTdYWXY1WWI0QXFsNzRveFlJN09KcWpPUVQ1b1k0OHEtZyIsInNpZ3MiOltdLCJjbWQiOiJ7XCJuZXR3b3JrSWRcIjpudWxsLFwicGF5bG9hZFwiOntcImV4ZWNcIjp7XCJkYXRhXCI6e1wiYWxsb2NhdGlvbi10ZXN0MDFcIjpbXCI3MDExYzM3OTE0MGZmODk5ZjdlNjEzYWMwYTk3ODRhN2MwYTUxNWQzMGZlMGFiMmIwYzA3ZTVhYTE3NjM1ZTNlXCJdLFwiYWxsb2NhdGlvbjAyXCI6W1wiZTllNGU3MWJkMDYzZGNmN2UwNmJkNWIxYTE2Njg4ODk3ZDE1Y2E4YmQyZTUwOWM0NTNjNjE2MjE5YzE4NmNjNVwiXSxcImFsbG9jYXRpb24wMFwiOltcImQ4MmQwZGNkZTk4MjU1MDVkODZhZmI2ZGNjMTA0MTFkNmI2N2E0MjlhNzllMjFiZGE0YmIxMTliZjI4YWI4NzFcIl0sXCJhbGxvY2F0aW9uLXRlc3QwMlwiOltcIjA2NTQ0ZTIyYmZlZjIzMGQ2ZDIyZjk0ODZhYzZjYjc2YmYyNThlYmZiZjAxMzdlZTU4ZjY1NzQzZTFhNWI4YzRcIl0sXCJhbGxvY2F0aW9uMDFcIjpbXCJiNGM4YTNlYTkxZDMxNDZiMDU2MDk5NDc0MGYwZTNlZWQ5MWM1OWQyZWVjYTFkYzk5ZjBjMjg3Mjg0NWMyOTRkXCJdfSxcImNvZGVcIjpcIihkZWZpbmUta2V5c2V0IFxcXCJhbGxvY2F0aW9uMDBcXFwiIChyZWFkLWtleXNldCBcXFwiYWxsb2NhdGlvbjAwXFxcIikpXFxuKGRlZmluZS1rZXlzZXQgXFxcImFsbG9jYXRpb24wMVxcXCIgKHJlYWQta2V5c2V0IFxcXCJhbGxvY2F0aW9uMDFcXFwiKSlcXG4oZGVmaW5lLWtleXNldCBcXFwiYWxsb2NhdGlvbjAyXFxcIiAocmVhZC1rZXlzZXQgXFxcImFsbG9jYXRpb24wMlxcXCIpKVxcbihkZWZpbmUta2V5c2V0IFxcXCJhbGxvY2F0aW9uLXRlc3QwMVxcXCIgKHJlYWQta2V5c2V0IFxcXCJhbGxvY2F0aW9uLXRlc3QwMVxcXCIpKVxcbihkZWZpbmUta2V5c2V0IFxcXCJhbGxvY2F0aW9uLXRlc3QwMlxcXCIgKHJlYWQta2V5c2V0IFxcXCJhbGxvY2F0aW9uLXRlc3QwMlxcXCIpKVwifX0sXCJzaWduZXJzXCI6W10sXCJtZXRhXCI6e1wiY3JlYXRpb25UaW1lXCI6MCxcInR0bFwiOjE3MjgwMCxcImdhc0xpbWl0XCI6MCxcImNoYWluSWRcIjpcIlwiLFwiZ2FzUHJpY2VcIjowLFwic2VuZGVyXCI6XCJcIn0sXCJub25jZVwiOlwiZGV2bmV0LWtleXNldHNcIn0ifQ", unsafeFromText "eyJnYXMiOjAsInJlc3VsdCI6eyJzdGF0dXMiOiJzdWNjZXNzIiwiZGF0YSI6IktleXNldCB3cml0ZSBzdWNjZXNzIn0sInJlcUtleSI6IlhOQTZsT0oxVy03WFl2NVliNEFxbDc0b3hZSTdPSnFqT1FUNW9ZNDhxLWciLCJsb2dzIjoiYXJRSWpQVGRrcXhoQTNjWl9WaVE3OXM3Uk5XRTlGV2Rha0xWdXl4Nlc0YyIsIm1ldGFEYXRhIjpudWxsLCJjb250aW51YXRpb24iOm51bGwsInR4SWQiOjZ9") + , (unsafeFromText "eyJoYXNoIjoiNWtxZ0tzWWtwbjZCcS1KUnhNYnA1VG9jUWhRWGRJVVNiM1NGQm1Ba3VWcyIsInNpZ3MiOltdLCJjbWQiOiJ7XCJuZXR3b3JrSWRcIjpudWxsLFwicGF5bG9hZFwiOntcImV4ZWNcIjp7XCJkYXRhXCI6bnVsbCxcImNvZGVcIjpcIihjb2luLmNyZWF0ZS1hbGxvY2F0aW9uLWFjY291bnQgXFxcImFsbG9jYXRpb24wMFxcXCIgKHRpbWUgXFxcIjE5MDAtMTAtMTVUMTg6MDA6MDBaXFxcIikgXFxcImFsbG9jYXRpb24wMFxcXCIgMTAwMDAwMC4wKVxcbihjb2luLmNyZWF0ZS1hbGxvY2F0aW9uLWFjY291bnQgXFxcImFsbG9jYXRpb24wMVxcXCIgKHRpbWUgXFxcIjIxMDAtMTAtMzFUMTg6MDA6MDBaXFxcIikgXFxcImFsbG9jYXRpb24wMVxcXCIgMTAwMDAwMC4wKVxcbihjb2luLmNyZWF0ZS1hbGxvY2F0aW9uLWFjY291bnQgXFxcImFsbG9jYXRpb24wMlxcXCIgKHRpbWUgXFxcIjE5MDAtMTAtMzFUMTg6MDA6MDBaXFxcIikgXFxcImFsbG9jYXRpb24wMlxcXCIgMTAwMDAwMC4wKVxcbihjb2luLmNyZWF0ZS1hbGxvY2F0aW9uLWFjY291bnQgXFxcImFsbG9jYXRpb24tdGVzdDAxXFxcIiAodGltZSBcXFwiMTkwMC0xMC0zMVQxODowMDowMFpcXFwiKSBcXFwiYWxsb2NhdGlvbi10ZXN0MDFcXFwiIDEwMDAwMDAuMClcXG4oY29pbi5jcmVhdGUtYWxsb2NhdGlvbi1hY2NvdW50IFxcXCJhbGxvY2F0aW9uLXRlc3QwMlxcXCIgKHRpbWUgXFxcIjE5MDAtMTAtMzFUMTg6MDA6MDBaXFxcIikgXFxcImFsbG9jYXRpb24tdGVzdDAyXFxcIiAyMDAwMDAwLjApXCJ9fSxcInNpZ25lcnNcIjpbXSxcIm1ldGFcIjp7XCJjcmVhdGlvblRpbWVcIjowLFwidHRsXCI6MTcyODAwLFwiZ2FzTGltaXRcIjowLFwiY2hhaW5JZFwiOlwiXCIsXCJnYXNQcmljZVwiOjAsXCJzZW5kZXJcIjpcIlwifSxcIm5vbmNlXCI6XCJkZXZuZXQtYWxsb2NhdGlvbnNcIn0ifQ", unsafeFromText "eyJnYXMiOjAsInJlc3VsdCI6eyJzdGF0dXMiOiJzdWNjZXNzIiwiZGF0YSI6IldyaXRlIHN1Y2NlZWRlZCJ9LCJyZXFLZXkiOiI1a3FnS3NZa3BuNkJxLUpSeE1icDVUb2NRaFFYZElVU2IzU0ZCbUFrdVZzIiwibG9ncyI6IkhpX3ZfVEhFT2s2aEJFRU0yWmV2Vzh3eVJsQWpUZzNjVUQydXBlVkx0b1UiLCJtZXRhRGF0YSI6bnVsbCwiY29udGludWF0aW9uIjpudWxsLCJ0eElkIjo3fQ") + , (unsafeFromText "eyJoYXNoIjoiejJtR1ZxektqeHp5bUdHLWNpWjBCSEpGM1EzeGtvOFYyNEE4ejBxcEl4ayIsInNpZ3MiOltdLCJjbWQiOiJ7XCJuZXR3b3JrSWRcIjpudWxsLFwicGF5bG9hZFwiOntcImV4ZWNcIjp7XCJkYXRhXCI6e1wic2VuZGVyMDdcIjpbXCI0YzMxZGM5ZWU3ZjI0MTc3Zjc4YjZmNTE4MDEyYTIwODMyNmUyYWYxZjM3YmIwYTI0MDViNTA1NmQwY2FkNjI4XCJdLFwic2VuZGVyMDFcIjpbXCI2YmUyZjQ4NWE3YWY3NWZlZGI0YjdmMTUzYTkwM2Y3ZTYwMDBjYTRhYTUwMTE3OWM5MWEyNDUwYjc3N2JkMmE3XCJdLFwic2VuZGVyMDZcIjpbXCI1ZmZjMWY3ZmVmN2E0NDczODYyNTc2MmY3NWE0MjI5NDU0OTUxZTAzZjJhZmM2ZjgxMzA5YzBjMWJkZjllZTZmXCJdLFwic2VuZGVyMDBcIjpbXCIzNjg4MjBmODBjMzI0YmJjN2MyYjA2MTA2ODhhN2RhNDNlMzlmOTFkMTE4NzMyNjcxY2Q5Yzc1MDBmZjQzY2NhXCJdLFwiZTdmN1wiOltcImU3Zjc2MzRlOTI1NTQxZjM2OGI4MjdhZDVjNzI0MjE5MDUxMDBmNjIwNTI4NWE3OGMxOWQ3YjRhMzg3MTE4MDVcIl0sXCJzZW5kZXIwNVwiOltcImYwOWQ4ZjYzOTRhZWE0MjVmZTY3ODNkODhjZDgxMzYzZDgwMTdmMTZhZmQzNzExYzU3NWJlMGY1Y2Q1YzliYjlcIl0sXCJzZW5kZXIwNFwiOltcIjJkNzBhYTRmNjk3YzNhM2I4ZGQ2ZDk3NzQ1YWMwNzRlZGNmZDBlYjY1YzM3Nzc0Y2RlMjUxMzU0ODNiZWE3MWVcIl0sXCJtdWx0aS0wMi0wMy0wNC1hbnlcIjp7XCJwcmVkXCI6XCJrZXlzLWFueVwiLFwia2V5c1wiOltcIjJkNzBhYTRmNjk3YzNhM2I4ZGQ2ZDk3NzQ1YWMwNzRlZGNmZDBlYjY1YzM3Nzc0Y2RlMjUxMzU0ODNiZWE3MWVcIixcIjNhOWRkNTMyZDczZGFjZTE5NWRiYjY0ZDFkYmE2NTcyZmI3ODNkMGZkZDMyNDY4NWUzMmZiZGEyZjg5Zjk5YTZcIixcIjQzZjJhZGIxZGUxOTIwMDBjYjM3NzdiYWNjN2Y5ODNiNjYxNGZkOWMxNzE1Y2Q0NGNkNDg0YjZkM2EwZDM0YzhcIl19LFwic2VuZGVyMDlcIjpbXCJjNTlkOTg0MGIwYjY2MDkwODM2NTQ2YjdlYjRhNzM2MDYyNTc1MjdlYzhjMmI0ODIzMDBmZDIyOTI2NGIwN2U2XCJdLFwic2VuZGVyMDNcIjpbXCI0M2YyYWRiMWRlMTkyMDAwY2IzNzc3YmFjYzdmOTgzYjY2MTRmZDljMTcxNWNkNDRjZDQ4NGI2ZDNhMGQzNGM4XCJdLFwibXVsdGktMDAtMDFcIjpbXCIzNjg4MjBmODBjMzI0YmJjN2MyYjA2MTA2ODhhN2RhNDNlMzlmOTFkMTE4NzMyNjcxY2Q5Yzc1MDBmZjQzY2NhXCIsXCI2YmUyZjQ4NWE3YWY3NWZlZGI0YjdmMTUzYTkwM2Y3ZTYwMDBjYTRhYTUwMTE3OWM5MWEyNDUwYjc3N2JkMmE3XCJdLFwic2VuZGVyMDhcIjpbXCI2M2IyZWJhNGVkNzBkNDYxMmQzZTdiYzkwZGIyZmJmNGM3NmY3YjA3NDM2M2U4NmQ3M2YwYmM2MTdmOGU4YjgxXCJdLFwic2VuZGVyMDJcIjpbXCIzYTlkZDUzMmQ3M2RhY2UxOTVkYmI2NGQxZGJhNjU3MmZiNzgzZDBmZGQzMjQ2ODVlMzJmYmRhMmY4OWY5OWE2XCJdfSxcImNvZGVcIjpcIihjb2luLmNvaW5iYXNlIFxcXCJzZW5kZXIwMFxcXCIgKHJlYWQta2V5c2V0IFxcXCJzZW5kZXIwMFxcXCIpIDEwMDAwMDAwMC4wKVxcbihjb2luLmNvaW5iYXNlIFxcXCJzZW5kZXIwMVxcXCIgKHJlYWQta2V5c2V0IFxcXCJzZW5kZXIwMVxcXCIpIDExMDAwMDAwMC4wKVxcbihjb2luLmNvaW5iYXNlIFxcXCJzZW5kZXIwMlxcXCIgKHJlYWQta2V5c2V0IFxcXCJzZW5kZXIwMlxcXCIpIDEyMDAwMDAwMC4wKVxcbihjb2luLmNvaW5iYXNlIFxcXCJzZW5kZXIwM1xcXCIgKHJlYWQta2V5c2V0IFxcXCJzZW5kZXIwM1xcXCIpIDEzMDAwMDAwMC4wKVxcbihjb2luLmNvaW5iYXNlIFxcXCJzZW5kZXIwNFxcXCIgKHJlYWQta2V5c2V0IFxcXCJzZW5kZXIwNFxcXCIpIDE0MDAwMDAwMC4wKVxcbihjb2luLmNvaW5iYXNlIFxcXCJzZW5kZXIwNVxcXCIgKHJlYWQta2V5c2V0IFxcXCJzZW5kZXIwNVxcXCIpIDE1MDAwMDAwMC4wKVxcbihjb2luLmNvaW5iYXNlIFxcXCJzZW5kZXIwNlxcXCIgKHJlYWQta2V5c2V0IFxcXCJzZW5kZXIwNlxcXCIpIDE2MDAwMDAwMC4wKVxcbihjb2luLmNvaW5iYXNlIFxcXCJzZW5kZXIwN1xcXCIgKHJlYWQta2V5c2V0IFxcXCJzZW5kZXIwN1xcXCIpIDE3MDAwMDAwMC4wKVxcbihjb2luLmNvaW5iYXNlIFxcXCJzZW5kZXIwOFxcXCIgKHJlYWQta2V5c2V0IFxcXCJzZW5kZXIwOFxcXCIpIDE4MDAwMDAwMC4wKVxcbihjb2luLmNvaW5iYXNlIFxcXCJzZW5kZXIwOVxcXCIgKHJlYWQta2V5c2V0IFxcXCJzZW5kZXIwOVxcXCIpIDE5MDAwMDAwMC4wKVxcbihjb2luLmNvaW5iYXNlIFxcXCJtdWx0aS0wMC0wMVxcXCIgKHJlYWQta2V5c2V0IFxcXCJtdWx0aS0wMC0wMVxcXCIpIDEwMTAwMDAwMC4wKVxcbihjb2luLmNvaW5iYXNlIFxcXCJtdWx0aS0wMi0wMy0wNC1hbnlcXFwiIChyZWFkLWtleXNldCBcXFwibXVsdGktMDItMDMtMDQtYW55XFxcIikgMTIzNDAwMDAwLjApXFxuXFxuKGNvaW4uY29pbmJhc2UgXFxcImU3Zjc2MzRlOTI1NTQxZjM2OGI4MjdhZDVjNzI0MjE5MDUxMDBmNjIwNTI4NWE3OGMxOWQ3YjRhMzg3MTE4MDVcXFwiIChyZWFkLWtleXNldCBcXFwiZTdmN1xcXCIpIDE1MC4wKVxcblxcbjsgZW5vdWdoIHRvIGNvdmVyIHRoZSBnYXMgY29zdHMgZm9yIGFsbG9jYXRpb24gcmVsZWFzZVxcbihjb2luLmNvaW5iYXNlIFxcXCJhbGxvY2F0aW9uMDBcXFwiIChrZXlzZXQtcmVmLWd1YXJkIFxcXCJhbGxvY2F0aW9uMDBcXFwiKSAxMDAwMDAuMClcXG4oY29pbi5jb2luYmFzZSBcXFwiYWxsb2NhdGlvbjAxXFxcIiAoa2V5c2V0LXJlZi1ndWFyZCBcXFwiYWxsb2NhdGlvbjAxXFxcIikgMTAwMDAwLjApXFxuKGNvaW4uY29pbmJhc2UgXFxcImFsbG9jYXRpb24wMlxcXCIgKGtleXNldC1yZWYtZ3VhcmQgXFxcImFsbG9jYXRpb24wMlxcXCIpIDEwMDAwMC4wKVwifX0sXCJzaWduZXJzXCI6W10sXCJtZXRhXCI6e1wiY3JlYXRpb25UaW1lXCI6MCxcInR0bFwiOjE3MjgwMCxcImdhc0xpbWl0XCI6MCxcImNoYWluSWRcIjpcIlwiLFwiZ2FzUHJpY2VcIjowLFwic2VuZGVyXCI6XCJcIn0sXCJub25jZVwiOlwiZGV2bmV0LWdyYW50czBcIn0ifQ", unsafeFromText "eyJnYXMiOjAsInJlc3VsdCI6eyJzdGF0dXMiOiJzdWNjZXNzIiwiZGF0YSI6IldyaXRlIHN1Y2NlZWRlZCJ9LCJyZXFLZXkiOiJ6Mm1HVnF6S2p4enltR0ctY2laMEJISkYzUTN4a284VjI0QTh6MHFwSXhrIiwibG9ncyI6ImFCUXM2aDJGVUN1a00tM0pjQmdLZGFvRU1Ta3p2OTJkM0VmT2t5MXNrMmciLCJldmVudHMiOlt7InBhcmFtcyI6WyIiLCJzZW5kZXIwMCIsMTAwMDAwMDAwXSwibmFtZSI6IlRSQU5TRkVSIiwibW9kdWxlIjp7Im5hbWVzcGFjZSI6bnVsbCwibmFtZSI6ImNvaW4ifSwibW9kdWxlSGFzaCI6IjNpSUJRZEpuc3Q0NFoyWmdYb0hQa0FhdXliSjBoODVsX2VuX1NHSE5pYkUifSx7InBhcmFtcyI6WyIiLCJzZW5kZXIwMSIsMTEwMDAwMDAwXSwibmFtZSI6IlRSQU5TRkVSIiwibW9kdWxlIjp7Im5hbWVzcGFjZSI6bnVsbCwibmFtZSI6ImNvaW4ifSwibW9kdWxlSGFzaCI6IjNpSUJRZEpuc3Q0NFoyWmdYb0hQa0FhdXliSjBoODVsX2VuX1NHSE5pYkUifSx7InBhcmFtcyI6WyIiLCJzZW5kZXIwMiIsMTIwMDAwMDAwXSwibmFtZSI6IlRSQU5TRkVSIiwibW9kdWxlIjp7Im5hbWVzcGFjZSI6bnVsbCwibmFtZSI6ImNvaW4ifSwibW9kdWxlSGFzaCI6IjNpSUJRZEpuc3Q0NFoyWmdYb0hQa0FhdXliSjBoODVsX2VuX1NHSE5pYkUifSx7InBhcmFtcyI6WyIiLCJzZW5kZXIwMyIsMTMwMDAwMDAwXSwibmFtZSI6IlRSQU5TRkVSIiwibW9kdWxlIjp7Im5hbWVzcGFjZSI6bnVsbCwibmFtZSI6ImNvaW4ifSwibW9kdWxlSGFzaCI6IjNpSUJRZEpuc3Q0NFoyWmdYb0hQa0FhdXliSjBoODVsX2VuX1NHSE5pYkUifSx7InBhcmFtcyI6WyIiLCJzZW5kZXIwNCIsMTQwMDAwMDAwXSwibmFtZSI6IlRSQU5TRkVSIiwibW9kdWxlIjp7Im5hbWVzcGFjZSI6bnVsbCwibmFtZSI6ImNvaW4ifSwibW9kdWxlSGFzaCI6IjNpSUJRZEpuc3Q0NFoyWmdYb0hQa0FhdXliSjBoODVsX2VuX1NHSE5pYkUifSx7InBhcmFtcyI6WyIiLCJzZW5kZXIwNSIsMTUwMDAwMDAwXSwibmFtZSI6IlRSQU5TRkVSIiwibW9kdWxlIjp7Im5hbWVzcGFjZSI6bnVsbCwibmFtZSI6ImNvaW4ifSwibW9kdWxlSGFzaCI6IjNpSUJRZEpuc3Q0NFoyWmdYb0hQa0FhdXliSjBoODVsX2VuX1NHSE5pYkUifSx7InBhcmFtcyI6WyIiLCJzZW5kZXIwNiIsMTYwMDAwMDAwXSwibmFtZSI6IlRSQU5TRkVSIiwibW9kdWxlIjp7Im5hbWVzcGFjZSI6bnVsbCwibmFtZSI6ImNvaW4ifSwibW9kdWxlSGFzaCI6IjNpSUJRZEpuc3Q0NFoyWmdYb0hQa0FhdXliSjBoODVsX2VuX1NHSE5pYkUifSx7InBhcmFtcyI6WyIiLCJzZW5kZXIwNyIsMTcwMDAwMDAwXSwibmFtZSI6IlRSQU5TRkVSIiwibW9kdWxlIjp7Im5hbWVzcGFjZSI6bnVsbCwibmFtZSI6ImNvaW4ifSwibW9kdWxlSGFzaCI6IjNpSUJRZEpuc3Q0NFoyWmdYb0hQa0FhdXliSjBoODVsX2VuX1NHSE5pYkUifSx7InBhcmFtcyI6WyIiLCJzZW5kZXIwOCIsMTgwMDAwMDAwXSwibmFtZSI6IlRSQU5TRkVSIiwibW9kdWxlIjp7Im5hbWVzcGFjZSI6bnVsbCwibmFtZSI6ImNvaW4ifSwibW9kdWxlSGFzaCI6IjNpSUJRZEpuc3Q0NFoyWmdYb0hQa0FhdXliSjBoODVsX2VuX1NHSE5pYkUifSx7InBhcmFtcyI6WyIiLCJzZW5kZXIwOSIsMTkwMDAwMDAwXSwibmFtZSI6IlRSQU5TRkVSIiwibW9kdWxlIjp7Im5hbWVzcGFjZSI6bnVsbCwibmFtZSI6ImNvaW4ifSwibW9kdWxlSGFzaCI6IjNpSUJRZEpuc3Q0NFoyWmdYb0hQa0FhdXliSjBoODVsX2VuX1NHSE5pYkUifSx7InBhcmFtcyI6WyIiLCJtdWx0aS0wMC0wMSIsMTAxMDAwMDAwXSwibmFtZSI6IlRSQU5TRkVSIiwibW9kdWxlIjp7Im5hbWVzcGFjZSI6bnVsbCwibmFtZSI6ImNvaW4ifSwibW9kdWxlSGFzaCI6IjNpSUJRZEpuc3Q0NFoyWmdYb0hQa0FhdXliSjBoODVsX2VuX1NHSE5pYkUifSx7InBhcmFtcyI6WyIiLCJtdWx0aS0wMi0wMy0wNC1hbnkiLDEyMzQwMDAwMF0sIm5hbWUiOiJUUkFOU0ZFUiIsIm1vZHVsZSI6eyJuYW1lc3BhY2UiOm51bGwsIm5hbWUiOiJjb2luIn0sIm1vZHVsZUhhc2giOiIzaUlCUWRKbnN0NDRaMlpnWG9IUGtBYXV5YkowaDg1bF9lbl9TR0hOaWJFIn0seyJwYXJhbXMiOlsiIiwiZTdmNzYzNGU5MjU1NDFmMzY4YjgyN2FkNWM3MjQyMTkwNTEwMGY2MjA1Mjg1YTc4YzE5ZDdiNGEzODcxMTgwNSIsMTUwXSwibmFtZSI6IlRSQU5TRkVSIiwibW9kdWxlIjp7Im5hbWVzcGFjZSI6bnVsbCwibmFtZSI6ImNvaW4ifSwibW9kdWxlSGFzaCI6IjNpSUJRZEpuc3Q0NFoyWmdYb0hQa0FhdXliSjBoODVsX2VuX1NHSE5pYkUifSx7InBhcmFtcyI6WyIiLCJhbGxvY2F0aW9uMDAiLDEwMDAwMF0sIm5hbWUiOiJUUkFOU0ZFUiIsIm1vZHVsZSI6eyJuYW1lc3BhY2UiOm51bGwsIm5hbWUiOiJjb2luIn0sIm1vZHVsZUhhc2giOiIzaUlCUWRKbnN0NDRaMlpnWG9IUGtBYXV5YkowaDg1bF9lbl9TR0hOaWJFIn0seyJwYXJhbXMiOlsiIiwiYWxsb2NhdGlvbjAxIiwxMDAwMDBdLCJuYW1lIjoiVFJBTlNGRVIiLCJtb2R1bGUiOnsibmFtZXNwYWNlIjpudWxsLCJuYW1lIjoiY29pbiJ9LCJtb2R1bGVIYXNoIjoiM2lJQlFkSm5zdDQ0WjJaZ1hvSFBrQWF1eWJKMGg4NWxfZW5fU0dITmliRSJ9LHsicGFyYW1zIjpbIiIsImFsbG9jYXRpb24wMiIsMTAwMDAwXSwibmFtZSI6IlRSQU5TRkVSIiwibW9kdWxlIjp7Im5hbWVzcGFjZSI6bnVsbCwibmFtZSI6ImNvaW4ifSwibW9kdWxlSGFzaCI6IjNpSUJRZEpuc3Q0NFoyWmdYb0hQa0FhdXliSjBoODVsX2VuX1NHSE5pYkUifV0sIm1ldGFEYXRhIjpudWxsLCJjb250aW51YXRpb24iOm51bGwsInR4SWQiOjh9") ] diff --git a/src/Chainweb/BlockHeader/Genesis/InstantTimedCPM1to9Payload.hs b/src/Chainweb/BlockHeader/Genesis/InstantTimedCPM1to9Payload.hs index e5352c2192..4dd374172f 100644 --- a/src/Chainweb/BlockHeader/Genesis/InstantTimedCPM1to9Payload.hs +++ b/src/Chainweb/BlockHeader/Genesis/InstantTimedCPM1to9Payload.hs @@ -8,7 +8,7 @@ import qualified Data.Text as T import qualified Data.Vector as V import GHC.Stack -import Chainweb.Payload +import Chainweb.Pact.Payload import Chainweb.Utils (unsafeFromText, toText) payloadBlock :: HasCallStack => PayloadWithOutputs @@ -21,19 +21,19 @@ payloadBlock where actualHash, expectedHash :: BlockPayloadHash actualHash = _payloadWithOutputsPayloadHash payload - expectedHash = unsafeFromText "66JSEmDIl6AqWTKN29LprukaeUmK0OOd4RufVO8e6-4" + expectedHash = unsafeFromText "jrfVQ_AVbtnWRVXeUhyNurrz1XXl37sofUfEBh7EBG0" payload = newPayloadWithOutputs minerData coinbase txs minerData = unsafeFromText "eyJhY2NvdW50IjoiTm9NaW5lciIsInByZWRpY2F0ZSI6IjwiLCJwdWJsaWMta2V5cyI6W119" coinbase = unsafeFromText "eyJnYXMiOjAsInJlc3VsdCI6eyJzdGF0dXMiOiJzdWNjZXNzIiwiZGF0YSI6Ik5PX0NPSU5CQVNFIn0sInJlcUtleSI6IkRsZFJ3Q2JsUTdMb3F5NndZSm5hb2RIbDMwZDNqM2VILXF0RnpmRXY0NmciLCJsb2dzIjpudWxsLCJtZXRhRGF0YSI6bnVsbCwiY29udGludWF0aW9uIjpudWxsLCJ0eElkIjpudWxsfQ" txs = V.fromList - [ (unsafeFromText "eyJoYXNoIjoiNDhUMExqQW5TRnBGV3h2dmFQVi1fNkUtQ2pEQVBoV1lVRldidnlmMmxGcyIsInNpZ3MiOltdLCJjbWQiOiJ7XCJuZXR3b3JrSWRcIjpudWxsLFwicGF5bG9hZFwiOntcImV4ZWNcIjp7XCJkYXRhXCI6bnVsbCxcImNvZGVcIjpcIihpbnRlcmZhY2UgZnVuZ2libGUtdjFcXG5cXG4gIFxcXCIgU3RhbmRhcmQgZm9yIGZ1bmdpYmxlIGNvaW5zIGFuZCB0b2tlbnMgYXMgc3BlY2lmaWVkIGluIEtJUC0wMDAyLiBcXFwiXFxuXFxuICAgOyAtLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tXFxuICAgOyBTY2hlbWFcXG5cXG4gICAoZGVmc2NoZW1hIGFjY291bnQtZGV0YWlsc1xcbiAgICBAZG9jIFxcXCJTY2hlbWEgZm9yIHJlc3VsdHMgb2YgJ2FjY291bnQnIG9wZXJhdGlvbi5cXFwiXFxuICAgIEBtb2RlbCBbIChpbnZhcmlhbnQgKCE9IFxcXCJcXFwiIHNlbmRlcikpIF1cXG5cXG4gICAgYWNjb3VudDpzdHJpbmdcXG4gICAgYmFsYW5jZTpkZWNpbWFsXFxuICAgIGd1YXJkOmd1YXJkKVxcblxcblxcbiAgIDsgLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLVxcbiAgIDsgQ2Fwc1xcblxcbiAgIChkZWZjYXAgVFJBTlNGRVI6Ym9vbFxcbiAgICAgKCBzZW5kZXI6c3RyaW5nXFxuICAgICAgIHJlY2VpdmVyOnN0cmluZ1xcbiAgICAgICBhbW91bnQ6ZGVjaW1hbFxcbiAgICAgKVxcbiAgICAgQGRvYyBcXFwiIE1hbmFnZWQgY2FwYWJpbGl0eSBzZWFsaW5nIEFNT1VOVCBmb3IgdHJhbnNmZXIgZnJvbSBTRU5ERVIgdG8gXFxcXFxcbiAgICAgICAgICBcXFxcIFJFQ0VJVkVSLiBQZXJtaXRzIGFueSBudW1iZXIgb2YgdHJhbnNmZXJzIHVwIHRvIEFNT1VOVC5cXFwiXFxuICAgICBAbWFuYWdlZCBhbW91bnQgVFJBTlNGRVItbWdyXFxuICAgICApXFxuXFxuICAgKGRlZnVuIFRSQU5TRkVSLW1ncjpkZWNpbWFsXFxuICAgICAoIG1hbmFnZWQ6ZGVjaW1hbFxcbiAgICAgICByZXF1ZXN0ZWQ6ZGVjaW1hbFxcbiAgICAgKVxcbiAgICAgQGRvYyBcXFwiIE1hbmFnZXMgVFJBTlNGRVIgQU1PVU5UIGxpbmVhcmx5LCBcXFxcXFxuICAgICAgICAgIFxcXFwgc3VjaCB0aGF0IGEgcmVxdWVzdCBmb3IgMS4wIGFtb3VudCBvbiBhIDMuMCBcXFxcXFxuICAgICAgICAgIFxcXFwgbWFuYWdlZCBxdWFudGl0eSBlbWl0cyB1cGRhdGVkIGFtb3VudCAyLjAuXFxcIlxcbiAgICAgKVxcblxcbiAgIDsgLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLVxcbiAgIDsgRnVuY3Rpb25hbGl0eVxcblxcbiAgIChkZWZ1biB0cmFuc2Zlci1jcmVhdGU6c3RyaW5nXFxuICAgICAoIHNlbmRlcjpzdHJpbmdcXG4gICAgICAgcmVjZWl2ZXI6c3RyaW5nXFxuICAgICAgIHJlY2VpdmVyLWd1YXJkOmd1YXJkXFxuICAgICAgIGFtb3VudDpkZWNpbWFsXFxuICAgICApXFxuICAgICBAZG9jIFxcXCIgVHJhbnNmZXIgQU1PVU5UIGJldHdlZW4gYWNjb3VudHMgU0VOREVSIGFuZCBSRUNFSVZFUi4gXFxcXFxcbiAgICAgICAgICBcXFxcIEZhaWxzIGlmIFNFTkRFUiBkb2VzIG5vdCBleGlzdC4gSWYgUkVDRUlWRVIgZXhpc3RzLCBndWFyZCBcXFxcXFxuICAgICAgICAgIFxcXFwgbXVzdCBtYXRjaCBleGlzdGluZyB2YWx1ZS4gSWYgUkVDRUlWRVIgZG9lcyBub3QgZXhpc3QsIFxcXFxcXG4gICAgICAgICAgXFxcXCBSRUNFSVZFUiBhY2NvdW50IGlzIGNyZWF0ZWQgdXNpbmcgUkVDRUlWRVItR1VBUkQuIFxcXFxcXG4gICAgICAgICAgXFxcXCBTdWJqZWN0IHRvIG1hbmFnZW1lbnQgYnkgVFJBTlNGRVIgY2FwYWJpbGl0eS5cXFwiXFxuICAgICBAbW9kZWwgWyAocHJvcGVydHkgKD4gYW1vdW50IDAuMCkpXFxuICAgICAgICAgICAgICAocHJvcGVydHkgKCE9IHNlbmRlciBcXFwiXFxcIikpXFxuICAgICAgICAgICAgICAocHJvcGVydHkgKCE9IHJlY2VpdmVyIFxcXCJcXFwiKSlcXG4gICAgICAgICAgICAgIChwcm9wZXJ0eSAoIT0gc2VuZGVyIHJlY2VpdmVyKSlcXG4gICAgICAgICAgICBdXFxuICAgICApXFxuXFxuICAgKGRlZnBhY3QgdHJhbnNmZXItY3Jvc3NjaGFpbjpzdHJpbmdcXG4gICAgICggc2VuZGVyOnN0cmluZ1xcbiAgICAgICByZWNlaXZlcjpzdHJpbmdcXG4gICAgICAgcmVjZWl2ZXItZ3VhcmQ6Z3VhcmRcXG4gICAgICAgdGFyZ2V0LWNoYWluOnN0cmluZ1xcbiAgICAgICBhbW91bnQ6ZGVjaW1hbFxcbiAgICAgKVxcbiAgICAgQGRvYyBcXFwiIDItc3RlcCBwYWN0IHRvIHRyYW5zZmVyIEFNT1VOVCBmcm9tIFNFTkRFUiBvbiBjdXJyZW50IGNoYWluIFxcXFxcXG4gICAgICAgICAgXFxcXCB0byBSRUNFSVZFUiBvbiBUQVJHRVQtQ0hBSU4gdmlhIFNQViBwcm9vZi4gXFxcXFxcbiAgICAgICAgICBcXFxcIFRBUkdFVC1DSEFJTiBtdXN0IGJlIGRpZmZlcmVudCB0aGFuIGN1cnJlbnQgY2hhaW4gaWQuIFxcXFxcXG4gICAgICAgICAgXFxcXCBGaXJzdCBzdGVwIGRlYml0cyBBTU9VTlQgY29pbnMgaW4gU0VOREVSIGFjY291bnQgYW5kIHlpZWxkcyBcXFxcXFxuICAgICAgICAgIFxcXFwgUkVDRUlWRVIsIFJFQ0VJVkVSX0dVQVJEIGFuZCBBTU9VTlQgdG8gVEFSR0VULUNIQUlOLiBcXFxcXFxuICAgICAgICAgIFxcXFwgU2Vjb25kIHN0ZXAgY29udGludWF0aW9uIGlzIHNlbnQgaW50byBUQVJHRVQtQ0hBSU4gd2l0aCBwcm9vZiBcXFxcXFxuICAgICAgICAgIFxcXFwgb2J0YWluZWQgZnJvbSB0aGUgc3B2ICdvdXRwdXQnIGVuZHBvaW50IG9mIENoYWlud2ViLiBcXFxcXFxuICAgICAgICAgIFxcXFwgUHJvb2YgaXMgdmFsaWRhdGVkIGFuZCBSRUNFSVZFUiBpcyBjcmVkaXRlZCB3aXRoIEFNT1VOVCBcXFxcXFxuICAgICAgICAgIFxcXFwgY3JlYXRpbmcgYWNjb3VudCB3aXRoIFJFQ0VJVkVSX0dVQVJEIGFzIG5lY2Vzc2FyeS5cXFwiXFxuICAgICBAbW9kZWwgWyAocHJvcGVydHkgKD4gYW1vdW50IDAuMCkpXFxuICAgICAgICAgICAgICAocHJvcGVydHkgKCE9IHNlbmRlciBcXFwiXFxcIikpXFxuICAgICAgICAgICAgICAocHJvcGVydHkgKCE9IHJlY2VpdmVyIFxcXCJcXFwiKSlcXG4gICAgICAgICAgICAgIChwcm9wZXJ0eSAoIT0gc2VuZGVyIHJlY2VpdmVyKSlcXG4gICAgICAgICAgICAgIChwcm9wZXJ0eSAoIT0gdGFyZ2V0LWNoYWluIFxcXCJcXFwiKSlcXG4gICAgICAgICAgICBdXFxuICAgICApXFxuXFxuICAgKGRlZnVuIGdldC1iYWxhbmNlOmRlY2ltYWxcXG4gICAgICggYWNjb3VudDpzdHJpbmcgKVxcbiAgICAgXFxcIiBHZXQgYmFsYW5jZSBmb3IgQUNDT1VOVC4gRmFpbHMgaWYgYWNjb3VudCBkb2VzIG5vdCBleGlzdC5cXFwiXFxuICAgICApXFxuXFxuICAgKGRlZnVuIGRldGFpbHM6b2JqZWN0e2FjY291bnQtZGV0YWlsc31cXG4gICAgICggYWNjb3VudDogc3RyaW5nIClcXG4gICAgIFxcXCIgR2V0IGFuIG9iamVjdCB3aXRoIGRldGFpbHMgb2YgQUNDT1VOVC4gXFxcXFxcbiAgICAgXFxcXCBGYWlscyBpZiBhY2NvdW50IGRvZXMgbm90IGV4aXN0LlxcXCJcXG4gICAgIClcXG5cXG4gICAoZGVmdW4gcHJlY2lzaW9uOmludGVnZXJcXG4gICAgICgpXFxuICAgICBcXFwiUmV0dXJuIHRoZSBtYXhpbXVtIGFsbG93ZWQgZGVjaW1hbCBwcmVjaXNpb24uXFxcIlxcbiAgICAgKVxcblxcbiAgIChkZWZ1biBlbmZvcmNlLXVuaXQ6Ym9vbFxcbiAgICAgKCBhbW91bnQ6ZGVjaW1hbCApXFxuICAgICBcXFwiIEVuZm9yY2UgbWluaW11bSBwcmVjaXNpb24gYWxsb3dlZCBmb3IgdHJhbnNhY3Rpb25zLlxcXCJcXG4gICAgIClcXG5cXG4gICAoZGVmdW4gY3JlYXRlLWFjY291bnQ6c3RyaW5nXFxuICAgICAoIGFjY291bnQ6c3RyaW5nXFxuICAgICAgIGd1YXJkOmd1YXJkXFxuICAgICApXFxuICAgICBcXFwiIENyZWF0ZSBBQ0NPVU5UIHdpdGggMC4wIGJhbGFuY2UsIHdpdGggR1VBUkQgY29udHJvbGxpbmcgYWNjZXNzLlxcXCJcXG4gICAgIClcXG5cXG4gICAoZGVmdW4gcm90YXRlOnN0cmluZ1xcbiAgICAgKCBhY2NvdW50OnN0cmluZ1xcbiAgICAgICBuZXctZ3VhcmQ6Z3VhcmRcXG4gICAgIClcXG4gICAgIFxcXCIgUm90YXRlIGd1YXJkIGZvciBBQ0NPVU5ULiBUcmFuc2FjdGlvbiBpcyB2YWxpZGF0ZWQgYWdhaW5zdCBcXFxcXFxuICAgICBcXFxcIGV4aXN0aW5nIGd1YXJkIGJlZm9yZSBpbnN0YWxsaW5nIG5ldyBndWFyZC4gXFxcIlxcbiAgICAgKVxcblxcbilcXG5cIn19LFwic2lnbmVyc1wiOltdLFwibWV0YVwiOntcImNyZWF0aW9uVGltZVwiOjAsXCJ0dGxcIjoxNzI4MDAsXCJnYXNMaW1pdFwiOjAsXCJjaGFpbklkXCI6XCJcIixcImdhc1ByaWNlXCI6MCxcInNlbmRlclwiOlwiXCJ9LFwibm9uY2VcIjpcImdlbmVzaXMtMDFcIn0ifQ", unsafeFromText "eyJnYXMiOjAsInJlc3VsdCI6eyJzdGF0dXMiOiJzdWNjZXNzIiwiZGF0YSI6IkxvYWRlZCBpbnRlcmZhY2UgZnVuZ2libGUtdjEifSwicmVxS2V5IjoiNDhUMExqQW5TRnBGV3h2dmFQVi1fNkUtQ2pEQVBoV1lVRldidnlmMmxGcyIsImxvZ3MiOiJRRmEyOHRuOXkydFdMVzdUc3lHdzNOTkhpYzhxYjJ6UGtudXRpWWhnQXc4IiwibWV0YURhdGEiOm51bGwsImNvbnRpbnVhdGlvbiI6bnVsbCwidHhJZCI6MH0") - , (unsafeFromText "eyJoYXNoIjoieW5ucDFYVVNSTjJrMUYwYTZ2dXM3RFp0SDZjcHN6MVhmX0d3V0xnTFhTTSIsInNpZ3MiOltdLCJjbWQiOiJ7XCJuZXR3b3JrSWRcIjpudWxsLFwicGF5bG9hZFwiOntcImV4ZWNcIjp7XCJkYXRhXCI6bnVsbCxcImNvZGVcIjpcIihpbnRlcmZhY2UgZnVuZ2libGUteGNoYWluLXYxXFxuXFxuICBcXFwiIFRoaXMgaW50ZXJmYWNlIG9mZmVycyBhIHN0YW5kYXJkIGNhcGFiaWxpdHkgZm9yIGNyb3NzLWNoYWluIFxcXFxcXG4gIFxcXFwgdHJhbnNmZXJzIGFuZCBhc3NvY2lhdGVkIGV2ZW50cy4gXFxcIlxcblxcbiAgKGRlZmNhcCBUUkFOU0ZFUl9YQ0hBSU46Ym9vbFxcbiAgICAoIHNlbmRlcjpzdHJpbmdcXG4gICAgICByZWNlaXZlcjpzdHJpbmdcXG4gICAgICBhbW91bnQ6ZGVjaW1hbFxcbiAgICAgIHRhcmdldC1jaGFpbjpzdHJpbmdcXG4gICAgKVxcbiAgICBAZG9jIFxcXCIgTWFuYWdlZCBjYXBhYmlsaXR5IHNlYWxpbmcgQU1PVU5UIGZvciB0cmFuc2ZlciBcXFxcXFxuICAgICAgICAgXFxcXCBmcm9tIFNFTkRFUiB0byBSRUNFSVZFUiBvbiBUQVJHRVQtQ0hBSU4uIFBlcm1pdHMgXFxcXFxcbiAgICAgICAgIFxcXFwgYW55IG51bWJlciBvZiBjcm9zcy1jaGFpbiB0cmFuc2ZlcnMgdXAgdG8gQU1PVU5ULlxcXCJcXG5cXG4gICAgQG1hbmFnZWQgYW1vdW50IFRSQU5TRkVSX1hDSEFJTi1tZ3JcXG4gICAgKVxcblxcbiAgKGRlZnVuIFRSQU5TRkVSX1hDSEFJTi1tZ3I6ZGVjaW1hbFxcbiAgICAoIG1hbmFnZWQ6ZGVjaW1hbFxcbiAgICAgIHJlcXVlc3RlZDpkZWNpbWFsXFxuICAgIClcXG4gICAgQGRvYyBcXFwiIEFsbG93cyBUUkFOU0ZFUi1YQ0hBSU4gQU1PVU5UIHRvIGJlIGxlc3MgdGhhbiBvciBcXFxcXFxuICAgICAgICAgXFxcXCBlcXVhbCBtYW5hZ2VkIHF1YW50aXR5IGFzIGEgb25lLXNob3QsIHJldHVybmluZyAwLjAuXFxcIlxcbiAgKVxcblxcbiAgKGRlZmNhcCBUUkFOU0ZFUl9YQ0hBSU5fUkVDRDpib29sXFxuICAgICggc2VuZGVyOnN0cmluZ1xcbiAgICAgIHJlY2VpdmVyOnN0cmluZ1xcbiAgICAgIGFtb3VudDpkZWNpbWFsXFxuICAgICAgc291cmNlLWNoYWluOnN0cmluZ1xcbiAgICApXFxuICAgIEBkb2MgXFxcIkV2ZW50IGVtaXR0ZWQgb24gcmVjZWlwdCBvZiBjcm9zcy1jaGFpbiB0cmFuc2Zlci5cXFwiXFxuICAgIEBldmVudFxcbiAgKVxcbilcXG5cIn19LFwic2lnbmVyc1wiOltdLFwibWV0YVwiOntcImNyZWF0aW9uVGltZVwiOjAsXCJ0dGxcIjoxNzI4MDAsXCJnYXNMaW1pdFwiOjAsXCJjaGFpbklkXCI6XCJcIixcImdhc1ByaWNlXCI6MCxcInNlbmRlclwiOlwiXCJ9LFwibm9uY2VcIjpcImdlbmVzaXMteGNoYWluXCJ9In0", unsafeFromText "eyJnYXMiOjAsInJlc3VsdCI6eyJzdGF0dXMiOiJzdWNjZXNzIiwiZGF0YSI6IkxvYWRlZCBpbnRlcmZhY2UgZnVuZ2libGUteGNoYWluLXYxIn0sInJlcUtleSI6InlubnAxWFVTUk4yazFGMGE2dnVzN0RadEg2Y3BzejFYZl9Hd1dMZ0xYU00iLCJsb2dzIjoiVmRxMHp0SjBnRThOLTNkLW1tRmRRXzZ0ZGp0dnEtNXIwX050dXBvT1hpVSIsIm1ldGFEYXRhIjpudWxsLCJjb250aW51YXRpb24iOm51bGwsInR4SWQiOjF9") - , (unsafeFromText "eyJoYXNoIjoiMDVCdGo3ZUJaQlc3by1TYUxvVmhBaWNNVVBaVUJiRzZRVDhfTEFrQ3hIcyIsInNpZ3MiOltdLCJjbWQiOiJ7XCJuZXR3b3JrSWRcIjpudWxsLFwicGF5bG9hZFwiOntcImV4ZWNcIjp7XCJkYXRhXCI6bnVsbCxcImNvZGVcIjpcIihpbnRlcmZhY2UgZnVuZ2libGUtdjJcXG5cXG4gIFxcXCIgU3RhbmRhcmQgZm9yIGZ1bmdpYmxlIGNvaW5zIGFuZCB0b2tlbnMgYXMgc3BlY2lmaWVkIGluIEtJUC0wMDAyLiBcXFwiXFxuXFxuICAgOyAtLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tXFxuICAgOyBTY2hlbWFcXG5cXG4gICAoZGVmc2NoZW1hIGFjY291bnQtZGV0YWlsc1xcbiAgICBAZG9jIFxcXCJTY2hlbWEgZm9yIHJlc3VsdHMgb2YgJ2FjY291bnQnIG9wZXJhdGlvbi5cXFwiXFxuICAgIEBtb2RlbCBbIChpbnZhcmlhbnQgKCE9IFxcXCJcXFwiIHNlbmRlcikpIF1cXG5cXG4gICAgYWNjb3VudDpzdHJpbmdcXG4gICAgYmFsYW5jZTpkZWNpbWFsXFxuICAgIGd1YXJkOmd1YXJkKVxcblxcblxcbiAgIDsgLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLVxcbiAgIDsgQ2Fwc1xcblxcbiAgIChkZWZjYXAgVFJBTlNGRVI6Ym9vbFxcbiAgICAgKCBzZW5kZXI6c3RyaW5nXFxuICAgICAgIHJlY2VpdmVyOnN0cmluZ1xcbiAgICAgICBhbW91bnQ6ZGVjaW1hbFxcbiAgICAgKVxcbiAgICAgQGRvYyBcXFwiIE1hbmFnZWQgY2FwYWJpbGl0eSBzZWFsaW5nIEFNT1VOVCBmb3IgdHJhbnNmZXIgZnJvbSBTRU5ERVIgdG8gXFxcXFxcbiAgICAgICAgICBcXFxcIFJFQ0VJVkVSLiBQZXJtaXRzIGFueSBudW1iZXIgb2YgdHJhbnNmZXJzIHVwIHRvIEFNT1VOVC5cXFwiXFxuICAgICBAbWFuYWdlZCBhbW91bnQgVFJBTlNGRVItbWdyXFxuICAgICApXFxuXFxuICAgKGRlZnVuIFRSQU5TRkVSLW1ncjpkZWNpbWFsXFxuICAgICAoIG1hbmFnZWQ6ZGVjaW1hbFxcbiAgICAgICByZXF1ZXN0ZWQ6ZGVjaW1hbFxcbiAgICAgKVxcbiAgICAgQGRvYyBcXFwiIE1hbmFnZXMgVFJBTlNGRVIgQU1PVU5UIGxpbmVhcmx5LCBcXFxcXFxuICAgICAgICAgIFxcXFwgc3VjaCB0aGF0IGEgcmVxdWVzdCBmb3IgMS4wIGFtb3VudCBvbiBhIDMuMCBcXFxcXFxuICAgICAgICAgIFxcXFwgbWFuYWdlZCBxdWFudGl0eSBlbWl0cyB1cGRhdGVkIGFtb3VudCAyLjAuXFxcIlxcbiAgICAgKVxcblxcbiAgIDsgLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLVxcbiAgIDsgRnVuY3Rpb25hbGl0eVxcblxcblxcbiAgKGRlZnVuIHRyYW5zZmVyOnN0cmluZ1xcbiAgICAoIHNlbmRlcjpzdHJpbmdcXG4gICAgICByZWNlaXZlcjpzdHJpbmdcXG4gICAgICBhbW91bnQ6ZGVjaW1hbFxcbiAgICApXFxuICAgIEBkb2MgXFxcIiBUcmFuc2ZlciBBTU9VTlQgYmV0d2VlbiBhY2NvdW50cyBTRU5ERVIgYW5kIFJFQ0VJVkVSLiBcXFxcXFxuICAgICAgICAgXFxcXCBGYWlscyBpZiBlaXRoZXIgU0VOREVSIG9yIFJFQ0VJVkVSIGRvZXMgbm90IGV4aXN0LlxcXCJcXG4gICAgQG1vZGVsIFsgKHByb3BlcnR5ICg-IGFtb3VudCAwLjApKVxcbiAgICAgICAgICAgICAocHJvcGVydHkgKCE9IHNlbmRlciBcXFwiXFxcIikpXFxuICAgICAgICAgICAgIChwcm9wZXJ0eSAoIT0gcmVjZWl2ZXIgXFxcIlxcXCIpKVxcbiAgICAgICAgICAgICAocHJvcGVydHkgKCE9IHNlbmRlciByZWNlaXZlcikpXFxuICAgICAgICAgICBdXFxuICAgIClcXG5cXG4gICAoZGVmdW4gdHJhbnNmZXItY3JlYXRlOnN0cmluZ1xcbiAgICAgKCBzZW5kZXI6c3RyaW5nXFxuICAgICAgIHJlY2VpdmVyOnN0cmluZ1xcbiAgICAgICByZWNlaXZlci1ndWFyZDpndWFyZFxcbiAgICAgICBhbW91bnQ6ZGVjaW1hbFxcbiAgICAgKVxcbiAgICAgQGRvYyBcXFwiIFRyYW5zZmVyIEFNT1VOVCBiZXR3ZWVuIGFjY291bnRzIFNFTkRFUiBhbmQgUkVDRUlWRVIuIFxcXFxcXG4gICAgICAgICAgXFxcXCBGYWlscyBpZiBTRU5ERVIgZG9lcyBub3QgZXhpc3QuIElmIFJFQ0VJVkVSIGV4aXN0cywgZ3VhcmQgXFxcXFxcbiAgICAgICAgICBcXFxcIG11c3QgbWF0Y2ggZXhpc3RpbmcgdmFsdWUuIElmIFJFQ0VJVkVSIGRvZXMgbm90IGV4aXN0LCBcXFxcXFxuICAgICAgICAgIFxcXFwgUkVDRUlWRVIgYWNjb3VudCBpcyBjcmVhdGVkIHVzaW5nIFJFQ0VJVkVSLUdVQVJELiBcXFxcXFxuICAgICAgICAgIFxcXFwgU3ViamVjdCB0byBtYW5hZ2VtZW50IGJ5IFRSQU5TRkVSIGNhcGFiaWxpdHkuXFxcIlxcbiAgICAgQG1vZGVsIFsgKHByb3BlcnR5ICg-IGFtb3VudCAwLjApKVxcbiAgICAgICAgICAgICAgKHByb3BlcnR5ICghPSBzZW5kZXIgXFxcIlxcXCIpKVxcbiAgICAgICAgICAgICAgKHByb3BlcnR5ICghPSByZWNlaXZlciBcXFwiXFxcIikpXFxuICAgICAgICAgICAgICAocHJvcGVydHkgKCE9IHNlbmRlciByZWNlaXZlcikpXFxuICAgICAgICAgICAgXVxcbiAgICAgKVxcblxcbiAgIChkZWZwYWN0IHRyYW5zZmVyLWNyb3NzY2hhaW46c3RyaW5nXFxuICAgICAoIHNlbmRlcjpzdHJpbmdcXG4gICAgICAgcmVjZWl2ZXI6c3RyaW5nXFxuICAgICAgIHJlY2VpdmVyLWd1YXJkOmd1YXJkXFxuICAgICAgIHRhcmdldC1jaGFpbjpzdHJpbmdcXG4gICAgICAgYW1vdW50OmRlY2ltYWxcXG4gICAgIClcXG4gICAgIEBkb2MgXFxcIiAyLXN0ZXAgcGFjdCB0byB0cmFuc2ZlciBBTU9VTlQgZnJvbSBTRU5ERVIgb24gY3VycmVudCBjaGFpbiBcXFxcXFxuICAgICAgICAgIFxcXFwgdG8gUkVDRUlWRVIgb24gVEFSR0VULUNIQUlOIHZpYSBTUFYgcHJvb2YuIFxcXFxcXG4gICAgICAgICAgXFxcXCBUQVJHRVQtQ0hBSU4gbXVzdCBiZSBkaWZmZXJlbnQgdGhhbiBjdXJyZW50IGNoYWluIGlkLiBcXFxcXFxuICAgICAgICAgIFxcXFwgRmlyc3Qgc3RlcCBkZWJpdHMgQU1PVU5UIGNvaW5zIGluIFNFTkRFUiBhY2NvdW50IGFuZCB5aWVsZHMgXFxcXFxcbiAgICAgICAgICBcXFxcIFJFQ0VJVkVSLCBSRUNFSVZFUl9HVUFSRCBhbmQgQU1PVU5UIHRvIFRBUkdFVC1DSEFJTi4gXFxcXFxcbiAgICAgICAgICBcXFxcIFNlY29uZCBzdGVwIGNvbnRpbnVhdGlvbiBpcyBzZW50IGludG8gVEFSR0VULUNIQUlOIHdpdGggcHJvb2YgXFxcXFxcbiAgICAgICAgICBcXFxcIG9idGFpbmVkIGZyb20gdGhlIHNwdiAnb3V0cHV0JyBlbmRwb2ludCBvZiBDaGFpbndlYi4gXFxcXFxcbiAgICAgICAgICBcXFxcIFByb29mIGlzIHZhbGlkYXRlZCBhbmQgUkVDRUlWRVIgaXMgY3JlZGl0ZWQgd2l0aCBBTU9VTlQgXFxcXFxcbiAgICAgICAgICBcXFxcIGNyZWF0aW5nIGFjY291bnQgd2l0aCBSRUNFSVZFUl9HVUFSRCBhcyBuZWNlc3NhcnkuXFxcIlxcbiAgICAgQG1vZGVsIFsgKHByb3BlcnR5ICg-IGFtb3VudCAwLjApKVxcbiAgICAgICAgICAgICAgKHByb3BlcnR5ICghPSBzZW5kZXIgXFxcIlxcXCIpKVxcbiAgICAgICAgICAgICAgKHByb3BlcnR5ICghPSByZWNlaXZlciBcXFwiXFxcIikpXFxuICAgICAgICAgICAgICAocHJvcGVydHkgKCE9IHNlbmRlciByZWNlaXZlcikpXFxuICAgICAgICAgICAgICAocHJvcGVydHkgKCE9IHRhcmdldC1jaGFpbiBcXFwiXFxcIikpXFxuICAgICAgICAgICAgXVxcbiAgICAgKVxcblxcbiAgIChkZWZ1biBnZXQtYmFsYW5jZTpkZWNpbWFsXFxuICAgICAoIGFjY291bnQ6c3RyaW5nIClcXG4gICAgIFxcXCIgR2V0IGJhbGFuY2UgZm9yIEFDQ09VTlQuIEZhaWxzIGlmIGFjY291bnQgZG9lcyBub3QgZXhpc3QuXFxcIlxcbiAgICAgKVxcblxcbiAgIChkZWZ1biBkZXRhaWxzOm9iamVjdHthY2NvdW50LWRldGFpbHN9XFxuICAgICAoIGFjY291bnQ6IHN0cmluZyApXFxuICAgICBcXFwiIEdldCBhbiBvYmplY3Qgd2l0aCBkZXRhaWxzIG9mIEFDQ09VTlQuIFxcXFxcXG4gICAgIFxcXFwgRmFpbHMgaWYgYWNjb3VudCBkb2VzIG5vdCBleGlzdC5cXFwiXFxuICAgICApXFxuXFxuICAgKGRlZnVuIHByZWNpc2lvbjppbnRlZ2VyXFxuICAgICAoKVxcbiAgICAgXFxcIlJldHVybiB0aGUgbWF4aW11bSBhbGxvd2VkIGRlY2ltYWwgcHJlY2lzaW9uLlxcXCJcXG4gICAgIClcXG5cXG4gICAoZGVmdW4gZW5mb3JjZS11bml0OmJvb2xcXG4gICAgICggYW1vdW50OmRlY2ltYWwgKVxcbiAgICAgXFxcIiBFbmZvcmNlIG1pbmltdW0gcHJlY2lzaW9uIGFsbG93ZWQgZm9yIHRyYW5zYWN0aW9ucy5cXFwiXFxuICAgICApXFxuXFxuICAgKGRlZnVuIGNyZWF0ZS1hY2NvdW50OnN0cmluZ1xcbiAgICAgKCBhY2NvdW50OnN0cmluZ1xcbiAgICAgICBndWFyZDpndWFyZFxcbiAgICAgKVxcbiAgICAgXFxcIiBDcmVhdGUgQUNDT1VOVCB3aXRoIDAuMCBiYWxhbmNlLCB3aXRoIEdVQVJEIGNvbnRyb2xsaW5nIGFjY2Vzcy5cXFwiXFxuICAgICApXFxuXFxuICAgKGRlZnVuIHJvdGF0ZTpzdHJpbmdcXG4gICAgICggYWNjb3VudDpzdHJpbmdcXG4gICAgICAgbmV3LWd1YXJkOmd1YXJkXFxuICAgICApXFxuICAgICBcXFwiIFJvdGF0ZSBndWFyZCBmb3IgQUNDT1VOVC4gVHJhbnNhY3Rpb24gaXMgdmFsaWRhdGVkIGFnYWluc3QgXFxcXFxcbiAgICAgXFxcXCBleGlzdGluZyBndWFyZCBiZWZvcmUgaW5zdGFsbGluZyBuZXcgZ3VhcmQuIFxcXCJcXG4gICAgIClcXG5cXG4pXFxuXCJ9fSxcInNpZ25lcnNcIjpbXSxcIm1ldGFcIjp7XCJjcmVhdGlvblRpbWVcIjowLFwidHRsXCI6MTcyODAwLFwiZ2FzTGltaXRcIjowLFwiY2hhaW5JZFwiOlwiXCIsXCJnYXNQcmljZVwiOjAsXCJzZW5kZXJcIjpcIlwifSxcIm5vbmNlXCI6XCJmdW5naWJsZS1hc3NldC12MlwifSJ9", unsafeFromText "eyJnYXMiOjAsInJlc3VsdCI6eyJzdGF0dXMiOiJzdWNjZXNzIiwiZGF0YSI6IkxvYWRlZCBpbnRlcmZhY2UgZnVuZ2libGUtdjIifSwicmVxS2V5IjoiMDVCdGo3ZUJaQlc3by1TYUxvVmhBaWNNVVBaVUJiRzZRVDhfTEFrQ3hIcyIsImxvZ3MiOiJWaGlrLVYzOHByQXRpbHhTV3RZNWYxUnpmVjFUYVJBQzF0N3VVVXZjbGxnIiwibWV0YURhdGEiOm51bGwsImNvbnRpbnVhdGlvbiI6bnVsbCwidHhJZCI6Mn0") - , (unsafeFromText "eyJoYXNoIjoiR1JJUXU0aEFLazBJRDlGOHpfLTB5WHlBS0ozM01QeVRZTVhPamxQSm1wSSIsInNpZ3MiOltdLCJjbWQiOiJ7XCJuZXR3b3JrSWRcIjpudWxsLFwicGF5bG9hZFwiOntcImV4ZWNcIjp7XCJkYXRhXCI6bnVsbCxcImNvZGVcIjpcIlxcbihtb2R1bGUgY29pbiBHT1ZFUk5BTkNFXFxuXFxuICBAZG9jIFxcXCInY29pbicgcmVwcmVzZW50cyB0aGUgS2FkZW5hIENvaW4gQ29udHJhY3QuIFRoaXMgY29udHJhY3QgcHJvdmlkZXMgYm90aCB0aGUgXFxcXFxcbiAgXFxcXGJ1eS9yZWRlZW0gZ2FzIHN1cHBvcnQgaW4gdGhlIGZvcm0gb2YgJ2Z1bmQtdHgnLCBhcyB3ZWxsIGFzIHRyYW5zZmVyLCAgICAgICBcXFxcXFxuICBcXFxcY3JlZGl0LCBkZWJpdCwgY29pbmJhc2UsIGFjY291bnQgY3JlYXRpb24gYW5kIHF1ZXJ5LCBhcyB3ZWxsIGFzIFNQViBidXJuICAgIFxcXFxcXG4gIFxcXFxjcmVhdGUuIFRvIGFjY2VzcyB0aGUgY29pbiBjb250cmFjdCwgeW91IG1heSB1c2UgaXRzIGZ1bGx5LXF1YWxpZmllZCBuYW1lLCAgXFxcXFxcbiAgXFxcXG9yIGlzc3VlIHRoZSAnKHVzZSBjb2luKScgY29tbWFuZCBpbiB0aGUgYm9keSBvZiBhIG1vZHVsZSBkZWNsYXJhdGlvbi5cXFwiXFxuXFxuICBAbW9kZWxcXG4gICAgWyAoZGVmcHJvcGVydHkgY29uc2VydmVzLW1hc3NcXG4gICAgICAgICg9IChjb2x1bW4tZGVsdGEgY29pbi10YWJsZSAnYmFsYW5jZSkgMC4wKSlcXG5cXG4gICAgICAoZGVmcHJvcGVydHkgdmFsaWQtYWNjb3VudCAoYWNjb3VudDpzdHJpbmcpXFxuICAgICAgICAoYW5kXFxuICAgICAgICAgICg-PSAobGVuZ3RoIGFjY291bnQpIDMpXFxuICAgICAgICAgICg8PSAobGVuZ3RoIGFjY291bnQpIDI1NikpKVxcbiAgICBdXFxuXFxuICAoaW1wbGVtZW50cyBmdW5naWJsZS12MilcXG4gIChpbXBsZW1lbnRzIGZ1bmdpYmxlLXhjaGFpbi12MSlcXG5cXG4gIDs7IGNvaW4tdjJcXG4gIChibGVzcyBcXFwidXRfSl9aTmtveWFQVUVKaGl3VmVXbmtTUW45SlQ5c1FDV0tkampWVnJXb1xcXCIpXFxuXFxuICA7OyBjb2luIHYzXFxuICAoYmxlc3MgXFxcIjFvc19zTEFVWXZCenNwbjVqamF3dFJwSldpSDFXUGZoeU5yYWVWdlNJd1VcXFwiKVxcblxcbiAgOzsgY29pbiB2NFxcbiAgKGJsZXNzIFxcXCJCalpXMFQyYWM2cUVfSTVYOEdFNGZhbDZ0VHFqaExUQzdteTB5dFFTeExVXFxcIilcXG5cXG4gIDs7IGNvaW4gdjVcXG4gIChibGVzcyBcXFwickU3RFU4amxRTDl4X01QWXVuaVpKZjVJQ0JUQUVIQUlGUUNCNGJsb2ZQNFxcXCIpXFxuXFxuICA7IC0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tXFxuICA7IFNjaGVtYXMgYW5kIFRhYmxlc1xcblxcbiAgKGRlZnNjaGVtYSBjb2luLXNjaGVtYVxcbiAgICBAZG9jIFxcXCJUaGUgY29pbiBjb250cmFjdCB0b2tlbiBzY2hlbWFcXFwiXFxuICAgIEBtb2RlbCBbIChpbnZhcmlhbnQgKD49IGJhbGFuY2UgMC4wKSkgXVxcblxcbiAgICBiYWxhbmNlOmRlY2ltYWxcXG4gICAgZ3VhcmQ6Z3VhcmQpXFxuXFxuICAoZGVmdGFibGUgY29pbi10YWJsZTp7Y29pbi1zY2hlbWF9KVxcblxcbiAgOyAtLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLVxcbiAgOyBDYXBhYmlsaXRpZXNcXG5cXG4gIChkZWZjYXAgR09WRVJOQU5DRSAoKVxcbiAgICAoZW5mb3JjZSBmYWxzZSBcXFwiRW5mb3JjZSBub24tdXBncmFkZWFiaWxpdHlcXFwiKSlcXG5cXG4gIChkZWZjYXAgR0FTICgpXFxuICAgIFxcXCJNYWdpYyBjYXBhYmlsaXR5IHRvIHByb3RlY3QgZ2FzIGJ1eSBhbmQgcmVkZWVtXFxcIlxcbiAgICB0cnVlKVxcblxcbiAgKGRlZmNhcCBDT0lOQkFTRSAoKVxcbiAgICBcXFwiTWFnaWMgY2FwYWJpbGl0eSB0byBwcm90ZWN0IG1pbmVyIHJld2FyZFxcXCJcXG4gICAgdHJ1ZSlcXG5cXG4gIChkZWZjYXAgR0VORVNJUyAoKVxcbiAgICBcXFwiTWFnaWMgY2FwYWJpbGl0eSBjb25zdHJhaW5pbmcgZ2VuZXNpcyB0cmFuc2FjdGlvbnNcXFwiXFxuICAgIHRydWUpXFxuXFxuICAoZGVmY2FwIFJFTUVESUFURSAoKVxcbiAgICBcXFwiTWFnaWMgY2FwYWJpbGl0eSBmb3IgcmVtZWRpYXRpb24gdHJhbnNhY3Rpb25zXFxcIlxcbiAgICB0cnVlKVxcblxcbiAgKGRlZmNhcCBERUJJVCAoc2VuZGVyOnN0cmluZylcXG4gICAgXFxcIkNhcGFiaWxpdHkgZm9yIG1hbmFnaW5nIGRlYml0aW5nIG9wZXJhdGlvbnNcXFwiXFxuICAgIChlbmZvcmNlLWd1YXJkIChhdCAnZ3VhcmQgKHJlYWQgY29pbi10YWJsZSBzZW5kZXIpKSlcXG4gICAgKGVuZm9yY2UgKCE9IHNlbmRlciBcXFwiXFxcIikgXFxcInZhbGlkIHNlbmRlclxcXCIpKVxcblxcbiAgKGRlZmNhcCBDUkVESVQgKHJlY2VpdmVyOnN0cmluZylcXG4gICAgXFxcIkNhcGFiaWxpdHkgZm9yIG1hbmFnaW5nIGNyZWRpdGluZyBvcGVyYXRpb25zXFxcIlxcbiAgICAoZW5mb3JjZSAoIT0gcmVjZWl2ZXIgXFxcIlxcXCIpIFxcXCJ2YWxpZCByZWNlaXZlclxcXCIpKVxcblxcbiAgKGRlZmNhcCBST1RBVEUgKGFjY291bnQ6c3RyaW5nKVxcbiAgICBAZG9jIFxcXCJBdXRvbm9tb3VzbHkgbWFuYWdlZCBjYXBhYmlsaXR5IGZvciBndWFyZCByb3RhdGlvblxcXCJcXG4gICAgQG1hbmFnZWRcXG4gICAgdHJ1ZSlcXG5cXG4gIChkZWZjYXAgVFJBTlNGRVI6Ym9vbFxcbiAgICAoIHNlbmRlcjpzdHJpbmdcXG4gICAgICByZWNlaXZlcjpzdHJpbmdcXG4gICAgICBhbW91bnQ6ZGVjaW1hbFxcbiAgICApXFxuICAgIEBtYW5hZ2VkIGFtb3VudCBUUkFOU0ZFUi1tZ3JcXG4gICAgKGVuZm9yY2UgKCE9IHNlbmRlciByZWNlaXZlcikgXFxcInNhbWUgc2VuZGVyIGFuZCByZWNlaXZlclxcXCIpXFxuICAgIChlbmZvcmNlLXVuaXQgYW1vdW50KVxcbiAgICAoZW5mb3JjZSAoPiBhbW91bnQgMC4wKSBcXFwiUG9zaXRpdmUgYW1vdW50XFxcIilcXG4gICAgKGNvbXBvc2UtY2FwYWJpbGl0eSAoREVCSVQgc2VuZGVyKSlcXG4gICAgKGNvbXBvc2UtY2FwYWJpbGl0eSAoQ1JFRElUIHJlY2VpdmVyKSlcXG4gIClcXG5cXG4gIChkZWZ1biBUUkFOU0ZFUi1tZ3I6ZGVjaW1hbFxcbiAgICAoIG1hbmFnZWQ6ZGVjaW1hbFxcbiAgICAgIHJlcXVlc3RlZDpkZWNpbWFsXFxuICAgIClcXG5cXG4gICAgKGxldCAoKG5ld2JhbCAoLSBtYW5hZ2VkIHJlcXVlc3RlZCkpKVxcbiAgICAgIChlbmZvcmNlICg-PSBuZXdiYWwgMC4wKVxcbiAgICAgICAgKGZvcm1hdCBcXFwiVFJBTlNGRVIgZXhjZWVkZWQgZm9yIGJhbGFuY2Uge31cXFwiIFttYW5hZ2VkXSkpXFxuICAgICAgbmV3YmFsKVxcbiAgKVxcblxcbiAgKGRlZmNhcCBUUkFOU0ZFUl9YQ0hBSU46Ym9vbFxcbiAgICAoIHNlbmRlcjpzdHJpbmdcXG4gICAgICByZWNlaXZlcjpzdHJpbmdcXG4gICAgICBhbW91bnQ6ZGVjaW1hbFxcbiAgICAgIHRhcmdldC1jaGFpbjpzdHJpbmdcXG4gICAgKVxcblxcbiAgICBAbWFuYWdlZCBhbW91bnQgVFJBTlNGRVJfWENIQUlOLW1nclxcbiAgICAoZW5mb3JjZS11bml0IGFtb3VudClcXG4gICAgKGVuZm9yY2UgKD4gYW1vdW50IDAuMCkgXFxcIkNyb3NzLWNoYWluIHRyYW5zZmVycyByZXF1aXJlIGEgcG9zaXRpdmUgYW1vdW50XFxcIilcXG4gICAgKGNvbXBvc2UtY2FwYWJpbGl0eSAoREVCSVQgc2VuZGVyKSlcXG4gIClcXG5cXG4gIChkZWZ1biBUUkFOU0ZFUl9YQ0hBSU4tbWdyOmRlY2ltYWxcXG4gICAgKCBtYW5hZ2VkOmRlY2ltYWxcXG4gICAgICByZXF1ZXN0ZWQ6ZGVjaW1hbFxcbiAgICApXFxuXFxuICAgIChlbmZvcmNlICg-PSBtYW5hZ2VkIHJlcXVlc3RlZClcXG4gICAgICAoZm9ybWF0IFxcXCJUUkFOU0ZFUl9YQ0hBSU4gZXhjZWVkZWQgZm9yIGJhbGFuY2Uge31cXFwiIFttYW5hZ2VkXSkpXFxuICAgIDAuMFxcbiAgKVxcblxcbiAgKGRlZmNhcCBUUkFOU0ZFUl9YQ0hBSU5fUkVDRDpib29sXFxuICAgICggc2VuZGVyOnN0cmluZ1xcbiAgICAgIHJlY2VpdmVyOnN0cmluZ1xcbiAgICAgIGFtb3VudDpkZWNpbWFsXFxuICAgICAgc291cmNlLWNoYWluOnN0cmluZ1xcbiAgICApXFxuICAgIEBldmVudCB0cnVlXFxuICApXFxuXFxuICA7IHYzIGNhcGFiaWxpdGllc1xcbiAgKGRlZmNhcCBSRUxFQVNFX0FMTE9DQVRJT05cXG4gICAgKCBhY2NvdW50OnN0cmluZ1xcbiAgICAgIGFtb3VudDpkZWNpbWFsXFxuICAgIClcXG4gICAgQGRvYyBcXFwiRXZlbnQgZm9yIGFsbG9jYXRpb24gcmVsZWFzZSwgY2FuIGJlIHVzZWQgZm9yIHNpZyBzY29waW5nLlxcXCJcXG4gICAgQGV2ZW50IHRydWVcXG4gIClcXG5cXG4gIDsgLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS1cXG4gIDsgQ29uc3RhbnRzXFxuXFxuICAoZGVmY29uc3QgQ09JTl9DSEFSU0VUIENIQVJTRVRfTEFUSU4xXFxuICAgIFxcXCJUaGUgZGVmYXVsdCBjb2luIGNvbnRyYWN0IGNoYXJhY3RlciBzZXRcXFwiKVxcblxcbiAgKGRlZmNvbnN0IE1JTklNVU1fUFJFQ0lTSU9OIDEyXFxuICAgIFxcXCJNaW5pbXVtIGFsbG93ZWQgcHJlY2lzaW9uIGZvciBjb2luIHRyYW5zYWN0aW9uc1xcXCIpXFxuXFxuICAoZGVmY29uc3QgTUlOSU1VTV9BQ0NPVU5UX0xFTkdUSCAzXFxuICAgIFxcXCJNaW5pbXVtIGFjY291bnQgbGVuZ3RoIGFkbWlzc2libGUgZm9yIGNvaW4gYWNjb3VudHNcXFwiKVxcblxcbiAgKGRlZmNvbnN0IE1BWElNVU1fQUNDT1VOVF9MRU5HVEggMjU2XFxuICAgIFxcXCJNYXhpbXVtIGFjY291bnQgbmFtZSBsZW5ndGggYWRtaXNzaWJsZSBmb3IgY29pbiBhY2NvdW50c1xcXCIpXFxuXFxuICAoZGVmY29uc3QgVkFMSURfQ0hBSU5fSURTIChtYXAgKGludC10by1zdHIgMTApIChlbnVtZXJhdGUgMCAxOSkpXFxuICAgIFxcXCJMaXN0IG9mIGFsbCB2YWxpZCBDaGFpbndlYiBjaGFpbiBpZHNcXFwiKVxcblxcbiAgOyAtLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLVxcbiAgOyBVdGlsaXRpZXNcXG5cXG4gIChkZWZ1biBlbmZvcmNlLXVuaXQ6Ym9vbCAoYW1vdW50OmRlY2ltYWwpXFxuICAgIEBkb2MgXFxcIkVuZm9yY2UgbWluaW11bSBwcmVjaXNpb24gYWxsb3dlZCBmb3IgY29pbiB0cmFuc2FjdGlvbnNcXFwiXFxuXFxuICAgIChlbmZvcmNlXFxuICAgICAgKD0gKGZsb29yIGFtb3VudCBNSU5JTVVNX1BSRUNJU0lPTilcXG4gICAgICAgICBhbW91bnQpXFxuICAgICAgKGZvcm1hdCBcXFwiQW1vdW50IHZpb2xhdGVzIG1pbmltdW0gcHJlY2lzaW9uOiB7fVxcXCIgW2Ftb3VudF0pKVxcbiAgICApXFxuXFxuICAoZGVmdW4gdmFsaWRhdGUtYWNjb3VudCAoYWNjb3VudDpzdHJpbmcpXFxuICAgIEBkb2MgXFxcIkVuZm9yY2UgdGhhdCBhbiBhY2NvdW50IG5hbWUgY29uZm9ybXMgdG8gdGhlIGNvaW4gY29udHJhY3QgXFxcXFxcbiAgICAgICAgIFxcXFxtaW5pbXVtIGFuZCBtYXhpbXVtIGxlbmd0aCByZXF1aXJlbWVudHMsIGFzIHdlbGwgYXMgdGhlICAgIFxcXFxcXG4gICAgICAgICBcXFxcbGF0aW4tMSBjaGFyYWN0ZXIgc2V0LlxcXCJcXG5cXG4gICAgKGVuZm9yY2VcXG4gICAgICAoaXMtY2hhcnNldCBDT0lOX0NIQVJTRVQgYWNjb3VudClcXG4gICAgICAoZm9ybWF0XFxuICAgICAgICBcXFwiQWNjb3VudCBkb2VzIG5vdCBjb25mb3JtIHRvIHRoZSBjb2luIGNvbnRyYWN0IGNoYXJzZXQ6IHt9XFxcIlxcbiAgICAgICAgW2FjY291bnRdKSlcXG5cXG4gICAgKGxldCAoKGFjY291bnQtbGVuZ3RoIChsZW5ndGggYWNjb3VudCkpKVxcblxcbiAgICAgIChlbmZvcmNlXFxuICAgICAgICAoPj0gYWNjb3VudC1sZW5ndGggTUlOSU1VTV9BQ0NPVU5UX0xFTkdUSClcXG4gICAgICAgIChmb3JtYXRcXG4gICAgICAgICAgXFxcIkFjY291bnQgbmFtZSBkb2VzIG5vdCBjb25mb3JtIHRvIHRoZSBtaW4gbGVuZ3RoIHJlcXVpcmVtZW50OiB7fVxcXCJcXG4gICAgICAgICAgW2FjY291bnRdKSlcXG5cXG4gICAgICAoZW5mb3JjZVxcbiAgICAgICAgKDw9IGFjY291bnQtbGVuZ3RoIE1BWElNVU1fQUNDT1VOVF9MRU5HVEgpXFxuICAgICAgICAoZm9ybWF0XFxuICAgICAgICAgIFxcXCJBY2NvdW50IG5hbWUgZG9lcyBub3QgY29uZm9ybSB0byB0aGUgbWF4IGxlbmd0aCByZXF1aXJlbWVudDoge31cXFwiXFxuICAgICAgICAgIFthY2NvdW50XSkpXFxuICAgICAgKVxcbiAgKVxcblxcbiAgOyAtLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLVxcbiAgOyBDb2luIENvbnRyYWN0XFxuXFxuICAoZGVmdW4gZ2FzLW9ubHkgKClcXG4gICAgXFxcIlByZWRpY2F0ZSBmb3IgZ2FzLW9ubHkgdXNlciBndWFyZHMuXFxcIlxcbiAgICAocmVxdWlyZS1jYXBhYmlsaXR5IChHQVMpKSlcXG5cXG4gIChkZWZ1biBnYXMtZ3VhcmQgKGd1YXJkOmd1YXJkKVxcbiAgICBcXFwiUHJlZGljYXRlIGZvciBnYXMgKyBzaW5nbGUga2V5IHVzZXIgZ3VhcmRzXFxcIlxcbiAgICAoZW5mb3JjZS1vbmVcXG4gICAgICBcXFwiRW5mb3JjZSBlaXRoZXIgdGhlIHByZXNlbmNlIG9mIGEgR0FTIGNhcCBvciBrZXlzZXRcXFwiXFxuICAgICAgWyAoZ2FzLW9ubHkpXFxuICAgICAgICAoZW5mb3JjZS1ndWFyZCBndWFyZClcXG4gICAgICBdKSlcXG5cXG4gIChkZWZ1biBidXktZ2FzOnN0cmluZyAoc2VuZGVyOnN0cmluZyB0b3RhbDpkZWNpbWFsKVxcbiAgICBAZG9jIFxcXCJUaGlzIGZ1bmN0aW9uIGRlc2NyaWJlcyB0aGUgbWFpbiAnZ2FzIGJ1eScgb3BlcmF0aW9uLiBBdCB0aGlzIHBvaW50IFxcXFxcXG4gICAgXFxcXE1JTkVSIGhhcyBiZWVuIGNob3NlbiBmcm9tIHRoZSBwb29sLCBhbmQgd2lsbCBiZSB2YWxpZGF0ZWQuIFRoZSBTRU5ERVIgICBcXFxcXFxuICAgIFxcXFxvZiB0aGlzIHRyYW5zYWN0aW9uIGhhcyBzcGVjaWZpZWQgYSBnYXMgbGltaXQgTElNSVQgKG1heGltdW0gZ2FzKSBmb3IgICAgXFxcXFxcbiAgICBcXFxcdGhlIHRyYW5zYWN0aW9uLCBhbmQgdGhlIHByaWNlIGlzIHRoZSBzcG90IHByaWNlIG9mIGdhcyBhdCB0aGF0IHRpbWUuICAgIFxcXFxcXG4gICAgXFxcXFRoZSBnYXMgYnV5IHdpbGwgYmUgZXhlY3V0ZWQgcHJpb3IgdG8gZXhlY3V0aW5nIFNFTkRFUidzIGNvZGUuXFxcIlxcblxcbiAgICBAbW9kZWwgWyAocHJvcGVydHkgKD4gdG90YWwgMC4wKSlcXG4gICAgICAgICAgICAgKHByb3BlcnR5ICh2YWxpZC1hY2NvdW50IHNlbmRlcikpXFxuICAgICAgICAgICBdXFxuXFxuICAgICh2YWxpZGF0ZS1hY2NvdW50IHNlbmRlcilcXG5cXG4gICAgKGVuZm9yY2UtdW5pdCB0b3RhbClcXG4gICAgKGVuZm9yY2UgKD4gdG90YWwgMC4wKSBcXFwiZ2FzIHN1cHBseSBtdXN0IGJlIGEgcG9zaXRpdmUgcXVhbnRpdHlcXFwiKVxcblxcbiAgICAocmVxdWlyZS1jYXBhYmlsaXR5IChHQVMpKVxcbiAgICAod2l0aC1jYXBhYmlsaXR5IChERUJJVCBzZW5kZXIpXFxuICAgICAgKGRlYml0IHNlbmRlciB0b3RhbCkpXFxuICAgIClcXG5cXG4gIChkZWZ1biByZWRlZW0tZ2FzOnN0cmluZyAobWluZXI6c3RyaW5nIG1pbmVyLWd1YXJkOmd1YXJkIHNlbmRlcjpzdHJpbmcgdG90YWw6ZGVjaW1hbClcXG4gICAgQGRvYyBcXFwiVGhpcyBmdW5jdGlvbiBkZXNjcmliZXMgdGhlIG1haW4gJ3JlZGVlbSBnYXMnIG9wZXJhdGlvbi4gQXQgdGhpcyAgICBcXFxcXFxuICAgIFxcXFxwb2ludCwgdGhlIFNFTkRFUidzIHRyYW5zYWN0aW9uIGhhcyBiZWVuIGV4ZWN1dGVkLCBhbmQgdGhlIGdhcyB0aGF0ICAgICAgXFxcXFxcbiAgICBcXFxcd2FzIGNoYXJnZWQgaGFzIGJlZW4gY2FsY3VsYXRlZC4gTUlORVIgd2lsbCBiZSBjcmVkaXRlZCB0aGUgZ2FzIGNvc3QsICAgIFxcXFxcXG4gICAgXFxcXGFuZCBTRU5ERVIgd2lsbCByZWNlaXZlIHRoZSByZW1haW5kZXIgdXAgdG8gdGhlIGxpbWl0XFxcIlxcblxcbiAgICBAbW9kZWwgWyAocHJvcGVydHkgKD4gdG90YWwgMC4wKSlcXG4gICAgICAgICAgICAgKHByb3BlcnR5ICh2YWxpZC1hY2NvdW50IHNlbmRlcikpXFxuICAgICAgICAgICAgIChwcm9wZXJ0eSAodmFsaWQtYWNjb3VudCBtaW5lcikpXFxuICAgICAgICAgICBdXFxuXFxuICAgICh2YWxpZGF0ZS1hY2NvdW50IHNlbmRlcilcXG4gICAgKHZhbGlkYXRlLWFjY291bnQgbWluZXIpXFxuICAgIChlbmZvcmNlLXVuaXQgdG90YWwpXFxuXFxuICAgIChyZXF1aXJlLWNhcGFiaWxpdHkgKEdBUykpXFxuICAgIChsZXQqXFxuICAgICAgKChmZWUgKHJlYWQtZGVjaW1hbCBcXFwiZmVlXFxcIikpXFxuICAgICAgIChyZWZ1bmQgKC0gdG90YWwgZmVlKSkpXFxuXFxuICAgICAgKGVuZm9yY2UtdW5pdCBmZWUpXFxuICAgICAgKGVuZm9yY2UgKD49IGZlZSAwLjApXFxuICAgICAgICBcXFwiZmVlIG11c3QgYmUgYSBub24tbmVnYXRpdmUgcXVhbnRpdHlcXFwiKVxcblxcbiAgICAgIChlbmZvcmNlICg-PSByZWZ1bmQgMC4wKVxcbiAgICAgICAgXFxcInJlZnVuZCBtdXN0IGJlIGEgbm9uLW5lZ2F0aXZlIHF1YW50aXR5XFxcIilcXG5cXG4gICAgICAoZW1pdC1ldmVudCAoVFJBTlNGRVIgc2VuZGVyIG1pbmVyIGZlZSkpIDt2M1xcblxcbiAgICAgICAgOyBkaXJlY3RseSB1cGRhdGUgaW5zdGVhZCBvZiBjcmVkaXRcXG4gICAgICAod2l0aC1jYXBhYmlsaXR5IChDUkVESVQgc2VuZGVyKVxcbiAgICAgICAgKGlmICg-IHJlZnVuZCAwLjApXFxuICAgICAgICAgICh3aXRoLXJlYWQgY29pbi10YWJsZSBzZW5kZXJcXG4gICAgICAgICAgICB7IFxcXCJiYWxhbmNlXFxcIiA6PSBiYWxhbmNlIH1cXG4gICAgICAgICAgICAodXBkYXRlIGNvaW4tdGFibGUgc2VuZGVyXFxuICAgICAgICAgICAgICB7IFxcXCJiYWxhbmNlXFxcIjogKCsgYmFsYW5jZSByZWZ1bmQpIH0pKVxcblxcbiAgICAgICAgICBcXFwibm9vcFxcXCIpKVxcblxcbiAgICAgICh3aXRoLWNhcGFiaWxpdHkgKENSRURJVCBtaW5lcilcXG4gICAgICAgIChpZiAoPiBmZWUgMC4wKVxcbiAgICAgICAgICAoY3JlZGl0IG1pbmVyIG1pbmVyLWd1YXJkIGZlZSlcXG4gICAgICAgICAgXFxcIm5vb3BcXFwiKSlcXG4gICAgICApXFxuXFxuICAgIClcXG5cXG4gIChkZWZ1biBjcmVhdGUtYWNjb3VudDpzdHJpbmcgKGFjY291bnQ6c3RyaW5nIGd1YXJkOmd1YXJkKVxcbiAgICBAbW9kZWwgWyAocHJvcGVydHkgKHZhbGlkLWFjY291bnQgYWNjb3VudCkpIF1cXG5cXG4gICAgKHZhbGlkYXRlLWFjY291bnQgYWNjb3VudClcXG4gICAgKGVuZm9yY2UtcmVzZXJ2ZWQgYWNjb3VudCBndWFyZClcXG5cXG4gICAgKGluc2VydCBjb2luLXRhYmxlIGFjY291bnRcXG4gICAgICB7IFxcXCJiYWxhbmNlXFxcIiA6IDAuMFxcbiAgICAgICwgXFxcImd1YXJkXFxcIiAgIDogZ3VhcmRcXG4gICAgICB9KVxcbiAgICApXFxuXFxuICAoZGVmdW4gZ2V0LWJhbGFuY2U6ZGVjaW1hbCAoYWNjb3VudDpzdHJpbmcpXFxuICAgICh3aXRoLXJlYWQgY29pbi10YWJsZSBhY2NvdW50XFxuICAgICAgeyBcXFwiYmFsYW5jZVxcXCIgOj0gYmFsYW5jZSB9XFxuICAgICAgYmFsYW5jZVxcbiAgICAgIClcXG4gICAgKVxcblxcbiAgKGRlZnVuIGRldGFpbHM6b2JqZWN0e2Z1bmdpYmxlLXYyLmFjY291bnQtZGV0YWlsc31cXG4gICAgKCBhY2NvdW50OnN0cmluZyApXFxuICAgICh3aXRoLXJlYWQgY29pbi10YWJsZSBhY2NvdW50XFxuICAgICAgeyBcXFwiYmFsYW5jZVxcXCIgOj0gYmFsXFxuICAgICAgLCBcXFwiZ3VhcmRcXFwiIDo9IGcgfVxcbiAgICAgIHsgXFxcImFjY291bnRcXFwiIDogYWNjb3VudFxcbiAgICAgICwgXFxcImJhbGFuY2VcXFwiIDogYmFsXFxuICAgICAgLCBcXFwiZ3VhcmRcXFwiOiBnIH0pXFxuICAgIClcXG5cXG4gIChkZWZ1biByb3RhdGU6c3RyaW5nIChhY2NvdW50OnN0cmluZyBuZXctZ3VhcmQ6Z3VhcmQpXFxuICAgICh3aXRoLWNhcGFiaWxpdHkgKFJPVEFURSBhY2NvdW50KVxcblxcbiAgICAgIDsgQWxsb3cgcm90YXRpb24gb25seSBmb3IgdmFuaXR5IGFjY291bnRzLCBvclxcbiAgICAgIDsgcmUtcm90YXRpbmcgYSBwcmluY2lwYWwgYWNjb3VudCBiYWNrIHRvIGl0cyBwcm9wZXIgZ3VhcmRcXG4gICAgICAoZW5mb3JjZSAob3IgKG5vdCAoaXMtcHJpbmNpcGFsIGFjY291bnQpKVxcbiAgICAgICAgICAgICAgICAgICh2YWxpZGF0ZS1wcmluY2lwYWwgbmV3LWd1YXJkIGFjY291bnQpKVxcbiAgICAgICAgXFxcIkl0IGlzIHVuc2FmZSBmb3IgcHJpbmNpcGFsIGFjY291bnRzIHRvIHJvdGF0ZSB0aGVpciBndWFyZFxcXCIpXFxuXFxuICAgICAgKHdpdGgtcmVhZCBjb2luLXRhYmxlIGFjY291bnRcXG4gICAgICAgIHsgXFxcImd1YXJkXFxcIiA6PSBvbGQtZ3VhcmQgfVxcbiAgICAgICAgKGVuZm9yY2UtZ3VhcmQgb2xkLWd1YXJkKVxcbiAgICAgICAgKHVwZGF0ZSBjb2luLXRhYmxlIGFjY291bnRcXG4gICAgICAgICAgeyBcXFwiZ3VhcmRcXFwiIDogbmV3LWd1YXJkIH1cXG4gICAgICAgICAgKSkpXFxuICAgIClcXG5cXG5cXG4gIChkZWZ1biBwcmVjaXNpb246aW50ZWdlclxcbiAgICAoKVxcbiAgICBNSU5JTVVNX1BSRUNJU0lPTilcXG5cXG4gIChkZWZ1biB0cmFuc2ZlcjpzdHJpbmcgKHNlbmRlcjpzdHJpbmcgcmVjZWl2ZXI6c3RyaW5nIGFtb3VudDpkZWNpbWFsKVxcbiAgICBAbW9kZWwgWyAocHJvcGVydHkgY29uc2VydmVzLW1hc3MpXFxuICAgICAgICAgICAgIChwcm9wZXJ0eSAoPiBhbW91bnQgMC4wKSlcXG4gICAgICAgICAgICAgKHByb3BlcnR5ICh2YWxpZC1hY2NvdW50IHNlbmRlcikpXFxuICAgICAgICAgICAgIChwcm9wZXJ0eSAodmFsaWQtYWNjb3VudCByZWNlaXZlcikpXFxuICAgICAgICAgICAgIChwcm9wZXJ0eSAoIT0gc2VuZGVyIHJlY2VpdmVyKSkgXVxcblxcbiAgICAoZW5mb3JjZSAoIT0gc2VuZGVyIHJlY2VpdmVyKVxcbiAgICAgIFxcXCJzZW5kZXIgY2Fubm90IGJlIHRoZSByZWNlaXZlciBvZiBhIHRyYW5zZmVyXFxcIilcXG5cXG4gICAgKHZhbGlkYXRlLWFjY291bnQgc2VuZGVyKVxcbiAgICAodmFsaWRhdGUtYWNjb3VudCByZWNlaXZlcilcXG5cXG4gICAgKGVuZm9yY2UgKD4gYW1vdW50IDAuMClcXG4gICAgICBcXFwidHJhbnNmZXIgYW1vdW50IG11c3QgYmUgcG9zaXRpdmVcXFwiKVxcblxcbiAgICAoZW5mb3JjZS11bml0IGFtb3VudClcXG5cXG4gICAgKHdpdGgtY2FwYWJpbGl0eSAoVFJBTlNGRVIgc2VuZGVyIHJlY2VpdmVyIGFtb3VudClcXG4gICAgICAoZGViaXQgc2VuZGVyIGFtb3VudClcXG4gICAgICAod2l0aC1yZWFkIGNvaW4tdGFibGUgcmVjZWl2ZXJcXG4gICAgICAgIHsgXFxcImd1YXJkXFxcIiA6PSBnIH1cXG5cXG4gICAgICAgIChjcmVkaXQgcmVjZWl2ZXIgZyBhbW91bnQpKVxcbiAgICAgIClcXG4gICAgKVxcblxcbiAgKGRlZnVuIHRyYW5zZmVyLWNyZWF0ZTpzdHJpbmdcXG4gICAgKCBzZW5kZXI6c3RyaW5nXFxuICAgICAgcmVjZWl2ZXI6c3RyaW5nXFxuICAgICAgcmVjZWl2ZXItZ3VhcmQ6Z3VhcmRcXG4gICAgICBhbW91bnQ6ZGVjaW1hbCApXFxuXFxuICAgIEBtb2RlbCBbIChwcm9wZXJ0eSBjb25zZXJ2ZXMtbWFzcykgXVxcblxcbiAgICAoZW5mb3JjZSAoIT0gc2VuZGVyIHJlY2VpdmVyKVxcbiAgICAgIFxcXCJzZW5kZXIgY2Fubm90IGJlIHRoZSByZWNlaXZlciBvZiBhIHRyYW5zZmVyXFxcIilcXG5cXG4gICAgKHZhbGlkYXRlLWFjY291bnQgc2VuZGVyKVxcbiAgICAodmFsaWRhdGUtYWNjb3VudCByZWNlaXZlcilcXG5cXG4gICAgKGVuZm9yY2UgKD4gYW1vdW50IDAuMClcXG4gICAgICBcXFwidHJhbnNmZXIgYW1vdW50IG11c3QgYmUgcG9zaXRpdmVcXFwiKVxcblxcbiAgICAoZW5mb3JjZS11bml0IGFtb3VudClcXG5cXG4gICAgKHdpdGgtY2FwYWJpbGl0eSAoVFJBTlNGRVIgc2VuZGVyIHJlY2VpdmVyIGFtb3VudClcXG4gICAgICAoZGViaXQgc2VuZGVyIGFtb3VudClcXG4gICAgICAoY3JlZGl0IHJlY2VpdmVyIHJlY2VpdmVyLWd1YXJkIGFtb3VudCkpXFxuICAgIClcXG5cXG4gIChkZWZ1biBjb2luYmFzZTpzdHJpbmcgKGFjY291bnQ6c3RyaW5nIGFjY291bnQtZ3VhcmQ6Z3VhcmQgYW1vdW50OmRlY2ltYWwpXFxuICAgIEBkb2MgXFxcIkludGVybmFsIGZ1bmN0aW9uIGZvciB0aGUgaW5pdGlhbCBjcmVhdGlvbiBvZiBjb2lucy4gIFRoaXMgZnVuY3Rpb24gXFxcXFxcbiAgICBcXFxcY2Fubm90IGJlIHVzZWQgb3V0c2lkZSBvZiB0aGUgY29pbiBjb250cmFjdC5cXFwiXFxuXFxuICAgIEBtb2RlbCBbIChwcm9wZXJ0eSAodmFsaWQtYWNjb3VudCBhY2NvdW50KSlcXG4gICAgICAgICAgICAgKHByb3BlcnR5ICg-IGFtb3VudCAwLjApKVxcbiAgICAgICAgICAgXVxcblxcbiAgICAodmFsaWRhdGUtYWNjb3VudCBhY2NvdW50KVxcbiAgICAoZW5mb3JjZS11bml0IGFtb3VudClcXG5cXG4gICAgKHJlcXVpcmUtY2FwYWJpbGl0eSAoQ09JTkJBU0UpKVxcbiAgICAoZW1pdC1ldmVudCAoVFJBTlNGRVIgXFxcIlxcXCIgYWNjb3VudCBhbW91bnQpKSA7djNcXG4gICAgKHdpdGgtY2FwYWJpbGl0eSAoQ1JFRElUIGFjY291bnQpXFxuICAgICAgKGNyZWRpdCBhY2NvdW50IGFjY291bnQtZ3VhcmQgYW1vdW50KSlcXG4gICAgKVxcblxcbiAgKGRlZnVuIHJlbWVkaWF0ZTpzdHJpbmcgKGFjY291bnQ6c3RyaW5nIGFtb3VudDpkZWNpbWFsKVxcbiAgICBAZG9jIFxcXCJBbGxvd3MgZm9yIHJlbWVkaWF0aW9uIHRyYW5zYWN0aW9ucy4gVGhpcyBmdW5jdGlvbiBcXFxcXFxuICAgICAgICAgXFxcXGlzIHByb3RlY3RlZCBieSB0aGUgUkVNRURJQVRFIGNhcGFiaWxpdHlcXFwiXFxuICAgIEBtb2RlbCBbIChwcm9wZXJ0eSAodmFsaWQtYWNjb3VudCBhY2NvdW50KSlcXG4gICAgICAgICAgICAgKHByb3BlcnR5ICg-IGFtb3VudCAwLjApKVxcbiAgICAgICAgICAgXVxcblxcbiAgICAodmFsaWRhdGUtYWNjb3VudCBhY2NvdW50KVxcblxcbiAgICAoZW5mb3JjZSAoPiBhbW91bnQgMC4wKVxcbiAgICAgIFxcXCJSZW1lZGlhdGlvbiBhbW91bnQgbXVzdCBiZSBwb3NpdGl2ZVxcXCIpXFxuXFxuICAgIChlbmZvcmNlLXVuaXQgYW1vdW50KVxcblxcbiAgICAocmVxdWlyZS1jYXBhYmlsaXR5IChSRU1FRElBVEUpKVxcbiAgICAoZW1pdC1ldmVudCAoVFJBTlNGRVIgXFxcIlxcXCIgYWNjb3VudCBhbW91bnQpKSA7djNcXG4gICAgKHdpdGgtcmVhZCBjb2luLXRhYmxlIGFjY291bnRcXG4gICAgICB7IFxcXCJiYWxhbmNlXFxcIiA6PSBiYWxhbmNlIH1cXG5cXG4gICAgICAoZW5mb3JjZSAoPD0gYW1vdW50IGJhbGFuY2UpIFxcXCJJbnN1ZmZpY2llbnQgZnVuZHNcXFwiKVxcblxcbiAgICAgICh1cGRhdGUgY29pbi10YWJsZSBhY2NvdW50XFxuICAgICAgICB7IFxcXCJiYWxhbmNlXFxcIiA6ICgtIGJhbGFuY2UgYW1vdW50KSB9XFxuICAgICAgICApKVxcbiAgICApXFxuXFxuICAoZGVmcGFjdCBmdW5kLXR4IChzZW5kZXI6c3RyaW5nIG1pbmVyOnN0cmluZyBtaW5lci1ndWFyZDpndWFyZCB0b3RhbDpkZWNpbWFsKVxcbiAgICBAZG9jIFxcXCInZnVuZC10eCcgaXMgYSBzcGVjaWFsIHBhY3QgdG8gZnVuZCBhIHRyYW5zYWN0aW9uIGluIHR3byBzdGVwcywgICAgIFxcXFxcXG4gICAgXFxcXHdpdGggdGhlIGFjdHVhbCB0cmFuc2FjdGlvbiB0cmFuc3BpcmluZyBpbiB0aGUgbWlkZGxlOiAgICAgICAgICAgICAgICAgICBcXFxcXFxuICAgIFxcXFwgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgXFxcXFxcbiAgICBcXFxcICAxKSBBIGJ1eWluZyBwaGFzZSwgZGViaXRpbmcgdGhlIHNlbmRlciBmb3IgdG90YWwgZ2FzIGFuZCBmZWUsIHlpZWxkaW5nIFxcXFxcXG4gICAgXFxcXCAgICAgVFhfTUFYX0NIQVJHRS4gICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICBcXFxcXFxuICAgIFxcXFwgIDIpIEEgc2V0dGxlbWVudCBwaGFzZSwgcmVzdW1pbmcgVFhfTUFYX0NIQVJHRSwgYW5kIGFsbG9jYXRpbmcgdG8gdGhlICAgXFxcXFxcbiAgICBcXFxcICAgICBjb2luYmFzZSBhY2NvdW50IGZvciB1c2VkIGdhcyBhbmQgZmVlLCBhbmQgc2VuZGVyIGFjY291bnQgZm9yIGJhbC0gIFxcXFxcXG4gICAgXFxcXCAgICAgYW5jZSAodW51c2VkIGdhcywgaWYgYW55KS5cXFwiXFxuXFxuICAgIEBtb2RlbCBbIChwcm9wZXJ0eSAoPiB0b3RhbCAwLjApKVxcbiAgICAgICAgICAgICAocHJvcGVydHkgKHZhbGlkLWFjY291bnQgc2VuZGVyKSlcXG4gICAgICAgICAgICAgKHByb3BlcnR5ICh2YWxpZC1hY2NvdW50IG1pbmVyKSlcXG4gICAgICAgICAgICAgOyhwcm9wZXJ0eSBjb25zZXJ2ZXMtbWFzcykgbm90IHN1cHBvcnRlZCB5ZXRcXG4gICAgICAgICAgIF1cXG5cXG4gICAgKHN0ZXAgKGJ1eS1nYXMgc2VuZGVyIHRvdGFsKSlcXG4gICAgKHN0ZXAgKHJlZGVlbS1nYXMgbWluZXIgbWluZXItZ3VhcmQgc2VuZGVyIHRvdGFsKSlcXG4gICAgKVxcblxcbiAgKGRlZnVuIGRlYml0OnN0cmluZyAoYWNjb3VudDpzdHJpbmcgYW1vdW50OmRlY2ltYWwpXFxuICAgIEBkb2MgXFxcIkRlYml0IEFNT1VOVCBmcm9tIEFDQ09VTlQgYmFsYW5jZVxcXCJcXG5cXG4gICAgQG1vZGVsIFsgKHByb3BlcnR5ICg-IGFtb3VudCAwLjApKVxcbiAgICAgICAgICAgICAocHJvcGVydHkgKHZhbGlkLWFjY291bnQgYWNjb3VudCkpXFxuICAgICAgICAgICBdXFxuXFxuICAgICh2YWxpZGF0ZS1hY2NvdW50IGFjY291bnQpXFxuXFxuICAgIChlbmZvcmNlICg-IGFtb3VudCAwLjApXFxuICAgICAgXFxcImRlYml0IGFtb3VudCBtdXN0IGJlIHBvc2l0aXZlXFxcIilcXG5cXG4gICAgKGVuZm9yY2UtdW5pdCBhbW91bnQpXFxuXFxuICAgIChyZXF1aXJlLWNhcGFiaWxpdHkgKERFQklUIGFjY291bnQpKVxcbiAgICAod2l0aC1yZWFkIGNvaW4tdGFibGUgYWNjb3VudFxcbiAgICAgIHsgXFxcImJhbGFuY2VcXFwiIDo9IGJhbGFuY2UgfVxcblxcbiAgICAgIChlbmZvcmNlICg8PSBhbW91bnQgYmFsYW5jZSkgXFxcIkluc3VmZmljaWVudCBmdW5kc1xcXCIpXFxuXFxuICAgICAgKHVwZGF0ZSBjb2luLXRhYmxlIGFjY291bnRcXG4gICAgICAgIHsgXFxcImJhbGFuY2VcXFwiIDogKC0gYmFsYW5jZSBhbW91bnQpIH1cXG4gICAgICAgICkpXFxuICAgIClcXG5cXG5cXG4gIChkZWZ1biBjcmVkaXQ6c3RyaW5nIChhY2NvdW50OnN0cmluZyBndWFyZDpndWFyZCBhbW91bnQ6ZGVjaW1hbClcXG4gICAgQGRvYyBcXFwiQ3JlZGl0IEFNT1VOVCB0byBBQ0NPVU5UIGJhbGFuY2VcXFwiXFxuXFxuICAgIEBtb2RlbCBbIChwcm9wZXJ0eSAoPiBhbW91bnQgMC4wKSlcXG4gICAgICAgICAgICAgKHByb3BlcnR5ICh2YWxpZC1hY2NvdW50IGFjY291bnQpKVxcbiAgICAgICAgICAgXVxcblxcbiAgICAodmFsaWRhdGUtYWNjb3VudCBhY2NvdW50KVxcblxcbiAgICAoZW5mb3JjZSAoPiBhbW91bnQgMC4wKSBcXFwiY3JlZGl0IGFtb3VudCBtdXN0IGJlIHBvc2l0aXZlXFxcIilcXG4gICAgKGVuZm9yY2UtdW5pdCBhbW91bnQpXFxuXFxuICAgIChyZXF1aXJlLWNhcGFiaWxpdHkgKENSRURJVCBhY2NvdW50KSlcXG4gICAgKHdpdGgtZGVmYXVsdC1yZWFkIGNvaW4tdGFibGUgYWNjb3VudFxcbiAgICAgIHsgXFxcImJhbGFuY2VcXFwiIDogLTEuMCwgXFxcImd1YXJkXFxcIiA6IGd1YXJkIH1cXG4gICAgICB7IFxcXCJiYWxhbmNlXFxcIiA6PSBiYWxhbmNlLCBcXFwiZ3VhcmRcXFwiIDo9IHJldGcgfVxcbiAgICAgIDsgd2UgZG9uJ3Qgd2FudCB0byBvdmVyd3JpdGUgYW4gZXhpc3RpbmcgZ3VhcmQgd2l0aCB0aGUgdXNlci1zdXBwbGllZCBvbmVcXG4gICAgICAoZW5mb3JjZSAoPSByZXRnIGd1YXJkKVxcbiAgICAgICAgXFxcImFjY291bnQgZ3VhcmRzIGRvIG5vdCBtYXRjaFxcXCIpXFxuXFxuICAgICAgKGxldCAoKGlzLW5ld1xcbiAgICAgICAgICAgICAoaWYgKD0gYmFsYW5jZSAtMS4wKVxcbiAgICAgICAgICAgICAgICAgKGVuZm9yY2UtcmVzZXJ2ZWQgYWNjb3VudCBndWFyZClcXG4gICAgICAgICAgICAgICBmYWxzZSkpKVxcblxcbiAgICAgICAgKHdyaXRlIGNvaW4tdGFibGUgYWNjb3VudFxcbiAgICAgICAgICB7IFxcXCJiYWxhbmNlXFxcIiA6IChpZiBpcy1uZXcgYW1vdW50ICgrIGJhbGFuY2UgYW1vdW50KSlcXG4gICAgICAgICAgLCBcXFwiZ3VhcmRcXFwiICAgOiByZXRnXFxuICAgICAgICAgIH0pKVxcbiAgICAgICkpXFxuXFxuICAoZGVmdW4gY2hlY2stcmVzZXJ2ZWQ6c3RyaW5nIChhY2NvdW50OnN0cmluZylcXG4gICAgXFxcIiBDaGVja3MgQUNDT1VOVCBmb3IgcmVzZXJ2ZWQgbmFtZSBhbmQgcmV0dXJucyB0eXBlIGlmIFxcXFxcXG4gICAgXFxcXCBmb3VuZCBvciBlbXB0eSBzdHJpbmcuIFJlc2VydmVkIG5hbWVzIHN0YXJ0IHdpdGggYSBcXFxcXFxuICAgIFxcXFwgc2luZ2xlIGNoYXIgYW5kIGNvbG9uLCBlLmcuICdjOmZvbycsIHdoaWNoIHdvdWxkIHJldHVybiAnYycgYXMgdHlwZS5cXFwiXFxuICAgIChsZXQgKChwZnggKHRha2UgMiBhY2NvdW50KSkpXFxuICAgICAgKGlmICg9IFxcXCI6XFxcIiAodGFrZSAtMSBwZngpKSAodGFrZSAxIHBmeCkgXFxcIlxcXCIpKSlcXG5cXG4gIChkZWZ1biBlbmZvcmNlLXJlc2VydmVkOmJvb2wgKGFjY291bnQ6c3RyaW5nIGd1YXJkOmd1YXJkKVxcbiAgICBAZG9jIFxcXCJFbmZvcmNlIHJlc2VydmVkIGFjY291bnQgbmFtZSBwcm90b2NvbHMuXFxcIlxcbiAgICAoaWYgKHZhbGlkYXRlLXByaW5jaXBhbCBndWFyZCBhY2NvdW50KVxcbiAgICAgIHRydWVcXG4gICAgICAobGV0ICgociAoY2hlY2stcmVzZXJ2ZWQgYWNjb3VudCkpKVxcbiAgICAgICAgKGlmICg9IHIgXFxcIlxcXCIpXFxuICAgICAgICAgIHRydWVcXG4gICAgICAgICAgKGlmICg9IHIgXFxcImtcXFwiKVxcbiAgICAgICAgICAgIChlbmZvcmNlIGZhbHNlIFxcXCJTaW5nbGUta2V5IGFjY291bnQgcHJvdG9jb2wgdmlvbGF0aW9uXFxcIilcXG4gICAgICAgICAgICAoZW5mb3JjZSBmYWxzZVxcbiAgICAgICAgICAgICAgKGZvcm1hdCBcXFwiUmVzZXJ2ZWQgcHJvdG9jb2wgZ3VhcmQgdmlvbGF0aW9uOiB7fVxcXCIgW3JdKSlcXG4gICAgICAgICAgICApKSkpKVxcblxcblxcbiAgKGRlZnNjaGVtYSBjcm9zc2NoYWluLXNjaGVtYVxcbiAgICBAZG9jIFxcXCJTY2hlbWEgZm9yIHlpZWxkZWQgdmFsdWUgaW4gY3Jvc3MtY2hhaW4gdHJhbnNmZXJzXFxcIlxcbiAgICByZWNlaXZlcjpzdHJpbmdcXG4gICAgcmVjZWl2ZXItZ3VhcmQ6Z3VhcmRcXG4gICAgYW1vdW50OmRlY2ltYWxcXG4gICAgc291cmNlLWNoYWluOnN0cmluZylcXG5cXG4gIChkZWZwYWN0IHRyYW5zZmVyLWNyb3NzY2hhaW46c3RyaW5nXFxuICAgICggc2VuZGVyOnN0cmluZ1xcbiAgICAgIHJlY2VpdmVyOnN0cmluZ1xcbiAgICAgIHJlY2VpdmVyLWd1YXJkOmd1YXJkXFxuICAgICAgdGFyZ2V0LWNoYWluOnN0cmluZ1xcbiAgICAgIGFtb3VudDpkZWNpbWFsIClcXG5cXG4gICAgQG1vZGVsIFsgKHByb3BlcnR5ICg-IGFtb3VudCAwLjApKVxcbiAgICAgICAgICAgICAocHJvcGVydHkgKHZhbGlkLWFjY291bnQgc2VuZGVyKSlcXG4gICAgICAgICAgICAgKHByb3BlcnR5ICh2YWxpZC1hY2NvdW50IHJlY2VpdmVyKSlcXG4gICAgICAgICAgIF1cXG5cXG4gICAgKHN0ZXBcXG4gICAgICAod2l0aC1jYXBhYmlsaXR5XFxuICAgICAgICAoVFJBTlNGRVJfWENIQUlOIHNlbmRlciByZWNlaXZlciBhbW91bnQgdGFyZ2V0LWNoYWluKVxcblxcbiAgICAgICAgKHZhbGlkYXRlLWFjY291bnQgc2VuZGVyKVxcbiAgICAgICAgKHZhbGlkYXRlLWFjY291bnQgcmVjZWl2ZXIpXFxuXFxuICAgICAgICAoZW5mb3JjZSAoIT0gXFxcIlxcXCIgdGFyZ2V0LWNoYWluKSBcXFwiZW1wdHkgdGFyZ2V0LWNoYWluXFxcIilcXG4gICAgICAgIChlbmZvcmNlICghPSAoYXQgJ2NoYWluLWlkIChjaGFpbi1kYXRhKSkgdGFyZ2V0LWNoYWluKVxcbiAgICAgICAgICBcXFwiY2Fubm90IHJ1biBjcm9zcy1jaGFpbiB0cmFuc2ZlcnMgdG8gdGhlIHNhbWUgY2hhaW5cXFwiKVxcblxcbiAgICAgICAgKGVuZm9yY2UgKD4gYW1vdW50IDAuMClcXG4gICAgICAgICAgXFxcInRyYW5zZmVyIHF1YW50aXR5IG11c3QgYmUgcG9zaXRpdmVcXFwiKVxcblxcbiAgICAgICAgKGVuZm9yY2UtdW5pdCBhbW91bnQpXFxuXFxuICAgICAgICAoZW5mb3JjZSAoY29udGFpbnMgdGFyZ2V0LWNoYWluIFZBTElEX0NIQUlOX0lEUylcXG4gICAgICAgICAgXFxcInRhcmdldCBjaGFpbiBpcyBub3QgYSB2YWxpZCBjaGFpbndlYiBjaGFpbiBpZFxcXCIpXFxuXFxuICAgICAgICA7OyBzdGVwIDEgLSBkZWJpdCBkZWxldGUtYWNjb3VudCBvbiBjdXJyZW50IGNoYWluXFxuICAgICAgICAoZGViaXQgc2VuZGVyIGFtb3VudClcXG4gICAgICAgIChlbWl0LWV2ZW50IChUUkFOU0ZFUiBzZW5kZXIgXFxcIlxcXCIgYW1vdW50KSlcXG5cXG4gICAgICAgIChsZXRcXG4gICAgICAgICAgKChjcm9zc2NoYWluLWRldGFpbHM6b2JqZWN0e2Nyb3NzY2hhaW4tc2NoZW1hfVxcbiAgICAgICAgICAgIHsgXFxcInJlY2VpdmVyXFxcIiA6IHJlY2VpdmVyXFxuICAgICAgICAgICAgLCBcXFwicmVjZWl2ZXItZ3VhcmRcXFwiIDogcmVjZWl2ZXItZ3VhcmRcXG4gICAgICAgICAgICAsIFxcXCJhbW91bnRcXFwiIDogYW1vdW50XFxuICAgICAgICAgICAgLCBcXFwic291cmNlLWNoYWluXFxcIiA6IChhdCAnY2hhaW4taWQgKGNoYWluLWRhdGEpKVxcbiAgICAgICAgICAgIH0pKVxcbiAgICAgICAgICAoeWllbGQgY3Jvc3NjaGFpbi1kZXRhaWxzIHRhcmdldC1jaGFpbilcXG4gICAgICAgICAgKSkpXFxuXFxuICAgIChzdGVwXFxuICAgICAgKHJlc3VtZVxcbiAgICAgICAgeyBcXFwicmVjZWl2ZXJcXFwiIDo9IHJlY2VpdmVyXFxuICAgICAgICAsIFxcXCJyZWNlaXZlci1ndWFyZFxcXCIgOj0gcmVjZWl2ZXItZ3VhcmRcXG4gICAgICAgICwgXFxcImFtb3VudFxcXCIgOj0gYW1vdW50XFxuICAgICAgICAsIFxcXCJzb3VyY2UtY2hhaW5cXFwiIDo9IHNvdXJjZS1jaGFpblxcbiAgICAgICAgfVxcblxcbiAgICAgICAgKGVtaXQtZXZlbnQgKFRSQU5TRkVSIFxcXCJcXFwiIHJlY2VpdmVyIGFtb3VudCkpXFxuICAgICAgICAoZW1pdC1ldmVudCAoVFJBTlNGRVJfWENIQUlOX1JFQ0QgXFxcIlxcXCIgcmVjZWl2ZXIgYW1vdW50IHNvdXJjZS1jaGFpbikpXFxuXFxuICAgICAgICA7OyBzdGVwIDIgLSBjcmVkaXQgY3JlYXRlIGFjY291bnQgb24gdGFyZ2V0IGNoYWluXFxuICAgICAgICAod2l0aC1jYXBhYmlsaXR5IChDUkVESVQgcmVjZWl2ZXIpXFxuICAgICAgICAgIChjcmVkaXQgcmVjZWl2ZXIgcmVjZWl2ZXItZ3VhcmQgYW1vdW50KSlcXG4gICAgICAgICkpXFxuICAgIClcXG5cXG5cXG4gIDsgLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS1cXG4gIDsgQ29pbiBhbGxvY2F0aW9uc1xcblxcbiAgKGRlZnNjaGVtYSBhbGxvY2F0aW9uLXNjaGVtYVxcbiAgICBAZG9jIFxcXCJHZW5lc2lzIGFsbG9jYXRpb24gcmVnaXN0cnlcXFwiXFxuICAgIDtAbW9kZWwgWyAoaW52YXJpYW50ICg-PSBiYWxhbmNlIDAuMCkpIF1cXG5cXG4gICAgYmFsYW5jZTpkZWNpbWFsXFxuICAgIGRhdGU6dGltZVxcbiAgICBndWFyZDpndWFyZFxcbiAgICByZWRlZW1lZDpib29sKVxcblxcbiAgKGRlZnRhYmxlIGFsbG9jYXRpb24tdGFibGU6e2FsbG9jYXRpb24tc2NoZW1hfSlcXG5cXG4gIChkZWZ1biBjcmVhdGUtYWxsb2NhdGlvbi1hY2NvdW50XFxuICAgICggYWNjb3VudDpzdHJpbmdcXG4gICAgICBkYXRlOnRpbWVcXG4gICAgICBrZXlzZXQtcmVmOnN0cmluZ1xcbiAgICAgIGFtb3VudDpkZWNpbWFsXFxuICAgIClcXG5cXG4gICAgQGRvYyBcXFwiQWRkIGFuIGVudHJ5IHRvIHRoZSBjb2luIGFsbG9jYXRpb24gdGFibGUuIFRoaXMgZnVuY3Rpb24gXFxcXFxcbiAgICAgICAgIFxcXFxhbHNvIGNyZWF0ZXMgYSBjb3JyZXNwb25kaW5nIGVtcHR5IGNvaW4gY29udHJhY3QgYWNjb3VudCBcXFxcXFxuICAgICAgICAgXFxcXG9mIHRoZSBzYW1lIG5hbWUgYW5kIGd1YXJkLiBSZXF1aXJlcyBHRU5FU0lTIGNhcGFiaWxpdHkuIFxcXCJcXG5cXG4gICAgQG1vZGVsIFsgKHByb3BlcnR5ICh2YWxpZC1hY2NvdW50IGFjY291bnQpKSBdXFxuXFxuICAgIChyZXF1aXJlLWNhcGFiaWxpdHkgKEdFTkVTSVMpKVxcblxcbiAgICAodmFsaWRhdGUtYWNjb3VudCBhY2NvdW50KVxcbiAgICAoZW5mb3JjZSAoPj0gYW1vdW50IDAuMClcXG4gICAgICBcXFwiYWxsb2NhdGlvbiBhbW91bnQgbXVzdCBiZSBub24tbmVnYXRpdmVcXFwiKVxcblxcbiAgICAoZW5mb3JjZS11bml0IGFtb3VudClcXG5cXG4gICAgKGxldFxcbiAgICAgICgoZ3VhcmQ6Z3VhcmQgKGtleXNldC1yZWYtZ3VhcmQga2V5c2V0LXJlZikpKVxcblxcbiAgICAgIChjcmVhdGUtYWNjb3VudCBhY2NvdW50IGd1YXJkKVxcblxcbiAgICAgIChpbnNlcnQgYWxsb2NhdGlvbi10YWJsZSBhY2NvdW50XFxuICAgICAgICB7IFxcXCJiYWxhbmNlXFxcIiA6IGFtb3VudFxcbiAgICAgICAgLCBcXFwiZGF0ZVxcXCIgOiBkYXRlXFxuICAgICAgICAsIFxcXCJndWFyZFxcXCIgOiBndWFyZFxcbiAgICAgICAgLCBcXFwicmVkZWVtZWRcXFwiIDogZmFsc2VcXG4gICAgICAgIH0pKSlcXG5cXG4gIChkZWZ1biByZWxlYXNlLWFsbG9jYXRpb25cXG4gICAgKCBhY2NvdW50OnN0cmluZyApXFxuXFxuICAgIEBkb2MgXFxcIlJlbGVhc2UgZnVuZHMgYXNzb2NpYXRlZCB3aXRoIGFsbG9jYXRpb24gQUNDT1VOVCBpbnRvIG1haW4gbGVkZ2VyLiAgIFxcXFxcXG4gICAgICAgICBcXFxcQUNDT1VOVCBtdXN0IGFscmVhZHkgZXhpc3QgaW4gbWFpbiBsZWRnZXIuIEFsbG9jYXRpb24gaXMgZGVhY3RpdmF0ZWQgXFxcXFxcbiAgICAgICAgIFxcXFxhZnRlciByZWxlYXNlLlxcXCJcXG4gICAgQG1vZGVsIFsgKHByb3BlcnR5ICh2YWxpZC1hY2NvdW50IGFjY291bnQpKSBdXFxuXFxuICAgICh2YWxpZGF0ZS1hY2NvdW50IGFjY291bnQpXFxuXFxuICAgICh3aXRoLXJlYWQgYWxsb2NhdGlvbi10YWJsZSBhY2NvdW50XFxuICAgICAgeyBcXFwiYmFsYW5jZVxcXCIgOj0gYmFsYW5jZVxcbiAgICAgICwgXFxcImRhdGVcXFwiIDo9IHJlbGVhc2UtdGltZVxcbiAgICAgICwgXFxcInJlZGVlbWVkXFxcIiA6PSByZWRlZW1lZFxcbiAgICAgICwgXFxcImd1YXJkXFxcIiA6PSBndWFyZFxcbiAgICAgIH1cXG5cXG4gICAgICAobGV0ICgoY3Vyci10aW1lOnRpbWUgKGF0ICdibG9jay10aW1lIChjaGFpbi1kYXRhKSkpKVxcblxcbiAgICAgICAgKGVuZm9yY2UgKG5vdCByZWRlZW1lZClcXG4gICAgICAgICAgXFxcImFsbG9jYXRpb24gZnVuZHMgaGF2ZSBhbHJlYWR5IGJlZW4gcmVkZWVtZWRcXFwiKVxcblxcbiAgICAgICAgKGVuZm9yY2VcXG4gICAgICAgICAgKD49IGN1cnItdGltZSByZWxlYXNlLXRpbWUpXFxuICAgICAgICAgIChmb3JtYXQgXFxcImZ1bmRzIGxvY2tlZCB1bnRpbCB7fS4gY3VycmVudCB0aW1lOiB7fVxcXCIgW3JlbGVhc2UtdGltZSBjdXJyLXRpbWVdKSlcXG5cXG4gICAgICAgICh3aXRoLWNhcGFiaWxpdHkgKFJFTEVBU0VfQUxMT0NBVElPTiBhY2NvdW50IGJhbGFuY2UpXFxuXFxuICAgICAgICAoZW5mb3JjZS1ndWFyZCBndWFyZClcXG5cXG4gICAgICAgICh3aXRoLWNhcGFiaWxpdHkgKENSRURJVCBhY2NvdW50KVxcbiAgICAgICAgICAoZW1pdC1ldmVudCAoVFJBTlNGRVIgXFxcIlxcXCIgYWNjb3VudCBiYWxhbmNlKSlcXG4gICAgICAgICAgKGNyZWRpdCBhY2NvdW50IGd1YXJkIGJhbGFuY2UpXFxuXFxuICAgICAgICAgICh1cGRhdGUgYWxsb2NhdGlvbi10YWJsZSBhY2NvdW50XFxuICAgICAgICAgICAgeyBcXFwicmVkZWVtZWRcXFwiIDogdHJ1ZVxcbiAgICAgICAgICAgICwgXFxcImJhbGFuY2VcXFwiIDogMC4wXFxuICAgICAgICAgICAgfSlcXG5cXG4gICAgICAgICAgXFxcIkFsbG9jYXRpb24gc3VjY2Vzc2Z1bGx5IHJlbGVhc2VkIHRvIG1haW4gbGVkZ2VyXFxcIikpXFxuICAgICkpKVxcblxcbilcXG5cXG4oY3JlYXRlLXRhYmxlIGNvaW4tdGFibGUpXFxuKGNyZWF0ZS10YWJsZSBhbGxvY2F0aW9uLXRhYmxlKVxcblwifX0sXCJzaWduZXJzXCI6W10sXCJtZXRhXCI6e1wiY3JlYXRpb25UaW1lXCI6MCxcInR0bFwiOjE3MjgwMCxcImdhc0xpbWl0XCI6MCxcImNoYWluSWRcIjpcIlwiLFwiZ2FzUHJpY2VcIjowLFwic2VuZGVyXCI6XCJcIn0sXCJub25jZVwiOlwiY29pbi1jb250cmFjdC12Ni1pbnN0YWxsXCJ9In0", unsafeFromText "eyJnYXMiOjAsInJlc3VsdCI6eyJzdGF0dXMiOiJzdWNjZXNzIiwiZGF0YSI6IlRhYmxlQ3JlYXRlZCJ9LCJyZXFLZXkiOiJHUklRdTRoQUtrMElEOUY4el8tMHlYeUFLSjMzTVB5VFlNWE9qbFBKbXBJIiwibG9ncyI6IlV5bUQ3bm5GUWZTMGF5aUVNT3RuWEdKWDhpbGpYX3JnQzdPbENMdHhZVEEiLCJtZXRhRGF0YSI6bnVsbCwiY29udGludWF0aW9uIjpudWxsLCJ0eElkIjozfQ") - , (unsafeFromText "eyJoYXNoIjoiU0IzVzVFTGl6azl4elNWWk9MX3dsem5VNjh5aUhPQzlwWUhreHBVXzBnbyIsInNpZ3MiOltdLCJjbWQiOiJ7XCJuZXR3b3JrSWRcIjpudWxsLFwicGF5bG9hZFwiOntcImV4ZWNcIjp7XCJkYXRhXCI6bnVsbCxcImNvZGVcIjpcIihpbnRlcmZhY2UgZ2FzLXBheWVyLXYxXFxuXFxuICAoZGVmY2FwIEdBU19QQVlFUjpib29sXFxuICAgICggdXNlcjpzdHJpbmdcXG4gICAgICBsaW1pdDppbnRlZ2VyXFxuICAgICAgcHJpY2U6ZGVjaW1hbFxcbiAgICApXFxuICAgIEBkb2NcXG4gICAgXFxcIiBQcm92aWRlIGEgY2FwYWJpbGl0eSBpbmRpY2F0aW5nIHRoYXQgZGVjbGFyaW5nIG1vZHVsZSBzdXBwb3J0cyBcXFxcXFxuICAgIFxcXFwgZ2FzIHBheW1lbnQgZm9yIFVTRVIgZm9yIGdhcyBMSU1JVCBhbmQgUFJJQ0UuIEZ1bmN0aW9uYWxpdHkgXFxcXFxcbiAgICBcXFxcIHNob3VsZCByZXF1aXJlIGNhcGFiaWxpdHkgKGNvaW4uRlVORF9UWCksIGFuZCBzaG91bGQgdmFsaWRhdGUgXFxcXFxcbiAgICBcXFxcIHRoZSBzcGVuZCBvZiAobGltaXQgKiBwcmljZSksIHBvc3NpYmx5IHVwZGF0aW5nIHNvbWUgZGF0YWJhc2UgXFxcXFxcbiAgICBcXFxcIGVudHJ5LiBcXFxcXFxuICAgIFxcXFwgU2hvdWxkIGNvbXBvc2UgY2FwYWJpbGl0eSByZXF1aXJlZCBmb3IgJ2NyZWF0ZS1nYXMtcGF5ZXItZ3VhcmQnLlxcXCJcXG4gICAgQG1vZGVsXFxuICAgIFsgKHByb3BlcnR5ICh1c2VyICE9IFxcXCJcXFwiKSlcXG4gICAgICAocHJvcGVydHkgKGxpbWl0ID4gMCkpXFxuICAgICAgKHByb3BlcnR5IChwcmljZSA-IDAuMCkpXFxuICAgIF1cXG4gIClcXG5cXG4gIChkZWZ1biBjcmVhdGUtZ2FzLXBheWVyLWd1YXJkOmd1YXJkICgpXFxuICAgIEBkb2NcXG4gICAgXFxcIiBQcm92aWRlIGEgZ3VhcmQgc3VpdGFibGUgZm9yIGNvbnRyb2xsaW5nIGEgY29pbiBhY2NvdW50IHRoYXQgY2FuIFxcXFxcXG4gICAgXFxcXCBwYXkgZ2FzIHZpYSBHQVNfUEFZRVIgbWVjaGFuaWNzLiBHZW5lcmFsbHkgdGhpcyBpcyBhY2NvbXBsaXNoZWQgXFxcXFxcbiAgICBcXFxcIGJ5IGhhdmluZyBHQVNfUEFZRVIgY29tcG9zZSBhbiB1bnBhcmFtZXRlcml6ZWQsIHVubWFuYWdlZCBjYXBhYmlsaXR5IFxcXFxcXG4gICAgXFxcXCB0aGF0IGlzIHJlcXVpcmVkIGluIHRoaXMgZ3VhcmQuIFRodXMsIGlmIGNvaW4gY29udHJhY3QgaXMgYWJsZSB0byBcXFxcXFxuICAgIFxcXFwgc3VjY2Vzc2Z1bGx5IGFjcXVpcmUgR0FTX1BBWUVSLCB0aGUgY29tcG9zZWQgJ2Fub255bW91cycgY2FwIHJlcXVpcmVkIFxcXFxcXG4gICAgXFxcXCBoZXJlIHdpbGwgYmUgaW4gc2NvcGUsIGFuZCBnYXMgYnV5IHdpbGwgc3VjY2VlZC5cXFwiXFxuICApXFxuXFxuKVxcblwifX0sXCJzaWduZXJzXCI6W10sXCJtZXRhXCI6e1wiY3JlYXRpb25UaW1lXCI6MCxcInR0bFwiOjE3MjgwMCxcImdhc0xpbWl0XCI6MCxcImNoYWluSWRcIjpcIlwiLFwiZ2FzUHJpY2VcIjowLFwic2VuZGVyXCI6XCJcIn0sXCJub25jZVwiOlwiZ2VuZXNpcy0wMVwifSJ9", unsafeFromText "eyJnYXMiOjAsInJlc3VsdCI6eyJzdGF0dXMiOiJzdWNjZXNzIiwiZGF0YSI6IkxvYWRlZCBpbnRlcmZhY2UgZ2FzLXBheWVyLXYxIn0sInJlcUtleSI6IlNCM1c1RUxpems5eHpTVlpPTF93bHpuVTY4eWlIT0M5cFlIa3hwVV8wZ28iLCJsb2dzIjoiZlZuSFlta19QNmJSY3VjeVg1RDdLamNLYkVsVDlEcU9vZW9yUFEtUXdsMCIsIm1ldGFEYXRhIjpudWxsLCJjb250aW51YXRpb24iOm51bGwsInR4SWQiOjR9") - , (unsafeFromText "eyJoYXNoIjoiQ1pteWxXZmllUk1CTXU1dzJFT21wRndLLXQ3YmNPVHM0bUsyYVQzM3VSNCIsInNpZ3MiOltdLCJjbWQiOiJ7XCJuZXR3b3JrSWRcIjpudWxsLFwicGF5bG9hZFwiOntcImV4ZWNcIjp7XCJkYXRhXCI6e1wibnMtYWRtaW4ta2V5c2V0XCI6W1wiMzY4ODIwZjgwYzMyNGJiYzdjMmIwNjEwNjg4YTdkYTQzZTM5ZjkxZDExODczMjY3MWNkOWM3NTAwZmY0M2NjYVwiXSxcIm5zLW9wZXJhdGUta2V5c2V0XCI6W1wiMzY4ODIwZjgwYzMyNGJiYzdjMmIwNjEwNjg4YTdkYTQzZTM5ZjkxZDExODczMjY3MWNkOWM3NTAwZmY0M2NjYVwiXSxcIm5zLWdlbmVzaXMta2V5c2V0XCI6e1wicHJlZFwiOlwiPVwiLFwia2V5c1wiOltdfX0sXCJjb2RlXCI6XCIoZGVmaW5lLWtleXNldCAnbnMtYWRtaW4ta2V5c2V0IChyZWFkLWtleXNldCAnbnMtYWRtaW4ta2V5c2V0KSlcXG4oZGVmaW5lLWtleXNldCAnbnMtb3BlcmF0ZS1rZXlzZXQgKHJlYWQta2V5c2V0ICducy1nZW5lc2lzLWtleXNldCkpXFxuXFxuKG1vZHVsZSBucyBHT1ZFUk5BTkNFXFxuICBcXFwiQWRtaW5pc3RlcnMgZGVmaW5pdGlvbiBvZiBuZXcgbmFtZXNwYWNlcyBpbiBDaGFpbndlYi5cXFwiXFxuXFxuICAoZGVmc2NoZW1hIHJlZy1lbnRyeVxcbiAgICBhZG1pbi1ndWFyZDpndWFyZFxcbiAgICBhY3RpdmU6Ym9vbClcXG5cXG4gIChkZWZ0YWJsZSByZWdpc3RyeTp7cmVnLWVudHJ5fSlcXG5cXG4gIChkZWZjYXAgR09WRVJOQU5DRSAoKVxcbiAgICAoZW5mb3JjZS1rZXlzZXQgJ25zLWFkbWluLWtleXNldCkpXFxuXFxuICAoZGVmY2FwIE9QRVJBVEUgKClcXG4gICAgKGVuZm9yY2Uta2V5c2V0ICducy1vcGVyYXRlLWtleXNldCkpXFxuXFxuICAoZGVmY29uc3QgR1VBUkRfU1VDQ0VTUyAoY3JlYXRlLXVzZXItZ3VhcmQgKHN1Y2Nlc3MpKSlcXG4gIChkZWZjb25zdCBHVUFSRF9GQUlMVVJFIChjcmVhdGUtdXNlci1ndWFyZCAoZmFpbHVyZSkpKVxcblxcbiAgKGRlZnVuIHN1Y2Nlc3MgKClcXG4gICAgdHJ1ZSlcXG4gIChkZWZ1biBmYWlsdXJlICgpXFxuICAgIChlbmZvcmNlIGZhbHNlIFxcXCJEaXNhYmxlZFxcXCIpKVxcblxcbiAgKGRlZnVuIHZhbGlkYXRlLW5hbWUgKG5hbWUpXFxuICAgIChlbmZvcmNlICghPSBcXFwiXFxcIiBuYW1lKSBcXFwiRW1wdHkgbmFtZSBub3QgYWxsb3dlZFxcXCIpXFxuICAgIChlbmZvcmNlICg8IChsZW5ndGggbmFtZSkgNjQpIFxcXCJOYW1lIG11c3QgYmUgbGVzcyB0aGFuIDY0IGNoYXJhY3RlcnMgbG9uZ1xcXCIpXFxuICAgIChlbmZvcmNlIChpcy1jaGFyc2V0IENIQVJTRVRfTEFUSU4xIG5hbWUpXFxuICAgICAgICAgICAgIFxcXCJOYW1lIG11c3QgYmUgaW4gbGF0aW4xIGNoYXJzZXRcXFwiKSlcXG5cXG4gIChkZWZ1biBjcmVhdGUtcHJpbmNpcGFsLW5hbWVzcGFjZTpzdHJpbmdcXG4gICAgICAoIGc6Z3VhcmRcXG4gICAgICAgIClcXG4gICAgXFxcIiBGb3JtYXQgcHJpbmNpcGFsIG5hbWVzcGFjZSBhcyBQYWN0IGhhc2ggKEJMQUtFMmIyNTYpIG9mIHByaW5jaXBhbCBcXFxcXFxuICAgIFxcXFwgaW4gaGV4IHRydW5jYXRlZCB0byAxNjAgYml0cyAoNDAgY2hhcmFjdGVycyksIHByZXBlbmRlZCB3aXRoICduXycuXFxcXFxcbiAgICBcXFxcIE9ubHkgdzogYW5kIGs6IGFjY291bnQgcHJvdG9jb2xzIGFyZSBzdXBwb3J0ZWQuIFxcXCJcXG5cXG4gICAgKGxldFxcbiAgICAgICgodHkgKHR5cGVvZi1wcmluY2lwYWwgKGNyZWF0ZS1wcmluY2lwYWwgZykpKSlcXG5cXG4gICAgICA7OyBvbmx5IHc6IGFuZCBrOiBjdXJyZW50bHkgc3VwcG9ydGVkXFxuICAgICAgKGlmIChvciAoPSB0eSBcXFwiazpcXFwiKSAoPSB0eSBcXFwidzpcXFwiKSlcXG4gICAgICAgICgrIFxcXCJuX1xcXCIgKHRha2UgNDAgKGludC10by1zdHIgMTYgKHN0ci10by1pbnQgNjQgKGhhc2ggZykpKSkpXFxuICAgICAgICAoZW5mb3JjZSBmYWxzZVxcbiAgICAgICAgICAoZm9ybWF0IFxcXCJVbnN1cHBvcnRlZCBndWFyZCBwcm90b2NvbDoge31cXFwiIFt0eV0pKVxcbiAgICAgICAgKSlcXG4gIClcXG5cXG4gIChkZWZ1biB2YWxpZGF0ZTpib29sXFxuICAgICAgKCBucy1uYW1lOnN0cmluZ1xcbiAgICAgICAgbnMtYWRtaW46Z3VhcmRcXG4gICAgICAgIClcXG4gICAgXFxcIiBNYW5hZ2VzIG5hbWVzcGFjZSBpbnN0YWxsIGZvciBDaGFpbndlYi4gXFxcXFxcbiAgICBcXFxcIEFsbG93cyBwcmluY2lwYWwgbmFtZXNwYWNlcy4gXFxcXFxcbiAgICBcXFxcIE5vbi1wcmluY2lwYWwgbmFtZXNwYWNlcyByZXF1aXJlIGFjdGl2ZSByb3cgaW4gcmVnaXN0cnkgXFxcXFxcbiAgICBcXFxcIGZvciBOUy1OQU1FIHdpdGggZ3VhcmQgbWF0Y2hpbmcgTlMtQURNSU4uXFxcIlxcblxcbiAgICAoaWYgKD0gKGNyZWF0ZS1wcmluY2lwYWwtbmFtZXNwYWNlIG5zLWFkbWluKSBucy1uYW1lKVxcblxcbiAgICAgIHRydWUgOzsgYWxsb3cgcHJpbmNpcGFsIG5hbWVzcGFjZXNcXG5cXG4gICAgICAod2l0aC1kZWZhdWx0LXJlYWQgcmVnaXN0cnkgbnMtbmFtZSAgICAgICA7OyBvdGhlcndpc2UgZW5mb3JjZSByZWdpc3RyeVxcbiAgICAgICAgeyAnYWRtaW4tZ3VhcmQgOiBucy1hZG1pblxcbiAgICAgICAgLCAnYWN0aXZlIDogZmFsc2UgfVxcbiAgICAgICAgeyAnYWRtaW4tZ3VhcmQgOj0gYWdcXG4gICAgICAgICwgJ2FjdGl2ZSA6PSBpcy1hY3RpdmUgfVxcblxcbiAgICAgICAgKGVuZm9yY2UgaXMtYWN0aXZlIFxcXCJJbmFjdGl2ZSBvciB1bnJlZ2lzdGVyZWQgbmFtZXNwYWNlXFxcIilcXG4gICAgICAgIChlbmZvcmNlICg9IG5zLWFkbWluIGFnKSBcXFwiQWRtaW4gZ3VhcmQgbXVzdCBtYXRjaCBndWFyZCBpbiByZWdpc3RyeVxcXCIpXFxuXFxuICAgICAgICB0cnVlKVxcbiAgICAgICkpXFxuXFxuICAoZGVmdW4gd3JpdGUtcmVnaXN0cnk6c3RyaW5nXFxuICAgICAgKCBucy1uYW1lOnN0cmluZ1xcbiAgICAgICAgZ3VhcmQ6Z3VhcmRcXG4gICAgICAgIGFjdGl2ZTpib29sXFxuICAgICAgICApXFxuICAgIFxcXCIgV3JpdGUgZW50cnkgd2l0aCBHVUFSRCBhbmQgQUNUSVZFIGludG8gcmVnaXN0cnkgZm9yIE5BTUUuIFxcXFxcXG4gICAgXFxcXCBHdWFyZGVkIGJ5IG9wZXJhdGUga2V5c2V0LiBcXFwiXFxuXFxuICAgICh3aXRoLWNhcGFiaWxpdHkgKE9QRVJBVEUpXFxuXFxuICAgICAgKHZhbGlkYXRlLW5hbWUgbnMtbmFtZSlcXG5cXG4gICAgICAod3JpdGUgcmVnaXN0cnkgbnMtbmFtZVxcbiAgICAgICAgeyAnYWRtaW4tZ3VhcmQ6IGd1YXJkXFxuICAgICAgICAsICdhY3RpdmU6IGFjdGl2ZSB9KVxcblxcbiAgICAgIFxcXCJSZWdpc3RlciBlbnRyeSB3cml0dGVuXFxcIikpXFxuXFxuICAoZGVmdW4gcXVlcnk6b2JqZWN0e3JlZy1lbnRyeX1cXG4gICAgICAoIG5zLW5hbWU6c3RyaW5nIClcXG4gICAgKHJlYWQgcmVnaXN0cnkgbnMtbmFtZSkpXFxuXFxuKVxcblxcbihjcmVhdGUtdGFibGUgcmVnaXN0cnkpXFxuXFxuKHdyaXRlLXJlZ2lzdHJ5IFxcXCJrYWRlbmFcXFwiXFxuICAoa2V5c2V0LXJlZi1ndWFyZCAnbnMtb3BlcmF0ZS1rZXlzZXQpIHRydWUpXFxuKHdyaXRlLXJlZ2lzdHJ5IFxcXCJ1c2VyXFxcIiBHVUFSRF9GQUlMVVJFIHRydWUpXFxuKHdyaXRlLXJlZ2lzdHJ5IFxcXCJmcmVlXFxcIiBHVUFSRF9GQUlMVVJFIHRydWUpXFxuXFxuKGRlZmluZS1uYW1lc3BhY2UgXFxcImthZGVuYVxcXCJcXG4gIChrZXlzZXQtcmVmLWd1YXJkICducy1vcGVyYXRlLWtleXNldClcXG4gIChrZXlzZXQtcmVmLWd1YXJkICducy1vcGVyYXRlLWtleXNldCkpXFxuXFxuKGRlZmluZS1uYW1lc3BhY2UgXFxcInVzZXJcXFwiIEdVQVJEX1NVQ0NFU1MgR1VBUkRfRkFJTFVSRSlcXG4oZGVmaW5lLW5hbWVzcGFjZSBcXFwiZnJlZVxcXCIgR1VBUkRfU1VDQ0VTUyBHVUFSRF9GQUlMVVJFKVxcbjs7cm90YXRlIHRvIHJlYWwgb3BlcmF0ZSBrZXlzZXRcXG4oZGVmaW5lLWtleXNldCAnbnMtb3BlcmF0ZS1rZXlzZXQgKHJlYWQta2V5c2V0ICducy1vcGVyYXRlLWtleXNldCkpXFxuXCJ9fSxcInNpZ25lcnNcIjpbXSxcIm1ldGFcIjp7XCJjcmVhdGlvblRpbWVcIjowLFwidHRsXCI6MTcyODAwLFwiZ2FzTGltaXRcIjowLFwiY2hhaW5JZFwiOlwiXCIsXCJnYXNQcmljZVwiOjAsXCJzZW5kZXJcIjpcIlwifSxcIm5vbmNlXCI6XCJsb2FkLW5zLWRldm5ldC1zZW5kZXIwMFwifSJ9", unsafeFromText "eyJnYXMiOjAsInJlc3VsdCI6eyJzdGF0dXMiOiJzdWNjZXNzIiwiZGF0YSI6IktleXNldCBkZWZpbmVkIn0sInJlcUtleSI6IkNabXlsV2ZpZVJNQk11NXcyRU9tcEZ3Sy10N2JjT1RzNG1LMmFUMzN1UjQiLCJsb2dzIjoiNHlRZEx6VWU5QUttdko3cnhEdkJtUnVIZjVic0lvSjNBMjZCaGdicl9NOCIsIm1ldGFEYXRhIjpudWxsLCJjb250aW51YXRpb24iOm51bGwsInR4SWQiOjV9") - , (unsafeFromText "eyJoYXNoIjoiWE5BNmxPSjFXLTdYWXY1WWI0QXFsNzRveFlJN09KcWpPUVQ1b1k0OHEtZyIsInNpZ3MiOltdLCJjbWQiOiJ7XCJuZXR3b3JrSWRcIjpudWxsLFwicGF5bG9hZFwiOntcImV4ZWNcIjp7XCJkYXRhXCI6e1wiYWxsb2NhdGlvbi10ZXN0MDFcIjpbXCI3MDExYzM3OTE0MGZmODk5ZjdlNjEzYWMwYTk3ODRhN2MwYTUxNWQzMGZlMGFiMmIwYzA3ZTVhYTE3NjM1ZTNlXCJdLFwiYWxsb2NhdGlvbjAyXCI6W1wiZTllNGU3MWJkMDYzZGNmN2UwNmJkNWIxYTE2Njg4ODk3ZDE1Y2E4YmQyZTUwOWM0NTNjNjE2MjE5YzE4NmNjNVwiXSxcImFsbG9jYXRpb24wMFwiOltcImQ4MmQwZGNkZTk4MjU1MDVkODZhZmI2ZGNjMTA0MTFkNmI2N2E0MjlhNzllMjFiZGE0YmIxMTliZjI4YWI4NzFcIl0sXCJhbGxvY2F0aW9uLXRlc3QwMlwiOltcIjA2NTQ0ZTIyYmZlZjIzMGQ2ZDIyZjk0ODZhYzZjYjc2YmYyNThlYmZiZjAxMzdlZTU4ZjY1NzQzZTFhNWI4YzRcIl0sXCJhbGxvY2F0aW9uMDFcIjpbXCJiNGM4YTNlYTkxZDMxNDZiMDU2MDk5NDc0MGYwZTNlZWQ5MWM1OWQyZWVjYTFkYzk5ZjBjMjg3Mjg0NWMyOTRkXCJdfSxcImNvZGVcIjpcIihkZWZpbmUta2V5c2V0IFxcXCJhbGxvY2F0aW9uMDBcXFwiIChyZWFkLWtleXNldCBcXFwiYWxsb2NhdGlvbjAwXFxcIikpXFxuKGRlZmluZS1rZXlzZXQgXFxcImFsbG9jYXRpb24wMVxcXCIgKHJlYWQta2V5c2V0IFxcXCJhbGxvY2F0aW9uMDFcXFwiKSlcXG4oZGVmaW5lLWtleXNldCBcXFwiYWxsb2NhdGlvbjAyXFxcIiAocmVhZC1rZXlzZXQgXFxcImFsbG9jYXRpb24wMlxcXCIpKVxcbihkZWZpbmUta2V5c2V0IFxcXCJhbGxvY2F0aW9uLXRlc3QwMVxcXCIgKHJlYWQta2V5c2V0IFxcXCJhbGxvY2F0aW9uLXRlc3QwMVxcXCIpKVxcbihkZWZpbmUta2V5c2V0IFxcXCJhbGxvY2F0aW9uLXRlc3QwMlxcXCIgKHJlYWQta2V5c2V0IFxcXCJhbGxvY2F0aW9uLXRlc3QwMlxcXCIpKVwifX0sXCJzaWduZXJzXCI6W10sXCJtZXRhXCI6e1wiY3JlYXRpb25UaW1lXCI6MCxcInR0bFwiOjE3MjgwMCxcImdhc0xpbWl0XCI6MCxcImNoYWluSWRcIjpcIlwiLFwiZ2FzUHJpY2VcIjowLFwic2VuZGVyXCI6XCJcIn0sXCJub25jZVwiOlwiZGV2bmV0LWtleXNldHNcIn0ifQ", unsafeFromText "eyJnYXMiOjAsInJlc3VsdCI6eyJzdGF0dXMiOiJzdWNjZXNzIiwiZGF0YSI6IktleXNldCBkZWZpbmVkIn0sInJlcUtleSI6IlhOQTZsT0oxVy03WFl2NVliNEFxbDc0b3hZSTdPSnFqT1FUNW9ZNDhxLWciLCJsb2dzIjoiU0t3RUk1NWN4M2pMdU16RWRZQ1NtZ1RSRWhmVjg2alQwVjd3WVdvZWxfQSIsIm1ldGFEYXRhIjpudWxsLCJjb250aW51YXRpb24iOm51bGwsInR4SWQiOjZ9") - , (unsafeFromText "eyJoYXNoIjoiNWtxZ0tzWWtwbjZCcS1KUnhNYnA1VG9jUWhRWGRJVVNiM1NGQm1Ba3VWcyIsInNpZ3MiOltdLCJjbWQiOiJ7XCJuZXR3b3JrSWRcIjpudWxsLFwicGF5bG9hZFwiOntcImV4ZWNcIjp7XCJkYXRhXCI6bnVsbCxcImNvZGVcIjpcIihjb2luLmNyZWF0ZS1hbGxvY2F0aW9uLWFjY291bnQgXFxcImFsbG9jYXRpb24wMFxcXCIgKHRpbWUgXFxcIjE5MDAtMTAtMTVUMTg6MDA6MDBaXFxcIikgXFxcImFsbG9jYXRpb24wMFxcXCIgMTAwMDAwMC4wKVxcbihjb2luLmNyZWF0ZS1hbGxvY2F0aW9uLWFjY291bnQgXFxcImFsbG9jYXRpb24wMVxcXCIgKHRpbWUgXFxcIjIxMDAtMTAtMzFUMTg6MDA6MDBaXFxcIikgXFxcImFsbG9jYXRpb24wMVxcXCIgMTAwMDAwMC4wKVxcbihjb2luLmNyZWF0ZS1hbGxvY2F0aW9uLWFjY291bnQgXFxcImFsbG9jYXRpb24wMlxcXCIgKHRpbWUgXFxcIjE5MDAtMTAtMzFUMTg6MDA6MDBaXFxcIikgXFxcImFsbG9jYXRpb24wMlxcXCIgMTAwMDAwMC4wKVxcbihjb2luLmNyZWF0ZS1hbGxvY2F0aW9uLWFjY291bnQgXFxcImFsbG9jYXRpb24tdGVzdDAxXFxcIiAodGltZSBcXFwiMTkwMC0xMC0zMVQxODowMDowMFpcXFwiKSBcXFwiYWxsb2NhdGlvbi10ZXN0MDFcXFwiIDEwMDAwMDAuMClcXG4oY29pbi5jcmVhdGUtYWxsb2NhdGlvbi1hY2NvdW50IFxcXCJhbGxvY2F0aW9uLXRlc3QwMlxcXCIgKHRpbWUgXFxcIjE5MDAtMTAtMzFUMTg6MDA6MDBaXFxcIikgXFxcImFsbG9jYXRpb24tdGVzdDAyXFxcIiAyMDAwMDAwLjApXCJ9fSxcInNpZ25lcnNcIjpbXSxcIm1ldGFcIjp7XCJjcmVhdGlvblRpbWVcIjowLFwidHRsXCI6MTcyODAwLFwiZ2FzTGltaXRcIjowLFwiY2hhaW5JZFwiOlwiXCIsXCJnYXNQcmljZVwiOjAsXCJzZW5kZXJcIjpcIlwifSxcIm5vbmNlXCI6XCJkZXZuZXQtYWxsb2NhdGlvbnNcIn0ifQ", unsafeFromText "eyJnYXMiOjAsInJlc3VsdCI6eyJzdGF0dXMiOiJzdWNjZXNzIiwiZGF0YSI6IldyaXRlIHN1Y2NlZWRlZCJ9LCJyZXFLZXkiOiI1a3FnS3NZa3BuNkJxLUpSeE1icDVUb2NRaFFYZElVU2IzU0ZCbUFrdVZzIiwibG9ncyI6IkRTeVFBWXBXSW9OazlOSUFNaTgzODRBTDhnSU9LRzc2Y1FaMzZNaGtkOGciLCJtZXRhRGF0YSI6bnVsbCwiY29udGludWF0aW9uIjpudWxsLCJ0eElkIjo3fQ") - , (unsafeFromText "eyJoYXNoIjoiZjIxVTFJRnlRN0ZfLTRlTnR6QTFuWnZjQ0g5cnY5ZnZsNWM1a0RyNXFsdyIsInNpZ3MiOltdLCJjbWQiOiJ7XCJuZXR3b3JrSWRcIjpudWxsLFwicGF5bG9hZFwiOntcImV4ZWNcIjp7XCJkYXRhXCI6e1wic2VuZGVyMDdcIjpbXCI0YzMxZGM5ZWU3ZjI0MTc3Zjc4YjZmNTE4MDEyYTIwODMyNmUyYWYxZjM3YmIwYTI0MDViNTA1NmQwY2FkNjI4XCJdLFwic2VuZGVyMDFcIjpbXCI2YmUyZjQ4NWE3YWY3NWZlZGI0YjdmMTUzYTkwM2Y3ZTYwMDBjYTRhYTUwMTE3OWM5MWEyNDUwYjc3N2JkMmE3XCJdLFwic2VuZGVyMDZcIjpbXCI1ZmZjMWY3ZmVmN2E0NDczODYyNTc2MmY3NWE0MjI5NDU0OTUxZTAzZjJhZmM2ZjgxMzA5YzBjMWJkZjllZTZmXCJdLFwic2VuZGVyMDBcIjpbXCIzNjg4MjBmODBjMzI0YmJjN2MyYjA2MTA2ODhhN2RhNDNlMzlmOTFkMTE4NzMyNjcxY2Q5Yzc1MDBmZjQzY2NhXCJdLFwiZTdmN1wiOltcImU3Zjc2MzRlOTI1NTQxZjM2OGI4MjdhZDVjNzI0MjE5MDUxMDBmNjIwNTI4NWE3OGMxOWQ3YjRhMzg3MTE4MDVcIl0sXCJzZW5kZXIwNVwiOltcImYwOWQ4ZjYzOTRhZWE0MjVmZTY3ODNkODhjZDgxMzYzZDgwMTdmMTZhZmQzNzExYzU3NWJlMGY1Y2Q1YzliYjlcIl0sXCJzZW5kZXIwNFwiOltcIjJkNzBhYTRmNjk3YzNhM2I4ZGQ2ZDk3NzQ1YWMwNzRlZGNmZDBlYjY1YzM3Nzc0Y2RlMjUxMzU0ODNiZWE3MWVcIl0sXCJtdWx0aS0wMi0wMy0wNC1hbnlcIjp7XCJwcmVkXCI6XCJrZXlzLWFueVwiLFwia2V5c1wiOltcIjNhOWRkNTMyZDczZGFjZTE5NWRiYjY0ZDFkYmE2NTcyZmI3ODNkMGZkZDMyNDY4NWUzMmZiZGEyZjg5Zjk5YTZcIixcIjQzZjJhZGIxZGUxOTIwMDBjYjM3NzdiYWNjN2Y5ODNiNjYxNGZkOWMxNzE1Y2Q0NGNkNDg0YjZkM2EwZDM0YzhcIixcIjJkNzBhYTRmNjk3YzNhM2I4ZGQ2ZDk3NzQ1YWMwNzRlZGNmZDBlYjY1YzM3Nzc0Y2RlMjUxMzU0ODNiZWE3MWVcIl19LFwic2VuZGVyMDlcIjpbXCJjNTlkOTg0MGIwYjY2MDkwODM2NTQ2YjdlYjRhNzM2MDYyNTc1MjdlYzhjMmI0ODIzMDBmZDIyOTI2NGIwN2U2XCJdLFwic2VuZGVyMDNcIjpbXCI0M2YyYWRiMWRlMTkyMDAwY2IzNzc3YmFjYzdmOTgzYjY2MTRmZDljMTcxNWNkNDRjZDQ4NGI2ZDNhMGQzNGM4XCJdLFwibXVsdGktMDAtMDFcIjpbXCIzNjg4MjBmODBjMzI0YmJjN2MyYjA2MTA2ODhhN2RhNDNlMzlmOTFkMTE4NzMyNjcxY2Q5Yzc1MDBmZjQzY2NhXCIsXCI2YmUyZjQ4NWE3YWY3NWZlZGI0YjdmMTUzYTkwM2Y3ZTYwMDBjYTRhYTUwMTE3OWM5MWEyNDUwYjc3N2JkMmE3XCJdLFwic2VuZGVyMDhcIjpbXCI2M2IyZWJhNGVkNzBkNDYxMmQzZTdiYzkwZGIyZmJmNGM3NmY3YjA3NDM2M2U4NmQ3M2YwYmM2MTdmOGU4YjgxXCJdLFwic2VuZGVyMDJcIjpbXCIzYTlkZDUzMmQ3M2RhY2UxOTVkYmI2NGQxZGJhNjU3MmZiNzgzZDBmZGQzMjQ2ODVlMzJmYmRhMmY4OWY5OWE2XCJdfSxcImNvZGVcIjpcIihjb2luLmNvaW5iYXNlIFxcXCJzZW5kZXIwMFxcXCIgKHJlYWQta2V5c2V0IFxcXCJzZW5kZXIwMFxcXCIpIDEwMDAwMDAwMC4wKVxcbihjb2luLmNvaW5iYXNlIFxcXCJzZW5kZXIwMVxcXCIgKHJlYWQta2V5c2V0IFxcXCJzZW5kZXIwMVxcXCIpIDExMDAwMDAwMC4wKVxcbihjb2luLmNvaW5iYXNlIFxcXCJzZW5kZXIwMlxcXCIgKHJlYWQta2V5c2V0IFxcXCJzZW5kZXIwMlxcXCIpIDEyMDAwMDAwMC4wKVxcbihjb2luLmNvaW5iYXNlIFxcXCJzZW5kZXIwM1xcXCIgKHJlYWQta2V5c2V0IFxcXCJzZW5kZXIwM1xcXCIpIDEzMDAwMDAwMC4wKVxcbihjb2luLmNvaW5iYXNlIFxcXCJzZW5kZXIwNFxcXCIgKHJlYWQta2V5c2V0IFxcXCJzZW5kZXIwNFxcXCIpIDE0MDAwMDAwMC4wKVxcbihjb2luLmNvaW5iYXNlIFxcXCJzZW5kZXIwNVxcXCIgKHJlYWQta2V5c2V0IFxcXCJzZW5kZXIwNVxcXCIpIDE1MDAwMDAwMC4wKVxcbihjb2luLmNvaW5iYXNlIFxcXCJzZW5kZXIwNlxcXCIgKHJlYWQta2V5c2V0IFxcXCJzZW5kZXIwNlxcXCIpIDE2MDAwMDAwMC4wKVxcbihjb2luLmNvaW5iYXNlIFxcXCJzZW5kZXIwN1xcXCIgKHJlYWQta2V5c2V0IFxcXCJzZW5kZXIwN1xcXCIpIDE3MDAwMDAwMC4wKVxcbihjb2luLmNvaW5iYXNlIFxcXCJzZW5kZXIwOFxcXCIgKHJlYWQta2V5c2V0IFxcXCJzZW5kZXIwOFxcXCIpIDE4MDAwMDAwMC4wKVxcbihjb2luLmNvaW5iYXNlIFxcXCJzZW5kZXIwOVxcXCIgKHJlYWQta2V5c2V0IFxcXCJzZW5kZXIwOVxcXCIpIDE5MDAwMDAwMC4wKVxcbihjb2luLmNvaW5iYXNlIFxcXCJtdWx0aS0wMC0wMVxcXCIgKHJlYWQta2V5c2V0IFxcXCJtdWx0aS0wMC0wMVxcXCIpIDEwMTAwMDAwMC4wKVxcbihjb2luLmNvaW5iYXNlIFxcXCJtdWx0aS0wMi0wMy0wNC1hbnlcXFwiIChyZWFkLWtleXNldCBcXFwibXVsdGktMDItMDMtMDQtYW55XFxcIikgMTIzNDAwMDAwLjApXFxuXFxuKGNvaW4uY29pbmJhc2UgXFxcImU3Zjc2MzRlOTI1NTQxZjM2OGI4MjdhZDVjNzI0MjE5MDUxMDBmNjIwNTI4NWE3OGMxOWQ3YjRhMzg3MTE4MDVcXFwiIChyZWFkLWtleXNldCBcXFwiZTdmN1xcXCIpIDE1MC4wKVwifX0sXCJzaWduZXJzXCI6W10sXCJtZXRhXCI6e1wiY3JlYXRpb25UaW1lXCI6MCxcInR0bFwiOjE3MjgwMCxcImdhc0xpbWl0XCI6MCxcImNoYWluSWRcIjpcIlwiLFwiZ2FzUHJpY2VcIjowLFwic2VuZGVyXCI6XCJcIn0sXCJub25jZVwiOlwiZGV2bmV0LWdyYW50c05cIn0ifQ", unsafeFromText "eyJnYXMiOjAsInJlc3VsdCI6eyJzdGF0dXMiOiJzdWNjZXNzIiwiZGF0YSI6IldyaXRlIHN1Y2NlZWRlZCJ9LCJyZXFLZXkiOiJmMjFVMUlGeVE3Rl8tNGVOdHpBMW5admNDSDlydjlmdmw1YzVrRHI1cWx3IiwibG9ncyI6Iks5dDlKdFBZc1hGQ0dhNk5TTEI2V2xJdTFZaEJqWG94bTFPZkY2Y0xFd00iLCJldmVudHMiOlt7InBhcmFtcyI6WyIiLCJzZW5kZXIwMCIsMTAwMDAwMDAwXSwibmFtZSI6IlRSQU5TRkVSIiwibW9kdWxlIjp7Im5hbWVzcGFjZSI6bnVsbCwibmFtZSI6ImNvaW4ifSwibW9kdWxlSGFzaCI6IndPVGpOQzNndE9BanFnQ1k4UzloUS1MQml3Y1BVRTdqNGlCREUwVG1kSm8ifSx7InBhcmFtcyI6WyIiLCJzZW5kZXIwMSIsMTEwMDAwMDAwXSwibmFtZSI6IlRSQU5TRkVSIiwibW9kdWxlIjp7Im5hbWVzcGFjZSI6bnVsbCwibmFtZSI6ImNvaW4ifSwibW9kdWxlSGFzaCI6IndPVGpOQzNndE9BanFnQ1k4UzloUS1MQml3Y1BVRTdqNGlCREUwVG1kSm8ifSx7InBhcmFtcyI6WyIiLCJzZW5kZXIwMiIsMTIwMDAwMDAwXSwibmFtZSI6IlRSQU5TRkVSIiwibW9kdWxlIjp7Im5hbWVzcGFjZSI6bnVsbCwibmFtZSI6ImNvaW4ifSwibW9kdWxlSGFzaCI6IndPVGpOQzNndE9BanFnQ1k4UzloUS1MQml3Y1BVRTdqNGlCREUwVG1kSm8ifSx7InBhcmFtcyI6WyIiLCJzZW5kZXIwMyIsMTMwMDAwMDAwXSwibmFtZSI6IlRSQU5TRkVSIiwibW9kdWxlIjp7Im5hbWVzcGFjZSI6bnVsbCwibmFtZSI6ImNvaW4ifSwibW9kdWxlSGFzaCI6IndPVGpOQzNndE9BanFnQ1k4UzloUS1MQml3Y1BVRTdqNGlCREUwVG1kSm8ifSx7InBhcmFtcyI6WyIiLCJzZW5kZXIwNCIsMTQwMDAwMDAwXSwibmFtZSI6IlRSQU5TRkVSIiwibW9kdWxlIjp7Im5hbWVzcGFjZSI6bnVsbCwibmFtZSI6ImNvaW4ifSwibW9kdWxlSGFzaCI6IndPVGpOQzNndE9BanFnQ1k4UzloUS1MQml3Y1BVRTdqNGlCREUwVG1kSm8ifSx7InBhcmFtcyI6WyIiLCJzZW5kZXIwNSIsMTUwMDAwMDAwXSwibmFtZSI6IlRSQU5TRkVSIiwibW9kdWxlIjp7Im5hbWVzcGFjZSI6bnVsbCwibmFtZSI6ImNvaW4ifSwibW9kdWxlSGFzaCI6IndPVGpOQzNndE9BanFnQ1k4UzloUS1MQml3Y1BVRTdqNGlCREUwVG1kSm8ifSx7InBhcmFtcyI6WyIiLCJzZW5kZXIwNiIsMTYwMDAwMDAwXSwibmFtZSI6IlRSQU5TRkVSIiwibW9kdWxlIjp7Im5hbWVzcGFjZSI6bnVsbCwibmFtZSI6ImNvaW4ifSwibW9kdWxlSGFzaCI6IndPVGpOQzNndE9BanFnQ1k4UzloUS1MQml3Y1BVRTdqNGlCREUwVG1kSm8ifSx7InBhcmFtcyI6WyIiLCJzZW5kZXIwNyIsMTcwMDAwMDAwXSwibmFtZSI6IlRSQU5TRkVSIiwibW9kdWxlIjp7Im5hbWVzcGFjZSI6bnVsbCwibmFtZSI6ImNvaW4ifSwibW9kdWxlSGFzaCI6IndPVGpOQzNndE9BanFnQ1k4UzloUS1MQml3Y1BVRTdqNGlCREUwVG1kSm8ifSx7InBhcmFtcyI6WyIiLCJzZW5kZXIwOCIsMTgwMDAwMDAwXSwibmFtZSI6IlRSQU5TRkVSIiwibW9kdWxlIjp7Im5hbWVzcGFjZSI6bnVsbCwibmFtZSI6ImNvaW4ifSwibW9kdWxlSGFzaCI6IndPVGpOQzNndE9BanFnQ1k4UzloUS1MQml3Y1BVRTdqNGlCREUwVG1kSm8ifSx7InBhcmFtcyI6WyIiLCJzZW5kZXIwOSIsMTkwMDAwMDAwXSwibmFtZSI6IlRSQU5TRkVSIiwibW9kdWxlIjp7Im5hbWVzcGFjZSI6bnVsbCwibmFtZSI6ImNvaW4ifSwibW9kdWxlSGFzaCI6IndPVGpOQzNndE9BanFnQ1k4UzloUS1MQml3Y1BVRTdqNGlCREUwVG1kSm8ifSx7InBhcmFtcyI6WyIiLCJtdWx0aS0wMC0wMSIsMTAxMDAwMDAwXSwibmFtZSI6IlRSQU5TRkVSIiwibW9kdWxlIjp7Im5hbWVzcGFjZSI6bnVsbCwibmFtZSI6ImNvaW4ifSwibW9kdWxlSGFzaCI6IndPVGpOQzNndE9BanFnQ1k4UzloUS1MQml3Y1BVRTdqNGlCREUwVG1kSm8ifSx7InBhcmFtcyI6WyIiLCJtdWx0aS0wMi0wMy0wNC1hbnkiLDEyMzQwMDAwMF0sIm5hbWUiOiJUUkFOU0ZFUiIsIm1vZHVsZSI6eyJuYW1lc3BhY2UiOm51bGwsIm5hbWUiOiJjb2luIn0sIm1vZHVsZUhhc2giOiJ3T1RqTkMzZ3RPQWpxZ0NZOFM5aFEtTEJpd2NQVUU3ajRpQkRFMFRtZEpvIn0seyJwYXJhbXMiOlsiIiwiZTdmNzYzNGU5MjU1NDFmMzY4YjgyN2FkNWM3MjQyMTkwNTEwMGY2MjA1Mjg1YTc4YzE5ZDdiNGEzODcxMTgwNSIsMTUwXSwibmFtZSI6IlRSQU5TRkVSIiwibW9kdWxlIjp7Im5hbWVzcGFjZSI6bnVsbCwibmFtZSI6ImNvaW4ifSwibW9kdWxlSGFzaCI6IndPVGpOQzNndE9BanFnQ1k4UzloUS1MQml3Y1BVRTdqNGlCREUwVG1kSm8ifV0sIm1ldGFEYXRhIjpudWxsLCJjb250aW51YXRpb24iOm51bGwsInR4SWQiOjh9") + [ (unsafeFromText "eyJoYXNoIjoiNDhUMExqQW5TRnBGV3h2dmFQVi1fNkUtQ2pEQVBoV1lVRldidnlmMmxGcyIsInNpZ3MiOltdLCJjbWQiOiJ7XCJuZXR3b3JrSWRcIjpudWxsLFwicGF5bG9hZFwiOntcImV4ZWNcIjp7XCJkYXRhXCI6bnVsbCxcImNvZGVcIjpcIihpbnRlcmZhY2UgZnVuZ2libGUtdjFcXG5cXG4gIFxcXCIgU3RhbmRhcmQgZm9yIGZ1bmdpYmxlIGNvaW5zIGFuZCB0b2tlbnMgYXMgc3BlY2lmaWVkIGluIEtJUC0wMDAyLiBcXFwiXFxuXFxuICAgOyAtLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tXFxuICAgOyBTY2hlbWFcXG5cXG4gICAoZGVmc2NoZW1hIGFjY291bnQtZGV0YWlsc1xcbiAgICBAZG9jIFxcXCJTY2hlbWEgZm9yIHJlc3VsdHMgb2YgJ2FjY291bnQnIG9wZXJhdGlvbi5cXFwiXFxuICAgIEBtb2RlbCBbIChpbnZhcmlhbnQgKCE9IFxcXCJcXFwiIHNlbmRlcikpIF1cXG5cXG4gICAgYWNjb3VudDpzdHJpbmdcXG4gICAgYmFsYW5jZTpkZWNpbWFsXFxuICAgIGd1YXJkOmd1YXJkKVxcblxcblxcbiAgIDsgLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLVxcbiAgIDsgQ2Fwc1xcblxcbiAgIChkZWZjYXAgVFJBTlNGRVI6Ym9vbFxcbiAgICAgKCBzZW5kZXI6c3RyaW5nXFxuICAgICAgIHJlY2VpdmVyOnN0cmluZ1xcbiAgICAgICBhbW91bnQ6ZGVjaW1hbFxcbiAgICAgKVxcbiAgICAgQGRvYyBcXFwiIE1hbmFnZWQgY2FwYWJpbGl0eSBzZWFsaW5nIEFNT1VOVCBmb3IgdHJhbnNmZXIgZnJvbSBTRU5ERVIgdG8gXFxcXFxcbiAgICAgICAgICBcXFxcIFJFQ0VJVkVSLiBQZXJtaXRzIGFueSBudW1iZXIgb2YgdHJhbnNmZXJzIHVwIHRvIEFNT1VOVC5cXFwiXFxuICAgICBAbWFuYWdlZCBhbW91bnQgVFJBTlNGRVItbWdyXFxuICAgICApXFxuXFxuICAgKGRlZnVuIFRSQU5TRkVSLW1ncjpkZWNpbWFsXFxuICAgICAoIG1hbmFnZWQ6ZGVjaW1hbFxcbiAgICAgICByZXF1ZXN0ZWQ6ZGVjaW1hbFxcbiAgICAgKVxcbiAgICAgQGRvYyBcXFwiIE1hbmFnZXMgVFJBTlNGRVIgQU1PVU5UIGxpbmVhcmx5LCBcXFxcXFxuICAgICAgICAgIFxcXFwgc3VjaCB0aGF0IGEgcmVxdWVzdCBmb3IgMS4wIGFtb3VudCBvbiBhIDMuMCBcXFxcXFxuICAgICAgICAgIFxcXFwgbWFuYWdlZCBxdWFudGl0eSBlbWl0cyB1cGRhdGVkIGFtb3VudCAyLjAuXFxcIlxcbiAgICAgKVxcblxcbiAgIDsgLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLVxcbiAgIDsgRnVuY3Rpb25hbGl0eVxcblxcbiAgIChkZWZ1biB0cmFuc2Zlci1jcmVhdGU6c3RyaW5nXFxuICAgICAoIHNlbmRlcjpzdHJpbmdcXG4gICAgICAgcmVjZWl2ZXI6c3RyaW5nXFxuICAgICAgIHJlY2VpdmVyLWd1YXJkOmd1YXJkXFxuICAgICAgIGFtb3VudDpkZWNpbWFsXFxuICAgICApXFxuICAgICBAZG9jIFxcXCIgVHJhbnNmZXIgQU1PVU5UIGJldHdlZW4gYWNjb3VudHMgU0VOREVSIGFuZCBSRUNFSVZFUi4gXFxcXFxcbiAgICAgICAgICBcXFxcIEZhaWxzIGlmIFNFTkRFUiBkb2VzIG5vdCBleGlzdC4gSWYgUkVDRUlWRVIgZXhpc3RzLCBndWFyZCBcXFxcXFxuICAgICAgICAgIFxcXFwgbXVzdCBtYXRjaCBleGlzdGluZyB2YWx1ZS4gSWYgUkVDRUlWRVIgZG9lcyBub3QgZXhpc3QsIFxcXFxcXG4gICAgICAgICAgXFxcXCBSRUNFSVZFUiBhY2NvdW50IGlzIGNyZWF0ZWQgdXNpbmcgUkVDRUlWRVItR1VBUkQuIFxcXFxcXG4gICAgICAgICAgXFxcXCBTdWJqZWN0IHRvIG1hbmFnZW1lbnQgYnkgVFJBTlNGRVIgY2FwYWJpbGl0eS5cXFwiXFxuICAgICBAbW9kZWwgWyAocHJvcGVydHkgKD4gYW1vdW50IDAuMCkpXFxuICAgICAgICAgICAgICAocHJvcGVydHkgKCE9IHNlbmRlciBcXFwiXFxcIikpXFxuICAgICAgICAgICAgICAocHJvcGVydHkgKCE9IHJlY2VpdmVyIFxcXCJcXFwiKSlcXG4gICAgICAgICAgICAgIChwcm9wZXJ0eSAoIT0gc2VuZGVyIHJlY2VpdmVyKSlcXG4gICAgICAgICAgICBdXFxuICAgICApXFxuXFxuICAgKGRlZnBhY3QgdHJhbnNmZXItY3Jvc3NjaGFpbjpzdHJpbmdcXG4gICAgICggc2VuZGVyOnN0cmluZ1xcbiAgICAgICByZWNlaXZlcjpzdHJpbmdcXG4gICAgICAgcmVjZWl2ZXItZ3VhcmQ6Z3VhcmRcXG4gICAgICAgdGFyZ2V0LWNoYWluOnN0cmluZ1xcbiAgICAgICBhbW91bnQ6ZGVjaW1hbFxcbiAgICAgKVxcbiAgICAgQGRvYyBcXFwiIDItc3RlcCBwYWN0IHRvIHRyYW5zZmVyIEFNT1VOVCBmcm9tIFNFTkRFUiBvbiBjdXJyZW50IGNoYWluIFxcXFxcXG4gICAgICAgICAgXFxcXCB0byBSRUNFSVZFUiBvbiBUQVJHRVQtQ0hBSU4gdmlhIFNQViBwcm9vZi4gXFxcXFxcbiAgICAgICAgICBcXFxcIFRBUkdFVC1DSEFJTiBtdXN0IGJlIGRpZmZlcmVudCB0aGFuIGN1cnJlbnQgY2hhaW4gaWQuIFxcXFxcXG4gICAgICAgICAgXFxcXCBGaXJzdCBzdGVwIGRlYml0cyBBTU9VTlQgY29pbnMgaW4gU0VOREVSIGFjY291bnQgYW5kIHlpZWxkcyBcXFxcXFxuICAgICAgICAgIFxcXFwgUkVDRUlWRVIsIFJFQ0VJVkVSX0dVQVJEIGFuZCBBTU9VTlQgdG8gVEFSR0VULUNIQUlOLiBcXFxcXFxuICAgICAgICAgIFxcXFwgU2Vjb25kIHN0ZXAgY29udGludWF0aW9uIGlzIHNlbnQgaW50byBUQVJHRVQtQ0hBSU4gd2l0aCBwcm9vZiBcXFxcXFxuICAgICAgICAgIFxcXFwgb2J0YWluZWQgZnJvbSB0aGUgc3B2ICdvdXRwdXQnIGVuZHBvaW50IG9mIENoYWlud2ViLiBcXFxcXFxuICAgICAgICAgIFxcXFwgUHJvb2YgaXMgdmFsaWRhdGVkIGFuZCBSRUNFSVZFUiBpcyBjcmVkaXRlZCB3aXRoIEFNT1VOVCBcXFxcXFxuICAgICAgICAgIFxcXFwgY3JlYXRpbmcgYWNjb3VudCB3aXRoIFJFQ0VJVkVSX0dVQVJEIGFzIG5lY2Vzc2FyeS5cXFwiXFxuICAgICBAbW9kZWwgWyAocHJvcGVydHkgKD4gYW1vdW50IDAuMCkpXFxuICAgICAgICAgICAgICAocHJvcGVydHkgKCE9IHNlbmRlciBcXFwiXFxcIikpXFxuICAgICAgICAgICAgICAocHJvcGVydHkgKCE9IHJlY2VpdmVyIFxcXCJcXFwiKSlcXG4gICAgICAgICAgICAgIChwcm9wZXJ0eSAoIT0gc2VuZGVyIHJlY2VpdmVyKSlcXG4gICAgICAgICAgICAgIChwcm9wZXJ0eSAoIT0gdGFyZ2V0LWNoYWluIFxcXCJcXFwiKSlcXG4gICAgICAgICAgICBdXFxuICAgICApXFxuXFxuICAgKGRlZnVuIGdldC1iYWxhbmNlOmRlY2ltYWxcXG4gICAgICggYWNjb3VudDpzdHJpbmcgKVxcbiAgICAgXFxcIiBHZXQgYmFsYW5jZSBmb3IgQUNDT1VOVC4gRmFpbHMgaWYgYWNjb3VudCBkb2VzIG5vdCBleGlzdC5cXFwiXFxuICAgICApXFxuXFxuICAgKGRlZnVuIGRldGFpbHM6b2JqZWN0e2FjY291bnQtZGV0YWlsc31cXG4gICAgICggYWNjb3VudDogc3RyaW5nIClcXG4gICAgIFxcXCIgR2V0IGFuIG9iamVjdCB3aXRoIGRldGFpbHMgb2YgQUNDT1VOVC4gXFxcXFxcbiAgICAgXFxcXCBGYWlscyBpZiBhY2NvdW50IGRvZXMgbm90IGV4aXN0LlxcXCJcXG4gICAgIClcXG5cXG4gICAoZGVmdW4gcHJlY2lzaW9uOmludGVnZXJcXG4gICAgICgpXFxuICAgICBcXFwiUmV0dXJuIHRoZSBtYXhpbXVtIGFsbG93ZWQgZGVjaW1hbCBwcmVjaXNpb24uXFxcIlxcbiAgICAgKVxcblxcbiAgIChkZWZ1biBlbmZvcmNlLXVuaXQ6Ym9vbFxcbiAgICAgKCBhbW91bnQ6ZGVjaW1hbCApXFxuICAgICBcXFwiIEVuZm9yY2UgbWluaW11bSBwcmVjaXNpb24gYWxsb3dlZCBmb3IgdHJhbnNhY3Rpb25zLlxcXCJcXG4gICAgIClcXG5cXG4gICAoZGVmdW4gY3JlYXRlLWFjY291bnQ6c3RyaW5nXFxuICAgICAoIGFjY291bnQ6c3RyaW5nXFxuICAgICAgIGd1YXJkOmd1YXJkXFxuICAgICApXFxuICAgICBcXFwiIENyZWF0ZSBBQ0NPVU5UIHdpdGggMC4wIGJhbGFuY2UsIHdpdGggR1VBUkQgY29udHJvbGxpbmcgYWNjZXNzLlxcXCJcXG4gICAgIClcXG5cXG4gICAoZGVmdW4gcm90YXRlOnN0cmluZ1xcbiAgICAgKCBhY2NvdW50OnN0cmluZ1xcbiAgICAgICBuZXctZ3VhcmQ6Z3VhcmRcXG4gICAgIClcXG4gICAgIFxcXCIgUm90YXRlIGd1YXJkIGZvciBBQ0NPVU5ULiBUcmFuc2FjdGlvbiBpcyB2YWxpZGF0ZWQgYWdhaW5zdCBcXFxcXFxuICAgICBcXFxcIGV4aXN0aW5nIGd1YXJkIGJlZm9yZSBpbnN0YWxsaW5nIG5ldyBndWFyZC4gXFxcIlxcbiAgICAgKVxcblxcbilcXG5cIn19LFwic2lnbmVyc1wiOltdLFwibWV0YVwiOntcImNyZWF0aW9uVGltZVwiOjAsXCJ0dGxcIjoxNzI4MDAsXCJnYXNMaW1pdFwiOjAsXCJjaGFpbklkXCI6XCJcIixcImdhc1ByaWNlXCI6MCxcInNlbmRlclwiOlwiXCJ9LFwibm9uY2VcIjpcImdlbmVzaXMtMDFcIn0ifQ", unsafeFromText "eyJnYXMiOjAsInJlc3VsdCI6eyJzdGF0dXMiOiJzdWNjZXNzIiwiZGF0YSI6IkxvYWRlZCBpbnRlcmZhY2UgZnVuZ2libGUtdjEsIGhhc2ggTm1kUnRzekN3YWNqSEd5eUU5Tl9mbFFNUlJCaGNIVkZQNE9qaGlQZWoxRSJ9LCJyZXFLZXkiOiI0OFQwTGpBblNGcEZXeHZ2YVBWLV82RS1DakRBUGhXWVVGV2J2eWYybEZzIiwibG9ncyI6IlB3eDlycG9kS2prSGNPUlh2WFVRSUpjRVZRZDhPSXRNM0FlakNFRExMVXMiLCJtZXRhRGF0YSI6bnVsbCwiY29udGludWF0aW9uIjpudWxsLCJ0eElkIjowfQ") + , (unsafeFromText "eyJoYXNoIjoieW5ucDFYVVNSTjJrMUYwYTZ2dXM3RFp0SDZjcHN6MVhmX0d3V0xnTFhTTSIsInNpZ3MiOltdLCJjbWQiOiJ7XCJuZXR3b3JrSWRcIjpudWxsLFwicGF5bG9hZFwiOntcImV4ZWNcIjp7XCJkYXRhXCI6bnVsbCxcImNvZGVcIjpcIihpbnRlcmZhY2UgZnVuZ2libGUteGNoYWluLXYxXFxuXFxuICBcXFwiIFRoaXMgaW50ZXJmYWNlIG9mZmVycyBhIHN0YW5kYXJkIGNhcGFiaWxpdHkgZm9yIGNyb3NzLWNoYWluIFxcXFxcXG4gIFxcXFwgdHJhbnNmZXJzIGFuZCBhc3NvY2lhdGVkIGV2ZW50cy4gXFxcIlxcblxcbiAgKGRlZmNhcCBUUkFOU0ZFUl9YQ0hBSU46Ym9vbFxcbiAgICAoIHNlbmRlcjpzdHJpbmdcXG4gICAgICByZWNlaXZlcjpzdHJpbmdcXG4gICAgICBhbW91bnQ6ZGVjaW1hbFxcbiAgICAgIHRhcmdldC1jaGFpbjpzdHJpbmdcXG4gICAgKVxcbiAgICBAZG9jIFxcXCIgTWFuYWdlZCBjYXBhYmlsaXR5IHNlYWxpbmcgQU1PVU5UIGZvciB0cmFuc2ZlciBcXFxcXFxuICAgICAgICAgXFxcXCBmcm9tIFNFTkRFUiB0byBSRUNFSVZFUiBvbiBUQVJHRVQtQ0hBSU4uIFBlcm1pdHMgXFxcXFxcbiAgICAgICAgIFxcXFwgYW55IG51bWJlciBvZiBjcm9zcy1jaGFpbiB0cmFuc2ZlcnMgdXAgdG8gQU1PVU5ULlxcXCJcXG5cXG4gICAgQG1hbmFnZWQgYW1vdW50IFRSQU5TRkVSX1hDSEFJTi1tZ3JcXG4gICAgKVxcblxcbiAgKGRlZnVuIFRSQU5TRkVSX1hDSEFJTi1tZ3I6ZGVjaW1hbFxcbiAgICAoIG1hbmFnZWQ6ZGVjaW1hbFxcbiAgICAgIHJlcXVlc3RlZDpkZWNpbWFsXFxuICAgIClcXG4gICAgQGRvYyBcXFwiIEFsbG93cyBUUkFOU0ZFUi1YQ0hBSU4gQU1PVU5UIHRvIGJlIGxlc3MgdGhhbiBvciBcXFxcXFxuICAgICAgICAgXFxcXCBlcXVhbCBtYW5hZ2VkIHF1YW50aXR5IGFzIGEgb25lLXNob3QsIHJldHVybmluZyAwLjAuXFxcIlxcbiAgKVxcblxcbiAgKGRlZmNhcCBUUkFOU0ZFUl9YQ0hBSU5fUkVDRDpib29sXFxuICAgICggc2VuZGVyOnN0cmluZ1xcbiAgICAgIHJlY2VpdmVyOnN0cmluZ1xcbiAgICAgIGFtb3VudDpkZWNpbWFsXFxuICAgICAgc291cmNlLWNoYWluOnN0cmluZ1xcbiAgICApXFxuICAgIEBkb2MgXFxcIkV2ZW50IGVtaXR0ZWQgb24gcmVjZWlwdCBvZiBjcm9zcy1jaGFpbiB0cmFuc2Zlci5cXFwiXFxuICAgIEBldmVudFxcbiAgKVxcbilcXG5cIn19LFwic2lnbmVyc1wiOltdLFwibWV0YVwiOntcImNyZWF0aW9uVGltZVwiOjAsXCJ0dGxcIjoxNzI4MDAsXCJnYXNMaW1pdFwiOjAsXCJjaGFpbklkXCI6XCJcIixcImdhc1ByaWNlXCI6MCxcInNlbmRlclwiOlwiXCJ9LFwibm9uY2VcIjpcImdlbmVzaXMteGNoYWluXCJ9In0", unsafeFromText "eyJnYXMiOjAsInJlc3VsdCI6eyJzdGF0dXMiOiJzdWNjZXNzIiwiZGF0YSI6IkxvYWRlZCBpbnRlcmZhY2UgZnVuZ2libGUteGNoYWluLXYxLCBoYXNoIGg4OWljM2doejIzUmprMHBITkt0Rk93cnZTczdtYm11cWxvVlhPaGwyR0kifSwicmVxS2V5IjoieW5ucDFYVVNSTjJrMUYwYTZ2dXM3RFp0SDZjcHN6MVhmX0d3V0xnTFhTTSIsImxvZ3MiOiJSUDhnMUJrZnkyQjN1bHE0WWU4amF1VlRZcGpqRXlaLWtydGJ5SVg2STRnIiwibWV0YURhdGEiOm51bGwsImNvbnRpbnVhdGlvbiI6bnVsbCwidHhJZCI6MX0") + , (unsafeFromText "eyJoYXNoIjoiMDVCdGo3ZUJaQlc3by1TYUxvVmhBaWNNVVBaVUJiRzZRVDhfTEFrQ3hIcyIsInNpZ3MiOltdLCJjbWQiOiJ7XCJuZXR3b3JrSWRcIjpudWxsLFwicGF5bG9hZFwiOntcImV4ZWNcIjp7XCJkYXRhXCI6bnVsbCxcImNvZGVcIjpcIihpbnRlcmZhY2UgZnVuZ2libGUtdjJcXG5cXG4gIFxcXCIgU3RhbmRhcmQgZm9yIGZ1bmdpYmxlIGNvaW5zIGFuZCB0b2tlbnMgYXMgc3BlY2lmaWVkIGluIEtJUC0wMDAyLiBcXFwiXFxuXFxuICAgOyAtLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tXFxuICAgOyBTY2hlbWFcXG5cXG4gICAoZGVmc2NoZW1hIGFjY291bnQtZGV0YWlsc1xcbiAgICBAZG9jIFxcXCJTY2hlbWEgZm9yIHJlc3VsdHMgb2YgJ2FjY291bnQnIG9wZXJhdGlvbi5cXFwiXFxuICAgIEBtb2RlbCBbIChpbnZhcmlhbnQgKCE9IFxcXCJcXFwiIHNlbmRlcikpIF1cXG5cXG4gICAgYWNjb3VudDpzdHJpbmdcXG4gICAgYmFsYW5jZTpkZWNpbWFsXFxuICAgIGd1YXJkOmd1YXJkKVxcblxcblxcbiAgIDsgLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLVxcbiAgIDsgQ2Fwc1xcblxcbiAgIChkZWZjYXAgVFJBTlNGRVI6Ym9vbFxcbiAgICAgKCBzZW5kZXI6c3RyaW5nXFxuICAgICAgIHJlY2VpdmVyOnN0cmluZ1xcbiAgICAgICBhbW91bnQ6ZGVjaW1hbFxcbiAgICAgKVxcbiAgICAgQGRvYyBcXFwiIE1hbmFnZWQgY2FwYWJpbGl0eSBzZWFsaW5nIEFNT1VOVCBmb3IgdHJhbnNmZXIgZnJvbSBTRU5ERVIgdG8gXFxcXFxcbiAgICAgICAgICBcXFxcIFJFQ0VJVkVSLiBQZXJtaXRzIGFueSBudW1iZXIgb2YgdHJhbnNmZXJzIHVwIHRvIEFNT1VOVC5cXFwiXFxuICAgICBAbWFuYWdlZCBhbW91bnQgVFJBTlNGRVItbWdyXFxuICAgICApXFxuXFxuICAgKGRlZnVuIFRSQU5TRkVSLW1ncjpkZWNpbWFsXFxuICAgICAoIG1hbmFnZWQ6ZGVjaW1hbFxcbiAgICAgICByZXF1ZXN0ZWQ6ZGVjaW1hbFxcbiAgICAgKVxcbiAgICAgQGRvYyBcXFwiIE1hbmFnZXMgVFJBTlNGRVIgQU1PVU5UIGxpbmVhcmx5LCBcXFxcXFxuICAgICAgICAgIFxcXFwgc3VjaCB0aGF0IGEgcmVxdWVzdCBmb3IgMS4wIGFtb3VudCBvbiBhIDMuMCBcXFxcXFxuICAgICAgICAgIFxcXFwgbWFuYWdlZCBxdWFudGl0eSBlbWl0cyB1cGRhdGVkIGFtb3VudCAyLjAuXFxcIlxcbiAgICAgKVxcblxcbiAgIDsgLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLVxcbiAgIDsgRnVuY3Rpb25hbGl0eVxcblxcblxcbiAgKGRlZnVuIHRyYW5zZmVyOnN0cmluZ1xcbiAgICAoIHNlbmRlcjpzdHJpbmdcXG4gICAgICByZWNlaXZlcjpzdHJpbmdcXG4gICAgICBhbW91bnQ6ZGVjaW1hbFxcbiAgICApXFxuICAgIEBkb2MgXFxcIiBUcmFuc2ZlciBBTU9VTlQgYmV0d2VlbiBhY2NvdW50cyBTRU5ERVIgYW5kIFJFQ0VJVkVSLiBcXFxcXFxuICAgICAgICAgXFxcXCBGYWlscyBpZiBlaXRoZXIgU0VOREVSIG9yIFJFQ0VJVkVSIGRvZXMgbm90IGV4aXN0LlxcXCJcXG4gICAgQG1vZGVsIFsgKHByb3BlcnR5ICg-IGFtb3VudCAwLjApKVxcbiAgICAgICAgICAgICAocHJvcGVydHkgKCE9IHNlbmRlciBcXFwiXFxcIikpXFxuICAgICAgICAgICAgIChwcm9wZXJ0eSAoIT0gcmVjZWl2ZXIgXFxcIlxcXCIpKVxcbiAgICAgICAgICAgICAocHJvcGVydHkgKCE9IHNlbmRlciByZWNlaXZlcikpXFxuICAgICAgICAgICBdXFxuICAgIClcXG5cXG4gICAoZGVmdW4gdHJhbnNmZXItY3JlYXRlOnN0cmluZ1xcbiAgICAgKCBzZW5kZXI6c3RyaW5nXFxuICAgICAgIHJlY2VpdmVyOnN0cmluZ1xcbiAgICAgICByZWNlaXZlci1ndWFyZDpndWFyZFxcbiAgICAgICBhbW91bnQ6ZGVjaW1hbFxcbiAgICAgKVxcbiAgICAgQGRvYyBcXFwiIFRyYW5zZmVyIEFNT1VOVCBiZXR3ZWVuIGFjY291bnRzIFNFTkRFUiBhbmQgUkVDRUlWRVIuIFxcXFxcXG4gICAgICAgICAgXFxcXCBGYWlscyBpZiBTRU5ERVIgZG9lcyBub3QgZXhpc3QuIElmIFJFQ0VJVkVSIGV4aXN0cywgZ3VhcmQgXFxcXFxcbiAgICAgICAgICBcXFxcIG11c3QgbWF0Y2ggZXhpc3RpbmcgdmFsdWUuIElmIFJFQ0VJVkVSIGRvZXMgbm90IGV4aXN0LCBcXFxcXFxuICAgICAgICAgIFxcXFwgUkVDRUlWRVIgYWNjb3VudCBpcyBjcmVhdGVkIHVzaW5nIFJFQ0VJVkVSLUdVQVJELiBcXFxcXFxuICAgICAgICAgIFxcXFwgU3ViamVjdCB0byBtYW5hZ2VtZW50IGJ5IFRSQU5TRkVSIGNhcGFiaWxpdHkuXFxcIlxcbiAgICAgQG1vZGVsIFsgKHByb3BlcnR5ICg-IGFtb3VudCAwLjApKVxcbiAgICAgICAgICAgICAgKHByb3BlcnR5ICghPSBzZW5kZXIgXFxcIlxcXCIpKVxcbiAgICAgICAgICAgICAgKHByb3BlcnR5ICghPSByZWNlaXZlciBcXFwiXFxcIikpXFxuICAgICAgICAgICAgICAocHJvcGVydHkgKCE9IHNlbmRlciByZWNlaXZlcikpXFxuICAgICAgICAgICAgXVxcbiAgICAgKVxcblxcbiAgIChkZWZwYWN0IHRyYW5zZmVyLWNyb3NzY2hhaW46c3RyaW5nXFxuICAgICAoIHNlbmRlcjpzdHJpbmdcXG4gICAgICAgcmVjZWl2ZXI6c3RyaW5nXFxuICAgICAgIHJlY2VpdmVyLWd1YXJkOmd1YXJkXFxuICAgICAgIHRhcmdldC1jaGFpbjpzdHJpbmdcXG4gICAgICAgYW1vdW50OmRlY2ltYWxcXG4gICAgIClcXG4gICAgIEBkb2MgXFxcIiAyLXN0ZXAgcGFjdCB0byB0cmFuc2ZlciBBTU9VTlQgZnJvbSBTRU5ERVIgb24gY3VycmVudCBjaGFpbiBcXFxcXFxuICAgICAgICAgIFxcXFwgdG8gUkVDRUlWRVIgb24gVEFSR0VULUNIQUlOIHZpYSBTUFYgcHJvb2YuIFxcXFxcXG4gICAgICAgICAgXFxcXCBUQVJHRVQtQ0hBSU4gbXVzdCBiZSBkaWZmZXJlbnQgdGhhbiBjdXJyZW50IGNoYWluIGlkLiBcXFxcXFxuICAgICAgICAgIFxcXFwgRmlyc3Qgc3RlcCBkZWJpdHMgQU1PVU5UIGNvaW5zIGluIFNFTkRFUiBhY2NvdW50IGFuZCB5aWVsZHMgXFxcXFxcbiAgICAgICAgICBcXFxcIFJFQ0VJVkVSLCBSRUNFSVZFUl9HVUFSRCBhbmQgQU1PVU5UIHRvIFRBUkdFVC1DSEFJTi4gXFxcXFxcbiAgICAgICAgICBcXFxcIFNlY29uZCBzdGVwIGNvbnRpbnVhdGlvbiBpcyBzZW50IGludG8gVEFSR0VULUNIQUlOIHdpdGggcHJvb2YgXFxcXFxcbiAgICAgICAgICBcXFxcIG9idGFpbmVkIGZyb20gdGhlIHNwdiAnb3V0cHV0JyBlbmRwb2ludCBvZiBDaGFpbndlYi4gXFxcXFxcbiAgICAgICAgICBcXFxcIFByb29mIGlzIHZhbGlkYXRlZCBhbmQgUkVDRUlWRVIgaXMgY3JlZGl0ZWQgd2l0aCBBTU9VTlQgXFxcXFxcbiAgICAgICAgICBcXFxcIGNyZWF0aW5nIGFjY291bnQgd2l0aCBSRUNFSVZFUl9HVUFSRCBhcyBuZWNlc3NhcnkuXFxcIlxcbiAgICAgQG1vZGVsIFsgKHByb3BlcnR5ICg-IGFtb3VudCAwLjApKVxcbiAgICAgICAgICAgICAgKHByb3BlcnR5ICghPSBzZW5kZXIgXFxcIlxcXCIpKVxcbiAgICAgICAgICAgICAgKHByb3BlcnR5ICghPSByZWNlaXZlciBcXFwiXFxcIikpXFxuICAgICAgICAgICAgICAocHJvcGVydHkgKCE9IHNlbmRlciByZWNlaXZlcikpXFxuICAgICAgICAgICAgICAocHJvcGVydHkgKCE9IHRhcmdldC1jaGFpbiBcXFwiXFxcIikpXFxuICAgICAgICAgICAgXVxcbiAgICAgKVxcblxcbiAgIChkZWZ1biBnZXQtYmFsYW5jZTpkZWNpbWFsXFxuICAgICAoIGFjY291bnQ6c3RyaW5nIClcXG4gICAgIFxcXCIgR2V0IGJhbGFuY2UgZm9yIEFDQ09VTlQuIEZhaWxzIGlmIGFjY291bnQgZG9lcyBub3QgZXhpc3QuXFxcIlxcbiAgICAgKVxcblxcbiAgIChkZWZ1biBkZXRhaWxzOm9iamVjdHthY2NvdW50LWRldGFpbHN9XFxuICAgICAoIGFjY291bnQ6IHN0cmluZyApXFxuICAgICBcXFwiIEdldCBhbiBvYmplY3Qgd2l0aCBkZXRhaWxzIG9mIEFDQ09VTlQuIFxcXFxcXG4gICAgIFxcXFwgRmFpbHMgaWYgYWNjb3VudCBkb2VzIG5vdCBleGlzdC5cXFwiXFxuICAgICApXFxuXFxuICAgKGRlZnVuIHByZWNpc2lvbjppbnRlZ2VyXFxuICAgICAoKVxcbiAgICAgXFxcIlJldHVybiB0aGUgbWF4aW11bSBhbGxvd2VkIGRlY2ltYWwgcHJlY2lzaW9uLlxcXCJcXG4gICAgIClcXG5cXG4gICAoZGVmdW4gZW5mb3JjZS11bml0OmJvb2xcXG4gICAgICggYW1vdW50OmRlY2ltYWwgKVxcbiAgICAgXFxcIiBFbmZvcmNlIG1pbmltdW0gcHJlY2lzaW9uIGFsbG93ZWQgZm9yIHRyYW5zYWN0aW9ucy5cXFwiXFxuICAgICApXFxuXFxuICAgKGRlZnVuIGNyZWF0ZS1hY2NvdW50OnN0cmluZ1xcbiAgICAgKCBhY2NvdW50OnN0cmluZ1xcbiAgICAgICBndWFyZDpndWFyZFxcbiAgICAgKVxcbiAgICAgXFxcIiBDcmVhdGUgQUNDT1VOVCB3aXRoIDAuMCBiYWxhbmNlLCB3aXRoIEdVQVJEIGNvbnRyb2xsaW5nIGFjY2Vzcy5cXFwiXFxuICAgICApXFxuXFxuICAgKGRlZnVuIHJvdGF0ZTpzdHJpbmdcXG4gICAgICggYWNjb3VudDpzdHJpbmdcXG4gICAgICAgbmV3LWd1YXJkOmd1YXJkXFxuICAgICApXFxuICAgICBcXFwiIFJvdGF0ZSBndWFyZCBmb3IgQUNDT1VOVC4gVHJhbnNhY3Rpb24gaXMgdmFsaWRhdGVkIGFnYWluc3QgXFxcXFxcbiAgICAgXFxcXCBleGlzdGluZyBndWFyZCBiZWZvcmUgaW5zdGFsbGluZyBuZXcgZ3VhcmQuIFxcXCJcXG4gICAgIClcXG5cXG4pXFxuXCJ9fSxcInNpZ25lcnNcIjpbXSxcIm1ldGFcIjp7XCJjcmVhdGlvblRpbWVcIjowLFwidHRsXCI6MTcyODAwLFwiZ2FzTGltaXRcIjowLFwiY2hhaW5JZFwiOlwiXCIsXCJnYXNQcmljZVwiOjAsXCJzZW5kZXJcIjpcIlwifSxcIm5vbmNlXCI6XCJmdW5naWJsZS1hc3NldC12MlwifSJ9", unsafeFromText "eyJnYXMiOjAsInJlc3VsdCI6eyJzdGF0dXMiOiJzdWNjZXNzIiwiZGF0YSI6IkxvYWRlZCBpbnRlcmZhY2UgZnVuZ2libGUtdjIsIGhhc2ggWXhFLUtnQzZKbUttQ2NnS1RKbWxFbl9JNThJNEVYbWhmcnZ6WDdiZXJZayJ9LCJyZXFLZXkiOiIwNUJ0ajdlQlpCVzdvLVNhTG9WaEFpY01VUFpVQmJHNlFUOF9MQWtDeEhzIiwibG9ncyI6IjFTQmJBNHVzS0E5OFNlX09WRUdkcVk5WjJoSW1jVmcydWpISDJkM1ZmeEkiLCJtZXRhRGF0YSI6bnVsbCwiY29udGludWF0aW9uIjpudWxsLCJ0eElkIjoyfQ") + , (unsafeFromText "eyJoYXNoIjoiR1JJUXU0aEFLazBJRDlGOHpfLTB5WHlBS0ozM01QeVRZTVhPamxQSm1wSSIsInNpZ3MiOltdLCJjbWQiOiJ7XCJuZXR3b3JrSWRcIjpudWxsLFwicGF5bG9hZFwiOntcImV4ZWNcIjp7XCJkYXRhXCI6bnVsbCxcImNvZGVcIjpcIlxcbihtb2R1bGUgY29pbiBHT1ZFUk5BTkNFXFxuXFxuICBAZG9jIFxcXCInY29pbicgcmVwcmVzZW50cyB0aGUgS2FkZW5hIENvaW4gQ29udHJhY3QuIFRoaXMgY29udHJhY3QgcHJvdmlkZXMgYm90aCB0aGUgXFxcXFxcbiAgXFxcXGJ1eS9yZWRlZW0gZ2FzIHN1cHBvcnQgaW4gdGhlIGZvcm0gb2YgJ2Z1bmQtdHgnLCBhcyB3ZWxsIGFzIHRyYW5zZmVyLCAgICAgICBcXFxcXFxuICBcXFxcY3JlZGl0LCBkZWJpdCwgY29pbmJhc2UsIGFjY291bnQgY3JlYXRpb24gYW5kIHF1ZXJ5LCBhcyB3ZWxsIGFzIFNQViBidXJuICAgIFxcXFxcXG4gIFxcXFxjcmVhdGUuIFRvIGFjY2VzcyB0aGUgY29pbiBjb250cmFjdCwgeW91IG1heSB1c2UgaXRzIGZ1bGx5LXF1YWxpZmllZCBuYW1lLCAgXFxcXFxcbiAgXFxcXG9yIGlzc3VlIHRoZSAnKHVzZSBjb2luKScgY29tbWFuZCBpbiB0aGUgYm9keSBvZiBhIG1vZHVsZSBkZWNsYXJhdGlvbi5cXFwiXFxuXFxuICBAbW9kZWxcXG4gICAgWyAoZGVmcHJvcGVydHkgY29uc2VydmVzLW1hc3NcXG4gICAgICAgICg9IChjb2x1bW4tZGVsdGEgY29pbi10YWJsZSAnYmFsYW5jZSkgMC4wKSlcXG5cXG4gICAgICAoZGVmcHJvcGVydHkgdmFsaWQtYWNjb3VudCAoYWNjb3VudDpzdHJpbmcpXFxuICAgICAgICAoYW5kXFxuICAgICAgICAgICg-PSAobGVuZ3RoIGFjY291bnQpIDMpXFxuICAgICAgICAgICg8PSAobGVuZ3RoIGFjY291bnQpIDI1NikpKVxcbiAgICBdXFxuXFxuICAoaW1wbGVtZW50cyBmdW5naWJsZS12MilcXG4gIChpbXBsZW1lbnRzIGZ1bmdpYmxlLXhjaGFpbi12MSlcXG5cXG4gIDs7IGNvaW4tdjJcXG4gIChibGVzcyBcXFwidXRfSl9aTmtveWFQVUVKaGl3VmVXbmtTUW45SlQ5c1FDV0tkampWVnJXb1xcXCIpXFxuXFxuICA7OyBjb2luIHYzXFxuICAoYmxlc3MgXFxcIjFvc19zTEFVWXZCenNwbjVqamF3dFJwSldpSDFXUGZoeU5yYWVWdlNJd1VcXFwiKVxcblxcbiAgOzsgY29pbiB2NFxcbiAgKGJsZXNzIFxcXCJCalpXMFQyYWM2cUVfSTVYOEdFNGZhbDZ0VHFqaExUQzdteTB5dFFTeExVXFxcIilcXG5cXG4gIDs7IGNvaW4gdjVcXG4gIChibGVzcyBcXFwickU3RFU4amxRTDl4X01QWXVuaVpKZjVJQ0JUQUVIQUlGUUNCNGJsb2ZQNFxcXCIpXFxuXFxuICA7IC0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tXFxuICA7IFNjaGVtYXMgYW5kIFRhYmxlc1xcblxcbiAgKGRlZnNjaGVtYSBjb2luLXNjaGVtYVxcbiAgICBAZG9jIFxcXCJUaGUgY29pbiBjb250cmFjdCB0b2tlbiBzY2hlbWFcXFwiXFxuICAgIEBtb2RlbCBbIChpbnZhcmlhbnQgKD49IGJhbGFuY2UgMC4wKSkgXVxcblxcbiAgICBiYWxhbmNlOmRlY2ltYWxcXG4gICAgZ3VhcmQ6Z3VhcmQpXFxuXFxuICAoZGVmdGFibGUgY29pbi10YWJsZTp7Y29pbi1zY2hlbWF9KVxcblxcbiAgOyAtLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLVxcbiAgOyBDYXBhYmlsaXRpZXNcXG5cXG4gIChkZWZjYXAgR09WRVJOQU5DRSAoKVxcbiAgICAoZW5mb3JjZSBmYWxzZSBcXFwiRW5mb3JjZSBub24tdXBncmFkZWFiaWxpdHlcXFwiKSlcXG5cXG4gIChkZWZjYXAgR0FTICgpXFxuICAgIFxcXCJNYWdpYyBjYXBhYmlsaXR5IHRvIHByb3RlY3QgZ2FzIGJ1eSBhbmQgcmVkZWVtXFxcIlxcbiAgICB0cnVlKVxcblxcbiAgKGRlZmNhcCBDT0lOQkFTRSAoKVxcbiAgICBcXFwiTWFnaWMgY2FwYWJpbGl0eSB0byBwcm90ZWN0IG1pbmVyIHJld2FyZFxcXCJcXG4gICAgdHJ1ZSlcXG5cXG4gIChkZWZjYXAgR0VORVNJUyAoKVxcbiAgICBcXFwiTWFnaWMgY2FwYWJpbGl0eSBjb25zdHJhaW5pbmcgZ2VuZXNpcyB0cmFuc2FjdGlvbnNcXFwiXFxuICAgIHRydWUpXFxuXFxuICAoZGVmY2FwIFJFTUVESUFURSAoKVxcbiAgICBcXFwiTWFnaWMgY2FwYWJpbGl0eSBmb3IgcmVtZWRpYXRpb24gdHJhbnNhY3Rpb25zXFxcIlxcbiAgICB0cnVlKVxcblxcbiAgKGRlZmNhcCBERUJJVCAoc2VuZGVyOnN0cmluZylcXG4gICAgXFxcIkNhcGFiaWxpdHkgZm9yIG1hbmFnaW5nIGRlYml0aW5nIG9wZXJhdGlvbnNcXFwiXFxuICAgIChlbmZvcmNlLWd1YXJkIChhdCAnZ3VhcmQgKHJlYWQgY29pbi10YWJsZSBzZW5kZXIpKSlcXG4gICAgKGVuZm9yY2UgKCE9IHNlbmRlciBcXFwiXFxcIikgXFxcInZhbGlkIHNlbmRlclxcXCIpKVxcblxcbiAgKGRlZmNhcCBDUkVESVQgKHJlY2VpdmVyOnN0cmluZylcXG4gICAgXFxcIkNhcGFiaWxpdHkgZm9yIG1hbmFnaW5nIGNyZWRpdGluZyBvcGVyYXRpb25zXFxcIlxcbiAgICAoZW5mb3JjZSAoIT0gcmVjZWl2ZXIgXFxcIlxcXCIpIFxcXCJ2YWxpZCByZWNlaXZlclxcXCIpKVxcblxcbiAgKGRlZmNhcCBST1RBVEUgKGFjY291bnQ6c3RyaW5nKVxcbiAgICBAZG9jIFxcXCJBdXRvbm9tb3VzbHkgbWFuYWdlZCBjYXBhYmlsaXR5IGZvciBndWFyZCByb3RhdGlvblxcXCJcXG4gICAgQG1hbmFnZWRcXG4gICAgdHJ1ZSlcXG5cXG4gIChkZWZjYXAgVFJBTlNGRVI6Ym9vbFxcbiAgICAoIHNlbmRlcjpzdHJpbmdcXG4gICAgICByZWNlaXZlcjpzdHJpbmdcXG4gICAgICBhbW91bnQ6ZGVjaW1hbFxcbiAgICApXFxuICAgIEBtYW5hZ2VkIGFtb3VudCBUUkFOU0ZFUi1tZ3JcXG4gICAgKGVuZm9yY2UgKCE9IHNlbmRlciByZWNlaXZlcikgXFxcInNhbWUgc2VuZGVyIGFuZCByZWNlaXZlclxcXCIpXFxuICAgIChlbmZvcmNlLXVuaXQgYW1vdW50KVxcbiAgICAoZW5mb3JjZSAoPiBhbW91bnQgMC4wKSBcXFwiUG9zaXRpdmUgYW1vdW50XFxcIilcXG4gICAgKGNvbXBvc2UtY2FwYWJpbGl0eSAoREVCSVQgc2VuZGVyKSlcXG4gICAgKGNvbXBvc2UtY2FwYWJpbGl0eSAoQ1JFRElUIHJlY2VpdmVyKSlcXG4gIClcXG5cXG4gIChkZWZ1biBUUkFOU0ZFUi1tZ3I6ZGVjaW1hbFxcbiAgICAoIG1hbmFnZWQ6ZGVjaW1hbFxcbiAgICAgIHJlcXVlc3RlZDpkZWNpbWFsXFxuICAgIClcXG5cXG4gICAgKGxldCAoKG5ld2JhbCAoLSBtYW5hZ2VkIHJlcXVlc3RlZCkpKVxcbiAgICAgIChlbmZvcmNlICg-PSBuZXdiYWwgMC4wKVxcbiAgICAgICAgKGZvcm1hdCBcXFwiVFJBTlNGRVIgZXhjZWVkZWQgZm9yIGJhbGFuY2Uge31cXFwiIFttYW5hZ2VkXSkpXFxuICAgICAgbmV3YmFsKVxcbiAgKVxcblxcbiAgKGRlZmNhcCBUUkFOU0ZFUl9YQ0hBSU46Ym9vbFxcbiAgICAoIHNlbmRlcjpzdHJpbmdcXG4gICAgICByZWNlaXZlcjpzdHJpbmdcXG4gICAgICBhbW91bnQ6ZGVjaW1hbFxcbiAgICAgIHRhcmdldC1jaGFpbjpzdHJpbmdcXG4gICAgKVxcblxcbiAgICBAbWFuYWdlZCBhbW91bnQgVFJBTlNGRVJfWENIQUlOLW1nclxcbiAgICAoZW5mb3JjZS11bml0IGFtb3VudClcXG4gICAgKGVuZm9yY2UgKD4gYW1vdW50IDAuMCkgXFxcIkNyb3NzLWNoYWluIHRyYW5zZmVycyByZXF1aXJlIGEgcG9zaXRpdmUgYW1vdW50XFxcIilcXG4gICAgKGNvbXBvc2UtY2FwYWJpbGl0eSAoREVCSVQgc2VuZGVyKSlcXG4gIClcXG5cXG4gIChkZWZ1biBUUkFOU0ZFUl9YQ0hBSU4tbWdyOmRlY2ltYWxcXG4gICAgKCBtYW5hZ2VkOmRlY2ltYWxcXG4gICAgICByZXF1ZXN0ZWQ6ZGVjaW1hbFxcbiAgICApXFxuXFxuICAgIChlbmZvcmNlICg-PSBtYW5hZ2VkIHJlcXVlc3RlZClcXG4gICAgICAoZm9ybWF0IFxcXCJUUkFOU0ZFUl9YQ0hBSU4gZXhjZWVkZWQgZm9yIGJhbGFuY2Uge31cXFwiIFttYW5hZ2VkXSkpXFxuICAgIDAuMFxcbiAgKVxcblxcbiAgKGRlZmNhcCBUUkFOU0ZFUl9YQ0hBSU5fUkVDRDpib29sXFxuICAgICggc2VuZGVyOnN0cmluZ1xcbiAgICAgIHJlY2VpdmVyOnN0cmluZ1xcbiAgICAgIGFtb3VudDpkZWNpbWFsXFxuICAgICAgc291cmNlLWNoYWluOnN0cmluZ1xcbiAgICApXFxuICAgIEBldmVudCB0cnVlXFxuICApXFxuXFxuICA7IHYzIGNhcGFiaWxpdGllc1xcbiAgKGRlZmNhcCBSRUxFQVNFX0FMTE9DQVRJT05cXG4gICAgKCBhY2NvdW50OnN0cmluZ1xcbiAgICAgIGFtb3VudDpkZWNpbWFsXFxuICAgIClcXG4gICAgQGRvYyBcXFwiRXZlbnQgZm9yIGFsbG9jYXRpb24gcmVsZWFzZSwgY2FuIGJlIHVzZWQgZm9yIHNpZyBzY29waW5nLlxcXCJcXG4gICAgQGV2ZW50IHRydWVcXG4gIClcXG5cXG4gIDsgLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS1cXG4gIDsgQ29uc3RhbnRzXFxuXFxuICAoZGVmY29uc3QgQ09JTl9DSEFSU0VUIENIQVJTRVRfTEFUSU4xXFxuICAgIFxcXCJUaGUgZGVmYXVsdCBjb2luIGNvbnRyYWN0IGNoYXJhY3RlciBzZXRcXFwiKVxcblxcbiAgKGRlZmNvbnN0IE1JTklNVU1fUFJFQ0lTSU9OIDEyXFxuICAgIFxcXCJNaW5pbXVtIGFsbG93ZWQgcHJlY2lzaW9uIGZvciBjb2luIHRyYW5zYWN0aW9uc1xcXCIpXFxuXFxuICAoZGVmY29uc3QgTUlOSU1VTV9BQ0NPVU5UX0xFTkdUSCAzXFxuICAgIFxcXCJNaW5pbXVtIGFjY291bnQgbGVuZ3RoIGFkbWlzc2libGUgZm9yIGNvaW4gYWNjb3VudHNcXFwiKVxcblxcbiAgKGRlZmNvbnN0IE1BWElNVU1fQUNDT1VOVF9MRU5HVEggMjU2XFxuICAgIFxcXCJNYXhpbXVtIGFjY291bnQgbmFtZSBsZW5ndGggYWRtaXNzaWJsZSBmb3IgY29pbiBhY2NvdW50c1xcXCIpXFxuXFxuICAoZGVmY29uc3QgVkFMSURfQ0hBSU5fSURTIChtYXAgKGludC10by1zdHIgMTApIChlbnVtZXJhdGUgMCAxOSkpXFxuICAgIFxcXCJMaXN0IG9mIGFsbCB2YWxpZCBDaGFpbndlYiBjaGFpbiBpZHNcXFwiKVxcblxcbiAgOyAtLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLVxcbiAgOyBVdGlsaXRpZXNcXG5cXG4gIChkZWZ1biBlbmZvcmNlLXVuaXQ6Ym9vbCAoYW1vdW50OmRlY2ltYWwpXFxuICAgIEBkb2MgXFxcIkVuZm9yY2UgbWluaW11bSBwcmVjaXNpb24gYWxsb3dlZCBmb3IgY29pbiB0cmFuc2FjdGlvbnNcXFwiXFxuXFxuICAgIChlbmZvcmNlXFxuICAgICAgKD0gKGZsb29yIGFtb3VudCBNSU5JTVVNX1BSRUNJU0lPTilcXG4gICAgICAgICBhbW91bnQpXFxuICAgICAgKGZvcm1hdCBcXFwiQW1vdW50IHZpb2xhdGVzIG1pbmltdW0gcHJlY2lzaW9uOiB7fVxcXCIgW2Ftb3VudF0pKVxcbiAgICApXFxuXFxuICAoZGVmdW4gdmFsaWRhdGUtYWNjb3VudCAoYWNjb3VudDpzdHJpbmcpXFxuICAgIEBkb2MgXFxcIkVuZm9yY2UgdGhhdCBhbiBhY2NvdW50IG5hbWUgY29uZm9ybXMgdG8gdGhlIGNvaW4gY29udHJhY3QgXFxcXFxcbiAgICAgICAgIFxcXFxtaW5pbXVtIGFuZCBtYXhpbXVtIGxlbmd0aCByZXF1aXJlbWVudHMsIGFzIHdlbGwgYXMgdGhlICAgIFxcXFxcXG4gICAgICAgICBcXFxcbGF0aW4tMSBjaGFyYWN0ZXIgc2V0LlxcXCJcXG5cXG4gICAgKGVuZm9yY2VcXG4gICAgICAoaXMtY2hhcnNldCBDT0lOX0NIQVJTRVQgYWNjb3VudClcXG4gICAgICAoZm9ybWF0XFxuICAgICAgICBcXFwiQWNjb3VudCBkb2VzIG5vdCBjb25mb3JtIHRvIHRoZSBjb2luIGNvbnRyYWN0IGNoYXJzZXQ6IHt9XFxcIlxcbiAgICAgICAgW2FjY291bnRdKSlcXG5cXG4gICAgKGxldCAoKGFjY291bnQtbGVuZ3RoIChsZW5ndGggYWNjb3VudCkpKVxcblxcbiAgICAgIChlbmZvcmNlXFxuICAgICAgICAoPj0gYWNjb3VudC1sZW5ndGggTUlOSU1VTV9BQ0NPVU5UX0xFTkdUSClcXG4gICAgICAgIChmb3JtYXRcXG4gICAgICAgICAgXFxcIkFjY291bnQgbmFtZSBkb2VzIG5vdCBjb25mb3JtIHRvIHRoZSBtaW4gbGVuZ3RoIHJlcXVpcmVtZW50OiB7fVxcXCJcXG4gICAgICAgICAgW2FjY291bnRdKSlcXG5cXG4gICAgICAoZW5mb3JjZVxcbiAgICAgICAgKDw9IGFjY291bnQtbGVuZ3RoIE1BWElNVU1fQUNDT1VOVF9MRU5HVEgpXFxuICAgICAgICAoZm9ybWF0XFxuICAgICAgICAgIFxcXCJBY2NvdW50IG5hbWUgZG9lcyBub3QgY29uZm9ybSB0byB0aGUgbWF4IGxlbmd0aCByZXF1aXJlbWVudDoge31cXFwiXFxuICAgICAgICAgIFthY2NvdW50XSkpXFxuICAgICAgKVxcbiAgKVxcblxcbiAgOyAtLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLVxcbiAgOyBDb2luIENvbnRyYWN0XFxuXFxuICAoZGVmdW4gZ2FzLW9ubHkgKClcXG4gICAgXFxcIlByZWRpY2F0ZSBmb3IgZ2FzLW9ubHkgdXNlciBndWFyZHMuXFxcIlxcbiAgICAocmVxdWlyZS1jYXBhYmlsaXR5IChHQVMpKSlcXG5cXG4gIChkZWZ1biBnYXMtZ3VhcmQgKGd1YXJkOmd1YXJkKVxcbiAgICBcXFwiUHJlZGljYXRlIGZvciBnYXMgKyBzaW5nbGUga2V5IHVzZXIgZ3VhcmRzXFxcIlxcbiAgICAoZW5mb3JjZS1vbmVcXG4gICAgICBcXFwiRW5mb3JjZSBlaXRoZXIgdGhlIHByZXNlbmNlIG9mIGEgR0FTIGNhcCBvciBrZXlzZXRcXFwiXFxuICAgICAgWyAoZ2FzLW9ubHkpXFxuICAgICAgICAoZW5mb3JjZS1ndWFyZCBndWFyZClcXG4gICAgICBdKSlcXG5cXG4gIChkZWZ1biBidXktZ2FzOnN0cmluZyAoc2VuZGVyOnN0cmluZyB0b3RhbDpkZWNpbWFsKVxcbiAgICBAZG9jIFxcXCJUaGlzIGZ1bmN0aW9uIGRlc2NyaWJlcyB0aGUgbWFpbiAnZ2FzIGJ1eScgb3BlcmF0aW9uLiBBdCB0aGlzIHBvaW50IFxcXFxcXG4gICAgXFxcXE1JTkVSIGhhcyBiZWVuIGNob3NlbiBmcm9tIHRoZSBwb29sLCBhbmQgd2lsbCBiZSB2YWxpZGF0ZWQuIFRoZSBTRU5ERVIgICBcXFxcXFxuICAgIFxcXFxvZiB0aGlzIHRyYW5zYWN0aW9uIGhhcyBzcGVjaWZpZWQgYSBnYXMgbGltaXQgTElNSVQgKG1heGltdW0gZ2FzKSBmb3IgICAgXFxcXFxcbiAgICBcXFxcdGhlIHRyYW5zYWN0aW9uLCBhbmQgdGhlIHByaWNlIGlzIHRoZSBzcG90IHByaWNlIG9mIGdhcyBhdCB0aGF0IHRpbWUuICAgIFxcXFxcXG4gICAgXFxcXFRoZSBnYXMgYnV5IHdpbGwgYmUgZXhlY3V0ZWQgcHJpb3IgdG8gZXhlY3V0aW5nIFNFTkRFUidzIGNvZGUuXFxcIlxcblxcbiAgICBAbW9kZWwgWyAocHJvcGVydHkgKD4gdG90YWwgMC4wKSlcXG4gICAgICAgICAgICAgKHByb3BlcnR5ICh2YWxpZC1hY2NvdW50IHNlbmRlcikpXFxuICAgICAgICAgICBdXFxuXFxuICAgICh2YWxpZGF0ZS1hY2NvdW50IHNlbmRlcilcXG5cXG4gICAgKGVuZm9yY2UtdW5pdCB0b3RhbClcXG4gICAgKGVuZm9yY2UgKD4gdG90YWwgMC4wKSBcXFwiZ2FzIHN1cHBseSBtdXN0IGJlIGEgcG9zaXRpdmUgcXVhbnRpdHlcXFwiKVxcblxcbiAgICAocmVxdWlyZS1jYXBhYmlsaXR5IChHQVMpKVxcbiAgICAod2l0aC1jYXBhYmlsaXR5IChERUJJVCBzZW5kZXIpXFxuICAgICAgKGRlYml0IHNlbmRlciB0b3RhbCkpXFxuICAgIClcXG5cXG4gIChkZWZ1biByZWRlZW0tZ2FzOnN0cmluZyAobWluZXI6c3RyaW5nIG1pbmVyLWd1YXJkOmd1YXJkIHNlbmRlcjpzdHJpbmcgdG90YWw6ZGVjaW1hbClcXG4gICAgQGRvYyBcXFwiVGhpcyBmdW5jdGlvbiBkZXNjcmliZXMgdGhlIG1haW4gJ3JlZGVlbSBnYXMnIG9wZXJhdGlvbi4gQXQgdGhpcyAgICBcXFxcXFxuICAgIFxcXFxwb2ludCwgdGhlIFNFTkRFUidzIHRyYW5zYWN0aW9uIGhhcyBiZWVuIGV4ZWN1dGVkLCBhbmQgdGhlIGdhcyB0aGF0ICAgICAgXFxcXFxcbiAgICBcXFxcd2FzIGNoYXJnZWQgaGFzIGJlZW4gY2FsY3VsYXRlZC4gTUlORVIgd2lsbCBiZSBjcmVkaXRlZCB0aGUgZ2FzIGNvc3QsICAgIFxcXFxcXG4gICAgXFxcXGFuZCBTRU5ERVIgd2lsbCByZWNlaXZlIHRoZSByZW1haW5kZXIgdXAgdG8gdGhlIGxpbWl0XFxcIlxcblxcbiAgICBAbW9kZWwgWyAocHJvcGVydHkgKD4gdG90YWwgMC4wKSlcXG4gICAgICAgICAgICAgKHByb3BlcnR5ICh2YWxpZC1hY2NvdW50IHNlbmRlcikpXFxuICAgICAgICAgICAgIChwcm9wZXJ0eSAodmFsaWQtYWNjb3VudCBtaW5lcikpXFxuICAgICAgICAgICBdXFxuXFxuICAgICh2YWxpZGF0ZS1hY2NvdW50IHNlbmRlcilcXG4gICAgKHZhbGlkYXRlLWFjY291bnQgbWluZXIpXFxuICAgIChlbmZvcmNlLXVuaXQgdG90YWwpXFxuXFxuICAgIChyZXF1aXJlLWNhcGFiaWxpdHkgKEdBUykpXFxuICAgIChsZXQqXFxuICAgICAgKChmZWUgKHJlYWQtZGVjaW1hbCBcXFwiZmVlXFxcIikpXFxuICAgICAgIChyZWZ1bmQgKC0gdG90YWwgZmVlKSkpXFxuXFxuICAgICAgKGVuZm9yY2UtdW5pdCBmZWUpXFxuICAgICAgKGVuZm9yY2UgKD49IGZlZSAwLjApXFxuICAgICAgICBcXFwiZmVlIG11c3QgYmUgYSBub24tbmVnYXRpdmUgcXVhbnRpdHlcXFwiKVxcblxcbiAgICAgIChlbmZvcmNlICg-PSByZWZ1bmQgMC4wKVxcbiAgICAgICAgXFxcInJlZnVuZCBtdXN0IGJlIGEgbm9uLW5lZ2F0aXZlIHF1YW50aXR5XFxcIilcXG5cXG4gICAgICAoZW1pdC1ldmVudCAoVFJBTlNGRVIgc2VuZGVyIG1pbmVyIGZlZSkpIDt2M1xcblxcbiAgICAgICAgOyBkaXJlY3RseSB1cGRhdGUgaW5zdGVhZCBvZiBjcmVkaXRcXG4gICAgICAod2l0aC1jYXBhYmlsaXR5IChDUkVESVQgc2VuZGVyKVxcbiAgICAgICAgKGlmICg-IHJlZnVuZCAwLjApXFxuICAgICAgICAgICh3aXRoLXJlYWQgY29pbi10YWJsZSBzZW5kZXJcXG4gICAgICAgICAgICB7IFxcXCJiYWxhbmNlXFxcIiA6PSBiYWxhbmNlIH1cXG4gICAgICAgICAgICAodXBkYXRlIGNvaW4tdGFibGUgc2VuZGVyXFxuICAgICAgICAgICAgICB7IFxcXCJiYWxhbmNlXFxcIjogKCsgYmFsYW5jZSByZWZ1bmQpIH0pKVxcblxcbiAgICAgICAgICBcXFwibm9vcFxcXCIpKVxcblxcbiAgICAgICh3aXRoLWNhcGFiaWxpdHkgKENSRURJVCBtaW5lcilcXG4gICAgICAgIChpZiAoPiBmZWUgMC4wKVxcbiAgICAgICAgICAoY3JlZGl0IG1pbmVyIG1pbmVyLWd1YXJkIGZlZSlcXG4gICAgICAgICAgXFxcIm5vb3BcXFwiKSlcXG4gICAgICApXFxuXFxuICAgIClcXG5cXG4gIChkZWZ1biBjcmVhdGUtYWNjb3VudDpzdHJpbmcgKGFjY291bnQ6c3RyaW5nIGd1YXJkOmd1YXJkKVxcbiAgICBAbW9kZWwgWyAocHJvcGVydHkgKHZhbGlkLWFjY291bnQgYWNjb3VudCkpIF1cXG5cXG4gICAgKHZhbGlkYXRlLWFjY291bnQgYWNjb3VudClcXG4gICAgKGVuZm9yY2UtcmVzZXJ2ZWQgYWNjb3VudCBndWFyZClcXG5cXG4gICAgKGluc2VydCBjb2luLXRhYmxlIGFjY291bnRcXG4gICAgICB7IFxcXCJiYWxhbmNlXFxcIiA6IDAuMFxcbiAgICAgICwgXFxcImd1YXJkXFxcIiAgIDogZ3VhcmRcXG4gICAgICB9KVxcbiAgICApXFxuXFxuICAoZGVmdW4gZ2V0LWJhbGFuY2U6ZGVjaW1hbCAoYWNjb3VudDpzdHJpbmcpXFxuICAgICh3aXRoLXJlYWQgY29pbi10YWJsZSBhY2NvdW50XFxuICAgICAgeyBcXFwiYmFsYW5jZVxcXCIgOj0gYmFsYW5jZSB9XFxuICAgICAgYmFsYW5jZVxcbiAgICAgIClcXG4gICAgKVxcblxcbiAgKGRlZnVuIGRldGFpbHM6b2JqZWN0e2Z1bmdpYmxlLXYyLmFjY291bnQtZGV0YWlsc31cXG4gICAgKCBhY2NvdW50OnN0cmluZyApXFxuICAgICh3aXRoLXJlYWQgY29pbi10YWJsZSBhY2NvdW50XFxuICAgICAgeyBcXFwiYmFsYW5jZVxcXCIgOj0gYmFsXFxuICAgICAgLCBcXFwiZ3VhcmRcXFwiIDo9IGcgfVxcbiAgICAgIHsgXFxcImFjY291bnRcXFwiIDogYWNjb3VudFxcbiAgICAgICwgXFxcImJhbGFuY2VcXFwiIDogYmFsXFxuICAgICAgLCBcXFwiZ3VhcmRcXFwiOiBnIH0pXFxuICAgIClcXG5cXG4gIChkZWZ1biByb3RhdGU6c3RyaW5nIChhY2NvdW50OnN0cmluZyBuZXctZ3VhcmQ6Z3VhcmQpXFxuICAgICh3aXRoLWNhcGFiaWxpdHkgKFJPVEFURSBhY2NvdW50KVxcblxcbiAgICAgIDsgQWxsb3cgcm90YXRpb24gb25seSBmb3IgdmFuaXR5IGFjY291bnRzLCBvclxcbiAgICAgIDsgcmUtcm90YXRpbmcgYSBwcmluY2lwYWwgYWNjb3VudCBiYWNrIHRvIGl0cyBwcm9wZXIgZ3VhcmRcXG4gICAgICAoZW5mb3JjZSAob3IgKG5vdCAoaXMtcHJpbmNpcGFsIGFjY291bnQpKVxcbiAgICAgICAgICAgICAgICAgICh2YWxpZGF0ZS1wcmluY2lwYWwgbmV3LWd1YXJkIGFjY291bnQpKVxcbiAgICAgICAgXFxcIkl0IGlzIHVuc2FmZSBmb3IgcHJpbmNpcGFsIGFjY291bnRzIHRvIHJvdGF0ZSB0aGVpciBndWFyZFxcXCIpXFxuXFxuICAgICAgKHdpdGgtcmVhZCBjb2luLXRhYmxlIGFjY291bnRcXG4gICAgICAgIHsgXFxcImd1YXJkXFxcIiA6PSBvbGQtZ3VhcmQgfVxcbiAgICAgICAgKGVuZm9yY2UtZ3VhcmQgb2xkLWd1YXJkKVxcbiAgICAgICAgKHVwZGF0ZSBjb2luLXRhYmxlIGFjY291bnRcXG4gICAgICAgICAgeyBcXFwiZ3VhcmRcXFwiIDogbmV3LWd1YXJkIH1cXG4gICAgICAgICAgKSkpXFxuICAgIClcXG5cXG5cXG4gIChkZWZ1biBwcmVjaXNpb246aW50ZWdlclxcbiAgICAoKVxcbiAgICBNSU5JTVVNX1BSRUNJU0lPTilcXG5cXG4gIChkZWZ1biB0cmFuc2ZlcjpzdHJpbmcgKHNlbmRlcjpzdHJpbmcgcmVjZWl2ZXI6c3RyaW5nIGFtb3VudDpkZWNpbWFsKVxcbiAgICBAbW9kZWwgWyAocHJvcGVydHkgY29uc2VydmVzLW1hc3MpXFxuICAgICAgICAgICAgIChwcm9wZXJ0eSAoPiBhbW91bnQgMC4wKSlcXG4gICAgICAgICAgICAgKHByb3BlcnR5ICh2YWxpZC1hY2NvdW50IHNlbmRlcikpXFxuICAgICAgICAgICAgIChwcm9wZXJ0eSAodmFsaWQtYWNjb3VudCByZWNlaXZlcikpXFxuICAgICAgICAgICAgIChwcm9wZXJ0eSAoIT0gc2VuZGVyIHJlY2VpdmVyKSkgXVxcblxcbiAgICAoZW5mb3JjZSAoIT0gc2VuZGVyIHJlY2VpdmVyKVxcbiAgICAgIFxcXCJzZW5kZXIgY2Fubm90IGJlIHRoZSByZWNlaXZlciBvZiBhIHRyYW5zZmVyXFxcIilcXG5cXG4gICAgKHZhbGlkYXRlLWFjY291bnQgc2VuZGVyKVxcbiAgICAodmFsaWRhdGUtYWNjb3VudCByZWNlaXZlcilcXG5cXG4gICAgKGVuZm9yY2UgKD4gYW1vdW50IDAuMClcXG4gICAgICBcXFwidHJhbnNmZXIgYW1vdW50IG11c3QgYmUgcG9zaXRpdmVcXFwiKVxcblxcbiAgICAoZW5mb3JjZS11bml0IGFtb3VudClcXG5cXG4gICAgKHdpdGgtY2FwYWJpbGl0eSAoVFJBTlNGRVIgc2VuZGVyIHJlY2VpdmVyIGFtb3VudClcXG4gICAgICAoZGViaXQgc2VuZGVyIGFtb3VudClcXG4gICAgICAod2l0aC1yZWFkIGNvaW4tdGFibGUgcmVjZWl2ZXJcXG4gICAgICAgIHsgXFxcImd1YXJkXFxcIiA6PSBnIH1cXG5cXG4gICAgICAgIChjcmVkaXQgcmVjZWl2ZXIgZyBhbW91bnQpKVxcbiAgICAgIClcXG4gICAgKVxcblxcbiAgKGRlZnVuIHRyYW5zZmVyLWNyZWF0ZTpzdHJpbmdcXG4gICAgKCBzZW5kZXI6c3RyaW5nXFxuICAgICAgcmVjZWl2ZXI6c3RyaW5nXFxuICAgICAgcmVjZWl2ZXItZ3VhcmQ6Z3VhcmRcXG4gICAgICBhbW91bnQ6ZGVjaW1hbCApXFxuXFxuICAgIEBtb2RlbCBbIChwcm9wZXJ0eSBjb25zZXJ2ZXMtbWFzcykgXVxcblxcbiAgICAoZW5mb3JjZSAoIT0gc2VuZGVyIHJlY2VpdmVyKVxcbiAgICAgIFxcXCJzZW5kZXIgY2Fubm90IGJlIHRoZSByZWNlaXZlciBvZiBhIHRyYW5zZmVyXFxcIilcXG5cXG4gICAgKHZhbGlkYXRlLWFjY291bnQgc2VuZGVyKVxcbiAgICAodmFsaWRhdGUtYWNjb3VudCByZWNlaXZlcilcXG5cXG4gICAgKGVuZm9yY2UgKD4gYW1vdW50IDAuMClcXG4gICAgICBcXFwidHJhbnNmZXIgYW1vdW50IG11c3QgYmUgcG9zaXRpdmVcXFwiKVxcblxcbiAgICAoZW5mb3JjZS11bml0IGFtb3VudClcXG5cXG4gICAgKHdpdGgtY2FwYWJpbGl0eSAoVFJBTlNGRVIgc2VuZGVyIHJlY2VpdmVyIGFtb3VudClcXG4gICAgICAoZGViaXQgc2VuZGVyIGFtb3VudClcXG4gICAgICAoY3JlZGl0IHJlY2VpdmVyIHJlY2VpdmVyLWd1YXJkIGFtb3VudCkpXFxuICAgIClcXG5cXG4gIChkZWZ1biBjb2luYmFzZTpzdHJpbmcgKGFjY291bnQ6c3RyaW5nIGFjY291bnQtZ3VhcmQ6Z3VhcmQgYW1vdW50OmRlY2ltYWwpXFxuICAgIEBkb2MgXFxcIkludGVybmFsIGZ1bmN0aW9uIGZvciB0aGUgaW5pdGlhbCBjcmVhdGlvbiBvZiBjb2lucy4gIFRoaXMgZnVuY3Rpb24gXFxcXFxcbiAgICBcXFxcY2Fubm90IGJlIHVzZWQgb3V0c2lkZSBvZiB0aGUgY29pbiBjb250cmFjdC5cXFwiXFxuXFxuICAgIEBtb2RlbCBbIChwcm9wZXJ0eSAodmFsaWQtYWNjb3VudCBhY2NvdW50KSlcXG4gICAgICAgICAgICAgKHByb3BlcnR5ICg-IGFtb3VudCAwLjApKVxcbiAgICAgICAgICAgXVxcblxcbiAgICAodmFsaWRhdGUtYWNjb3VudCBhY2NvdW50KVxcbiAgICAoZW5mb3JjZS11bml0IGFtb3VudClcXG5cXG4gICAgKHJlcXVpcmUtY2FwYWJpbGl0eSAoQ09JTkJBU0UpKVxcbiAgICAoZW1pdC1ldmVudCAoVFJBTlNGRVIgXFxcIlxcXCIgYWNjb3VudCBhbW91bnQpKSA7djNcXG4gICAgKHdpdGgtY2FwYWJpbGl0eSAoQ1JFRElUIGFjY291bnQpXFxuICAgICAgKGNyZWRpdCBhY2NvdW50IGFjY291bnQtZ3VhcmQgYW1vdW50KSlcXG4gICAgKVxcblxcbiAgKGRlZnVuIHJlbWVkaWF0ZTpzdHJpbmcgKGFjY291bnQ6c3RyaW5nIGFtb3VudDpkZWNpbWFsKVxcbiAgICBAZG9jIFxcXCJBbGxvd3MgZm9yIHJlbWVkaWF0aW9uIHRyYW5zYWN0aW9ucy4gVGhpcyBmdW5jdGlvbiBcXFxcXFxuICAgICAgICAgXFxcXGlzIHByb3RlY3RlZCBieSB0aGUgUkVNRURJQVRFIGNhcGFiaWxpdHlcXFwiXFxuICAgIEBtb2RlbCBbIChwcm9wZXJ0eSAodmFsaWQtYWNjb3VudCBhY2NvdW50KSlcXG4gICAgICAgICAgICAgKHByb3BlcnR5ICg-IGFtb3VudCAwLjApKVxcbiAgICAgICAgICAgXVxcblxcbiAgICAodmFsaWRhdGUtYWNjb3VudCBhY2NvdW50KVxcblxcbiAgICAoZW5mb3JjZSAoPiBhbW91bnQgMC4wKVxcbiAgICAgIFxcXCJSZW1lZGlhdGlvbiBhbW91bnQgbXVzdCBiZSBwb3NpdGl2ZVxcXCIpXFxuXFxuICAgIChlbmZvcmNlLXVuaXQgYW1vdW50KVxcblxcbiAgICAocmVxdWlyZS1jYXBhYmlsaXR5IChSRU1FRElBVEUpKVxcbiAgICAoZW1pdC1ldmVudCAoVFJBTlNGRVIgXFxcIlxcXCIgYWNjb3VudCBhbW91bnQpKSA7djNcXG4gICAgKHdpdGgtcmVhZCBjb2luLXRhYmxlIGFjY291bnRcXG4gICAgICB7IFxcXCJiYWxhbmNlXFxcIiA6PSBiYWxhbmNlIH1cXG5cXG4gICAgICAoZW5mb3JjZSAoPD0gYW1vdW50IGJhbGFuY2UpIFxcXCJJbnN1ZmZpY2llbnQgZnVuZHNcXFwiKVxcblxcbiAgICAgICh1cGRhdGUgY29pbi10YWJsZSBhY2NvdW50XFxuICAgICAgICB7IFxcXCJiYWxhbmNlXFxcIiA6ICgtIGJhbGFuY2UgYW1vdW50KSB9XFxuICAgICAgICApKVxcbiAgICApXFxuXFxuICAoZGVmcGFjdCBmdW5kLXR4IChzZW5kZXI6c3RyaW5nIG1pbmVyOnN0cmluZyBtaW5lci1ndWFyZDpndWFyZCB0b3RhbDpkZWNpbWFsKVxcbiAgICBAZG9jIFxcXCInZnVuZC10eCcgaXMgYSBzcGVjaWFsIHBhY3QgdG8gZnVuZCBhIHRyYW5zYWN0aW9uIGluIHR3byBzdGVwcywgICAgIFxcXFxcXG4gICAgXFxcXHdpdGggdGhlIGFjdHVhbCB0cmFuc2FjdGlvbiB0cmFuc3BpcmluZyBpbiB0aGUgbWlkZGxlOiAgICAgICAgICAgICAgICAgICBcXFxcXFxuICAgIFxcXFwgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgXFxcXFxcbiAgICBcXFxcICAxKSBBIGJ1eWluZyBwaGFzZSwgZGViaXRpbmcgdGhlIHNlbmRlciBmb3IgdG90YWwgZ2FzIGFuZCBmZWUsIHlpZWxkaW5nIFxcXFxcXG4gICAgXFxcXCAgICAgVFhfTUFYX0NIQVJHRS4gICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICBcXFxcXFxuICAgIFxcXFwgIDIpIEEgc2V0dGxlbWVudCBwaGFzZSwgcmVzdW1pbmcgVFhfTUFYX0NIQVJHRSwgYW5kIGFsbG9jYXRpbmcgdG8gdGhlICAgXFxcXFxcbiAgICBcXFxcICAgICBjb2luYmFzZSBhY2NvdW50IGZvciB1c2VkIGdhcyBhbmQgZmVlLCBhbmQgc2VuZGVyIGFjY291bnQgZm9yIGJhbC0gIFxcXFxcXG4gICAgXFxcXCAgICAgYW5jZSAodW51c2VkIGdhcywgaWYgYW55KS5cXFwiXFxuXFxuICAgIEBtb2RlbCBbIChwcm9wZXJ0eSAoPiB0b3RhbCAwLjApKVxcbiAgICAgICAgICAgICAocHJvcGVydHkgKHZhbGlkLWFjY291bnQgc2VuZGVyKSlcXG4gICAgICAgICAgICAgKHByb3BlcnR5ICh2YWxpZC1hY2NvdW50IG1pbmVyKSlcXG4gICAgICAgICAgICAgOyhwcm9wZXJ0eSBjb25zZXJ2ZXMtbWFzcykgbm90IHN1cHBvcnRlZCB5ZXRcXG4gICAgICAgICAgIF1cXG5cXG4gICAgKHN0ZXAgKGJ1eS1nYXMgc2VuZGVyIHRvdGFsKSlcXG4gICAgKHN0ZXAgKHJlZGVlbS1nYXMgbWluZXIgbWluZXItZ3VhcmQgc2VuZGVyIHRvdGFsKSlcXG4gICAgKVxcblxcbiAgKGRlZnVuIGRlYml0OnN0cmluZyAoYWNjb3VudDpzdHJpbmcgYW1vdW50OmRlY2ltYWwpXFxuICAgIEBkb2MgXFxcIkRlYml0IEFNT1VOVCBmcm9tIEFDQ09VTlQgYmFsYW5jZVxcXCJcXG5cXG4gICAgQG1vZGVsIFsgKHByb3BlcnR5ICg-IGFtb3VudCAwLjApKVxcbiAgICAgICAgICAgICAocHJvcGVydHkgKHZhbGlkLWFjY291bnQgYWNjb3VudCkpXFxuICAgICAgICAgICBdXFxuXFxuICAgICh2YWxpZGF0ZS1hY2NvdW50IGFjY291bnQpXFxuXFxuICAgIChlbmZvcmNlICg-IGFtb3VudCAwLjApXFxuICAgICAgXFxcImRlYml0IGFtb3VudCBtdXN0IGJlIHBvc2l0aXZlXFxcIilcXG5cXG4gICAgKGVuZm9yY2UtdW5pdCBhbW91bnQpXFxuXFxuICAgIChyZXF1aXJlLWNhcGFiaWxpdHkgKERFQklUIGFjY291bnQpKVxcbiAgICAod2l0aC1yZWFkIGNvaW4tdGFibGUgYWNjb3VudFxcbiAgICAgIHsgXFxcImJhbGFuY2VcXFwiIDo9IGJhbGFuY2UgfVxcblxcbiAgICAgIChlbmZvcmNlICg8PSBhbW91bnQgYmFsYW5jZSkgXFxcIkluc3VmZmljaWVudCBmdW5kc1xcXCIpXFxuXFxuICAgICAgKHVwZGF0ZSBjb2luLXRhYmxlIGFjY291bnRcXG4gICAgICAgIHsgXFxcImJhbGFuY2VcXFwiIDogKC0gYmFsYW5jZSBhbW91bnQpIH1cXG4gICAgICAgICkpXFxuICAgIClcXG5cXG5cXG4gIChkZWZ1biBjcmVkaXQ6c3RyaW5nIChhY2NvdW50OnN0cmluZyBndWFyZDpndWFyZCBhbW91bnQ6ZGVjaW1hbClcXG4gICAgQGRvYyBcXFwiQ3JlZGl0IEFNT1VOVCB0byBBQ0NPVU5UIGJhbGFuY2VcXFwiXFxuXFxuICAgIEBtb2RlbCBbIChwcm9wZXJ0eSAoPiBhbW91bnQgMC4wKSlcXG4gICAgICAgICAgICAgKHByb3BlcnR5ICh2YWxpZC1hY2NvdW50IGFjY291bnQpKVxcbiAgICAgICAgICAgXVxcblxcbiAgICAodmFsaWRhdGUtYWNjb3VudCBhY2NvdW50KVxcblxcbiAgICAoZW5mb3JjZSAoPiBhbW91bnQgMC4wKSBcXFwiY3JlZGl0IGFtb3VudCBtdXN0IGJlIHBvc2l0aXZlXFxcIilcXG4gICAgKGVuZm9yY2UtdW5pdCBhbW91bnQpXFxuXFxuICAgIChyZXF1aXJlLWNhcGFiaWxpdHkgKENSRURJVCBhY2NvdW50KSlcXG4gICAgKHdpdGgtZGVmYXVsdC1yZWFkIGNvaW4tdGFibGUgYWNjb3VudFxcbiAgICAgIHsgXFxcImJhbGFuY2VcXFwiIDogLTEuMCwgXFxcImd1YXJkXFxcIiA6IGd1YXJkIH1cXG4gICAgICB7IFxcXCJiYWxhbmNlXFxcIiA6PSBiYWxhbmNlLCBcXFwiZ3VhcmRcXFwiIDo9IHJldGcgfVxcbiAgICAgIDsgd2UgZG9uJ3Qgd2FudCB0byBvdmVyd3JpdGUgYW4gZXhpc3RpbmcgZ3VhcmQgd2l0aCB0aGUgdXNlci1zdXBwbGllZCBvbmVcXG4gICAgICAoZW5mb3JjZSAoPSByZXRnIGd1YXJkKVxcbiAgICAgICAgXFxcImFjY291bnQgZ3VhcmRzIGRvIG5vdCBtYXRjaFxcXCIpXFxuXFxuICAgICAgKGxldCAoKGlzLW5ld1xcbiAgICAgICAgICAgICAoaWYgKD0gYmFsYW5jZSAtMS4wKVxcbiAgICAgICAgICAgICAgICAgKGVuZm9yY2UtcmVzZXJ2ZWQgYWNjb3VudCBndWFyZClcXG4gICAgICAgICAgICAgICBmYWxzZSkpKVxcblxcbiAgICAgICAgKHdyaXRlIGNvaW4tdGFibGUgYWNjb3VudFxcbiAgICAgICAgICB7IFxcXCJiYWxhbmNlXFxcIiA6IChpZiBpcy1uZXcgYW1vdW50ICgrIGJhbGFuY2UgYW1vdW50KSlcXG4gICAgICAgICAgLCBcXFwiZ3VhcmRcXFwiICAgOiByZXRnXFxuICAgICAgICAgIH0pKVxcbiAgICAgICkpXFxuXFxuICAoZGVmdW4gY2hlY2stcmVzZXJ2ZWQ6c3RyaW5nIChhY2NvdW50OnN0cmluZylcXG4gICAgXFxcIiBDaGVja3MgQUNDT1VOVCBmb3IgcmVzZXJ2ZWQgbmFtZSBhbmQgcmV0dXJucyB0eXBlIGlmIFxcXFxcXG4gICAgXFxcXCBmb3VuZCBvciBlbXB0eSBzdHJpbmcuIFJlc2VydmVkIG5hbWVzIHN0YXJ0IHdpdGggYSBcXFxcXFxuICAgIFxcXFwgc2luZ2xlIGNoYXIgYW5kIGNvbG9uLCBlLmcuICdjOmZvbycsIHdoaWNoIHdvdWxkIHJldHVybiAnYycgYXMgdHlwZS5cXFwiXFxuICAgIChsZXQgKChwZnggKHRha2UgMiBhY2NvdW50KSkpXFxuICAgICAgKGlmICg9IFxcXCI6XFxcIiAodGFrZSAtMSBwZngpKSAodGFrZSAxIHBmeCkgXFxcIlxcXCIpKSlcXG5cXG4gIChkZWZ1biBlbmZvcmNlLXJlc2VydmVkOmJvb2wgKGFjY291bnQ6c3RyaW5nIGd1YXJkOmd1YXJkKVxcbiAgICBAZG9jIFxcXCJFbmZvcmNlIHJlc2VydmVkIGFjY291bnQgbmFtZSBwcm90b2NvbHMuXFxcIlxcbiAgICAoaWYgKHZhbGlkYXRlLXByaW5jaXBhbCBndWFyZCBhY2NvdW50KVxcbiAgICAgIHRydWVcXG4gICAgICAobGV0ICgociAoY2hlY2stcmVzZXJ2ZWQgYWNjb3VudCkpKVxcbiAgICAgICAgKGlmICg9IHIgXFxcIlxcXCIpXFxuICAgICAgICAgIHRydWVcXG4gICAgICAgICAgKGlmICg9IHIgXFxcImtcXFwiKVxcbiAgICAgICAgICAgIChlbmZvcmNlIGZhbHNlIFxcXCJTaW5nbGUta2V5IGFjY291bnQgcHJvdG9jb2wgdmlvbGF0aW9uXFxcIilcXG4gICAgICAgICAgICAoZW5mb3JjZSBmYWxzZVxcbiAgICAgICAgICAgICAgKGZvcm1hdCBcXFwiUmVzZXJ2ZWQgcHJvdG9jb2wgZ3VhcmQgdmlvbGF0aW9uOiB7fVxcXCIgW3JdKSlcXG4gICAgICAgICAgICApKSkpKVxcblxcblxcbiAgKGRlZnNjaGVtYSBjcm9zc2NoYWluLXNjaGVtYVxcbiAgICBAZG9jIFxcXCJTY2hlbWEgZm9yIHlpZWxkZWQgdmFsdWUgaW4gY3Jvc3MtY2hhaW4gdHJhbnNmZXJzXFxcIlxcbiAgICByZWNlaXZlcjpzdHJpbmdcXG4gICAgcmVjZWl2ZXItZ3VhcmQ6Z3VhcmRcXG4gICAgYW1vdW50OmRlY2ltYWxcXG4gICAgc291cmNlLWNoYWluOnN0cmluZylcXG5cXG4gIChkZWZwYWN0IHRyYW5zZmVyLWNyb3NzY2hhaW46c3RyaW5nXFxuICAgICggc2VuZGVyOnN0cmluZ1xcbiAgICAgIHJlY2VpdmVyOnN0cmluZ1xcbiAgICAgIHJlY2VpdmVyLWd1YXJkOmd1YXJkXFxuICAgICAgdGFyZ2V0LWNoYWluOnN0cmluZ1xcbiAgICAgIGFtb3VudDpkZWNpbWFsIClcXG5cXG4gICAgQG1vZGVsIFsgKHByb3BlcnR5ICg-IGFtb3VudCAwLjApKVxcbiAgICAgICAgICAgICAocHJvcGVydHkgKHZhbGlkLWFjY291bnQgc2VuZGVyKSlcXG4gICAgICAgICAgICAgKHByb3BlcnR5ICh2YWxpZC1hY2NvdW50IHJlY2VpdmVyKSlcXG4gICAgICAgICAgIF1cXG5cXG4gICAgKHN0ZXBcXG4gICAgICAod2l0aC1jYXBhYmlsaXR5XFxuICAgICAgICAoVFJBTlNGRVJfWENIQUlOIHNlbmRlciByZWNlaXZlciBhbW91bnQgdGFyZ2V0LWNoYWluKVxcblxcbiAgICAgICAgKHZhbGlkYXRlLWFjY291bnQgc2VuZGVyKVxcbiAgICAgICAgKHZhbGlkYXRlLWFjY291bnQgcmVjZWl2ZXIpXFxuXFxuICAgICAgICAoZW5mb3JjZSAoIT0gXFxcIlxcXCIgdGFyZ2V0LWNoYWluKSBcXFwiZW1wdHkgdGFyZ2V0LWNoYWluXFxcIilcXG4gICAgICAgIChlbmZvcmNlICghPSAoYXQgJ2NoYWluLWlkIChjaGFpbi1kYXRhKSkgdGFyZ2V0LWNoYWluKVxcbiAgICAgICAgICBcXFwiY2Fubm90IHJ1biBjcm9zcy1jaGFpbiB0cmFuc2ZlcnMgdG8gdGhlIHNhbWUgY2hhaW5cXFwiKVxcblxcbiAgICAgICAgKGVuZm9yY2UgKD4gYW1vdW50IDAuMClcXG4gICAgICAgICAgXFxcInRyYW5zZmVyIHF1YW50aXR5IG11c3QgYmUgcG9zaXRpdmVcXFwiKVxcblxcbiAgICAgICAgKGVuZm9yY2UtdW5pdCBhbW91bnQpXFxuXFxuICAgICAgICAoZW5mb3JjZSAoY29udGFpbnMgdGFyZ2V0LWNoYWluIFZBTElEX0NIQUlOX0lEUylcXG4gICAgICAgICAgXFxcInRhcmdldCBjaGFpbiBpcyBub3QgYSB2YWxpZCBjaGFpbndlYiBjaGFpbiBpZFxcXCIpXFxuXFxuICAgICAgICA7OyBzdGVwIDEgLSBkZWJpdCBkZWxldGUtYWNjb3VudCBvbiBjdXJyZW50IGNoYWluXFxuICAgICAgICAoZGViaXQgc2VuZGVyIGFtb3VudClcXG4gICAgICAgIChlbWl0LWV2ZW50IChUUkFOU0ZFUiBzZW5kZXIgXFxcIlxcXCIgYW1vdW50KSlcXG5cXG4gICAgICAgIChsZXRcXG4gICAgICAgICAgKChjcm9zc2NoYWluLWRldGFpbHM6b2JqZWN0e2Nyb3NzY2hhaW4tc2NoZW1hfVxcbiAgICAgICAgICAgIHsgXFxcInJlY2VpdmVyXFxcIiA6IHJlY2VpdmVyXFxuICAgICAgICAgICAgLCBcXFwicmVjZWl2ZXItZ3VhcmRcXFwiIDogcmVjZWl2ZXItZ3VhcmRcXG4gICAgICAgICAgICAsIFxcXCJhbW91bnRcXFwiIDogYW1vdW50XFxuICAgICAgICAgICAgLCBcXFwic291cmNlLWNoYWluXFxcIiA6IChhdCAnY2hhaW4taWQgKGNoYWluLWRhdGEpKVxcbiAgICAgICAgICAgIH0pKVxcbiAgICAgICAgICAoeWllbGQgY3Jvc3NjaGFpbi1kZXRhaWxzIHRhcmdldC1jaGFpbilcXG4gICAgICAgICAgKSkpXFxuXFxuICAgIChzdGVwXFxuICAgICAgKHJlc3VtZVxcbiAgICAgICAgeyBcXFwicmVjZWl2ZXJcXFwiIDo9IHJlY2VpdmVyXFxuICAgICAgICAsIFxcXCJyZWNlaXZlci1ndWFyZFxcXCIgOj0gcmVjZWl2ZXItZ3VhcmRcXG4gICAgICAgICwgXFxcImFtb3VudFxcXCIgOj0gYW1vdW50XFxuICAgICAgICAsIFxcXCJzb3VyY2UtY2hhaW5cXFwiIDo9IHNvdXJjZS1jaGFpblxcbiAgICAgICAgfVxcblxcbiAgICAgICAgKGVtaXQtZXZlbnQgKFRSQU5TRkVSIFxcXCJcXFwiIHJlY2VpdmVyIGFtb3VudCkpXFxuICAgICAgICAoZW1pdC1ldmVudCAoVFJBTlNGRVJfWENIQUlOX1JFQ0QgXFxcIlxcXCIgcmVjZWl2ZXIgYW1vdW50IHNvdXJjZS1jaGFpbikpXFxuXFxuICAgICAgICA7OyBzdGVwIDIgLSBjcmVkaXQgY3JlYXRlIGFjY291bnQgb24gdGFyZ2V0IGNoYWluXFxuICAgICAgICAod2l0aC1jYXBhYmlsaXR5IChDUkVESVQgcmVjZWl2ZXIpXFxuICAgICAgICAgIChjcmVkaXQgcmVjZWl2ZXIgcmVjZWl2ZXItZ3VhcmQgYW1vdW50KSlcXG4gICAgICAgICkpXFxuICAgIClcXG5cXG5cXG4gIDsgLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS1cXG4gIDsgQ29pbiBhbGxvY2F0aW9uc1xcblxcbiAgKGRlZnNjaGVtYSBhbGxvY2F0aW9uLXNjaGVtYVxcbiAgICBAZG9jIFxcXCJHZW5lc2lzIGFsbG9jYXRpb24gcmVnaXN0cnlcXFwiXFxuICAgIDtAbW9kZWwgWyAoaW52YXJpYW50ICg-PSBiYWxhbmNlIDAuMCkpIF1cXG5cXG4gICAgYmFsYW5jZTpkZWNpbWFsXFxuICAgIGRhdGU6dGltZVxcbiAgICBndWFyZDpndWFyZFxcbiAgICByZWRlZW1lZDpib29sKVxcblxcbiAgKGRlZnRhYmxlIGFsbG9jYXRpb24tdGFibGU6e2FsbG9jYXRpb24tc2NoZW1hfSlcXG5cXG4gIChkZWZ1biBjcmVhdGUtYWxsb2NhdGlvbi1hY2NvdW50XFxuICAgICggYWNjb3VudDpzdHJpbmdcXG4gICAgICBkYXRlOnRpbWVcXG4gICAgICBrZXlzZXQtcmVmOnN0cmluZ1xcbiAgICAgIGFtb3VudDpkZWNpbWFsXFxuICAgIClcXG5cXG4gICAgQGRvYyBcXFwiQWRkIGFuIGVudHJ5IHRvIHRoZSBjb2luIGFsbG9jYXRpb24gdGFibGUuIFRoaXMgZnVuY3Rpb24gXFxcXFxcbiAgICAgICAgIFxcXFxhbHNvIGNyZWF0ZXMgYSBjb3JyZXNwb25kaW5nIGVtcHR5IGNvaW4gY29udHJhY3QgYWNjb3VudCBcXFxcXFxuICAgICAgICAgXFxcXG9mIHRoZSBzYW1lIG5hbWUgYW5kIGd1YXJkLiBSZXF1aXJlcyBHRU5FU0lTIGNhcGFiaWxpdHkuIFxcXCJcXG5cXG4gICAgQG1vZGVsIFsgKHByb3BlcnR5ICh2YWxpZC1hY2NvdW50IGFjY291bnQpKSBdXFxuXFxuICAgIChyZXF1aXJlLWNhcGFiaWxpdHkgKEdFTkVTSVMpKVxcblxcbiAgICAodmFsaWRhdGUtYWNjb3VudCBhY2NvdW50KVxcbiAgICAoZW5mb3JjZSAoPj0gYW1vdW50IDAuMClcXG4gICAgICBcXFwiYWxsb2NhdGlvbiBhbW91bnQgbXVzdCBiZSBub24tbmVnYXRpdmVcXFwiKVxcblxcbiAgICAoZW5mb3JjZS11bml0IGFtb3VudClcXG5cXG4gICAgKGxldFxcbiAgICAgICgoZ3VhcmQ6Z3VhcmQgKGtleXNldC1yZWYtZ3VhcmQga2V5c2V0LXJlZikpKVxcblxcbiAgICAgIChjcmVhdGUtYWNjb3VudCBhY2NvdW50IGd1YXJkKVxcblxcbiAgICAgIChpbnNlcnQgYWxsb2NhdGlvbi10YWJsZSBhY2NvdW50XFxuICAgICAgICB7IFxcXCJiYWxhbmNlXFxcIiA6IGFtb3VudFxcbiAgICAgICAgLCBcXFwiZGF0ZVxcXCIgOiBkYXRlXFxuICAgICAgICAsIFxcXCJndWFyZFxcXCIgOiBndWFyZFxcbiAgICAgICAgLCBcXFwicmVkZWVtZWRcXFwiIDogZmFsc2VcXG4gICAgICAgIH0pKSlcXG5cXG4gIChkZWZ1biByZWxlYXNlLWFsbG9jYXRpb25cXG4gICAgKCBhY2NvdW50OnN0cmluZyApXFxuXFxuICAgIEBkb2MgXFxcIlJlbGVhc2UgZnVuZHMgYXNzb2NpYXRlZCB3aXRoIGFsbG9jYXRpb24gQUNDT1VOVCBpbnRvIG1haW4gbGVkZ2VyLiAgIFxcXFxcXG4gICAgICAgICBcXFxcQUNDT1VOVCBtdXN0IGFscmVhZHkgZXhpc3QgaW4gbWFpbiBsZWRnZXIuIEFsbG9jYXRpb24gaXMgZGVhY3RpdmF0ZWQgXFxcXFxcbiAgICAgICAgIFxcXFxhZnRlciByZWxlYXNlLlxcXCJcXG4gICAgQG1vZGVsIFsgKHByb3BlcnR5ICh2YWxpZC1hY2NvdW50IGFjY291bnQpKSBdXFxuXFxuICAgICh2YWxpZGF0ZS1hY2NvdW50IGFjY291bnQpXFxuXFxuICAgICh3aXRoLXJlYWQgYWxsb2NhdGlvbi10YWJsZSBhY2NvdW50XFxuICAgICAgeyBcXFwiYmFsYW5jZVxcXCIgOj0gYmFsYW5jZVxcbiAgICAgICwgXFxcImRhdGVcXFwiIDo9IHJlbGVhc2UtdGltZVxcbiAgICAgICwgXFxcInJlZGVlbWVkXFxcIiA6PSByZWRlZW1lZFxcbiAgICAgICwgXFxcImd1YXJkXFxcIiA6PSBndWFyZFxcbiAgICAgIH1cXG5cXG4gICAgICAobGV0ICgoY3Vyci10aW1lOnRpbWUgKGF0ICdibG9jay10aW1lIChjaGFpbi1kYXRhKSkpKVxcblxcbiAgICAgICAgKGVuZm9yY2UgKG5vdCByZWRlZW1lZClcXG4gICAgICAgICAgXFxcImFsbG9jYXRpb24gZnVuZHMgaGF2ZSBhbHJlYWR5IGJlZW4gcmVkZWVtZWRcXFwiKVxcblxcbiAgICAgICAgKGVuZm9yY2VcXG4gICAgICAgICAgKD49IGN1cnItdGltZSByZWxlYXNlLXRpbWUpXFxuICAgICAgICAgIChmb3JtYXQgXFxcImZ1bmRzIGxvY2tlZCB1bnRpbCB7fS4gY3VycmVudCB0aW1lOiB7fVxcXCIgW3JlbGVhc2UtdGltZSBjdXJyLXRpbWVdKSlcXG5cXG4gICAgICAgICh3aXRoLWNhcGFiaWxpdHkgKFJFTEVBU0VfQUxMT0NBVElPTiBhY2NvdW50IGJhbGFuY2UpXFxuXFxuICAgICAgICAoZW5mb3JjZS1ndWFyZCBndWFyZClcXG5cXG4gICAgICAgICh3aXRoLWNhcGFiaWxpdHkgKENSRURJVCBhY2NvdW50KVxcbiAgICAgICAgICAoZW1pdC1ldmVudCAoVFJBTlNGRVIgXFxcIlxcXCIgYWNjb3VudCBiYWxhbmNlKSlcXG4gICAgICAgICAgKGNyZWRpdCBhY2NvdW50IGd1YXJkIGJhbGFuY2UpXFxuXFxuICAgICAgICAgICh1cGRhdGUgYWxsb2NhdGlvbi10YWJsZSBhY2NvdW50XFxuICAgICAgICAgICAgeyBcXFwicmVkZWVtZWRcXFwiIDogdHJ1ZVxcbiAgICAgICAgICAgICwgXFxcImJhbGFuY2VcXFwiIDogMC4wXFxuICAgICAgICAgICAgfSlcXG5cXG4gICAgICAgICAgXFxcIkFsbG9jYXRpb24gc3VjY2Vzc2Z1bGx5IHJlbGVhc2VkIHRvIG1haW4gbGVkZ2VyXFxcIikpXFxuICAgICkpKVxcblxcbilcXG5cXG4oY3JlYXRlLXRhYmxlIGNvaW4tdGFibGUpXFxuKGNyZWF0ZS10YWJsZSBhbGxvY2F0aW9uLXRhYmxlKVxcblwifX0sXCJzaWduZXJzXCI6W10sXCJtZXRhXCI6e1wiY3JlYXRpb25UaW1lXCI6MCxcInR0bFwiOjE3MjgwMCxcImdhc0xpbWl0XCI6MCxcImNoYWluSWRcIjpcIlwiLFwiZ2FzUHJpY2VcIjowLFwic2VuZGVyXCI6XCJcIn0sXCJub25jZVwiOlwiY29pbi1jb250cmFjdC12Ni1pbnN0YWxsXCJ9In0", unsafeFromText "eyJnYXMiOjAsInJlc3VsdCI6eyJzdGF0dXMiOiJzdWNjZXNzIiwiZGF0YSI6IlRhYmxlQ3JlYXRlZCJ9LCJyZXFLZXkiOiJHUklRdTRoQUtrMElEOUY4el8tMHlYeUFLSjMzTVB5VFlNWE9qbFBKbXBJIiwibG9ncyI6IkxKWlA1V2ZFN1VfNGZINWltQm56dE94ZndyWWN0enQtdmNoSkRvUXN2T1EiLCJtZXRhRGF0YSI6bnVsbCwiY29udGludWF0aW9uIjpudWxsLCJ0eElkIjozfQ") + , (unsafeFromText "eyJoYXNoIjoiU0IzVzVFTGl6azl4elNWWk9MX3dsem5VNjh5aUhPQzlwWUhreHBVXzBnbyIsInNpZ3MiOltdLCJjbWQiOiJ7XCJuZXR3b3JrSWRcIjpudWxsLFwicGF5bG9hZFwiOntcImV4ZWNcIjp7XCJkYXRhXCI6bnVsbCxcImNvZGVcIjpcIihpbnRlcmZhY2UgZ2FzLXBheWVyLXYxXFxuXFxuICAoZGVmY2FwIEdBU19QQVlFUjpib29sXFxuICAgICggdXNlcjpzdHJpbmdcXG4gICAgICBsaW1pdDppbnRlZ2VyXFxuICAgICAgcHJpY2U6ZGVjaW1hbFxcbiAgICApXFxuICAgIEBkb2NcXG4gICAgXFxcIiBQcm92aWRlIGEgY2FwYWJpbGl0eSBpbmRpY2F0aW5nIHRoYXQgZGVjbGFyaW5nIG1vZHVsZSBzdXBwb3J0cyBcXFxcXFxuICAgIFxcXFwgZ2FzIHBheW1lbnQgZm9yIFVTRVIgZm9yIGdhcyBMSU1JVCBhbmQgUFJJQ0UuIEZ1bmN0aW9uYWxpdHkgXFxcXFxcbiAgICBcXFxcIHNob3VsZCByZXF1aXJlIGNhcGFiaWxpdHkgKGNvaW4uRlVORF9UWCksIGFuZCBzaG91bGQgdmFsaWRhdGUgXFxcXFxcbiAgICBcXFxcIHRoZSBzcGVuZCBvZiAobGltaXQgKiBwcmljZSksIHBvc3NpYmx5IHVwZGF0aW5nIHNvbWUgZGF0YWJhc2UgXFxcXFxcbiAgICBcXFxcIGVudHJ5LiBcXFxcXFxuICAgIFxcXFwgU2hvdWxkIGNvbXBvc2UgY2FwYWJpbGl0eSByZXF1aXJlZCBmb3IgJ2NyZWF0ZS1nYXMtcGF5ZXItZ3VhcmQnLlxcXCJcXG4gICAgQG1vZGVsXFxuICAgIFsgKHByb3BlcnR5ICh1c2VyICE9IFxcXCJcXFwiKSlcXG4gICAgICAocHJvcGVydHkgKGxpbWl0ID4gMCkpXFxuICAgICAgKHByb3BlcnR5IChwcmljZSA-IDAuMCkpXFxuICAgIF1cXG4gIClcXG5cXG4gIChkZWZ1biBjcmVhdGUtZ2FzLXBheWVyLWd1YXJkOmd1YXJkICgpXFxuICAgIEBkb2NcXG4gICAgXFxcIiBQcm92aWRlIGEgZ3VhcmQgc3VpdGFibGUgZm9yIGNvbnRyb2xsaW5nIGEgY29pbiBhY2NvdW50IHRoYXQgY2FuIFxcXFxcXG4gICAgXFxcXCBwYXkgZ2FzIHZpYSBHQVNfUEFZRVIgbWVjaGFuaWNzLiBHZW5lcmFsbHkgdGhpcyBpcyBhY2NvbXBsaXNoZWQgXFxcXFxcbiAgICBcXFxcIGJ5IGhhdmluZyBHQVNfUEFZRVIgY29tcG9zZSBhbiB1bnBhcmFtZXRlcml6ZWQsIHVubWFuYWdlZCBjYXBhYmlsaXR5IFxcXFxcXG4gICAgXFxcXCB0aGF0IGlzIHJlcXVpcmVkIGluIHRoaXMgZ3VhcmQuIFRodXMsIGlmIGNvaW4gY29udHJhY3QgaXMgYWJsZSB0byBcXFxcXFxuICAgIFxcXFwgc3VjY2Vzc2Z1bGx5IGFjcXVpcmUgR0FTX1BBWUVSLCB0aGUgY29tcG9zZWQgJ2Fub255bW91cycgY2FwIHJlcXVpcmVkIFxcXFxcXG4gICAgXFxcXCBoZXJlIHdpbGwgYmUgaW4gc2NvcGUsIGFuZCBnYXMgYnV5IHdpbGwgc3VjY2VlZC5cXFwiXFxuICApXFxuXFxuKVxcblwifX0sXCJzaWduZXJzXCI6W10sXCJtZXRhXCI6e1wiY3JlYXRpb25UaW1lXCI6MCxcInR0bFwiOjE3MjgwMCxcImdhc0xpbWl0XCI6MCxcImNoYWluSWRcIjpcIlwiLFwiZ2FzUHJpY2VcIjowLFwic2VuZGVyXCI6XCJcIn0sXCJub25jZVwiOlwiZ2VuZXNpcy0wMVwifSJ9", unsafeFromText "eyJnYXMiOjAsInJlc3VsdCI6eyJzdGF0dXMiOiJzdWNjZXNzIiwiZGF0YSI6IkxvYWRlZCBpbnRlcmZhY2UgZ2FzLXBheWVyLXYxLCBoYXNoIGlJV0FQMW9lbl9rcFhqRmJuUU04N0FKUlpJZ3RzZlpjQXdZckV5MjFSV1EifSwicmVxS2V5IjoiU0IzVzVFTGl6azl4elNWWk9MX3dsem5VNjh5aUhPQzlwWUhreHBVXzBnbyIsImxvZ3MiOiJ3TXdXV3hkSFVuU1VOWXJ1RXlISEtTTzUyeGtkVXU0TXBmbE1FcHYyT05FIiwibWV0YURhdGEiOm51bGwsImNvbnRpbnVhdGlvbiI6bnVsbCwidHhJZCI6NH0") + , (unsafeFromText "eyJoYXNoIjoiQ1pteWxXZmllUk1CTXU1dzJFT21wRndLLXQ3YmNPVHM0bUsyYVQzM3VSNCIsInNpZ3MiOltdLCJjbWQiOiJ7XCJuZXR3b3JrSWRcIjpudWxsLFwicGF5bG9hZFwiOntcImV4ZWNcIjp7XCJkYXRhXCI6e1wibnMtYWRtaW4ta2V5c2V0XCI6W1wiMzY4ODIwZjgwYzMyNGJiYzdjMmIwNjEwNjg4YTdkYTQzZTM5ZjkxZDExODczMjY3MWNkOWM3NTAwZmY0M2NjYVwiXSxcIm5zLW9wZXJhdGUta2V5c2V0XCI6W1wiMzY4ODIwZjgwYzMyNGJiYzdjMmIwNjEwNjg4YTdkYTQzZTM5ZjkxZDExODczMjY3MWNkOWM3NTAwZmY0M2NjYVwiXSxcIm5zLWdlbmVzaXMta2V5c2V0XCI6e1wicHJlZFwiOlwiPVwiLFwia2V5c1wiOltdfX0sXCJjb2RlXCI6XCIoZGVmaW5lLWtleXNldCAnbnMtYWRtaW4ta2V5c2V0IChyZWFkLWtleXNldCAnbnMtYWRtaW4ta2V5c2V0KSlcXG4oZGVmaW5lLWtleXNldCAnbnMtb3BlcmF0ZS1rZXlzZXQgKHJlYWQta2V5c2V0ICducy1nZW5lc2lzLWtleXNldCkpXFxuXFxuKG1vZHVsZSBucyBHT1ZFUk5BTkNFXFxuICBcXFwiQWRtaW5pc3RlcnMgZGVmaW5pdGlvbiBvZiBuZXcgbmFtZXNwYWNlcyBpbiBDaGFpbndlYi5cXFwiXFxuXFxuICAoZGVmc2NoZW1hIHJlZy1lbnRyeVxcbiAgICBhZG1pbi1ndWFyZDpndWFyZFxcbiAgICBhY3RpdmU6Ym9vbClcXG5cXG4gIChkZWZ0YWJsZSByZWdpc3RyeTp7cmVnLWVudHJ5fSlcXG5cXG4gIChkZWZjYXAgR09WRVJOQU5DRSAoKVxcbiAgICAoZW5mb3JjZS1rZXlzZXQgJ25zLWFkbWluLWtleXNldCkpXFxuXFxuICAoZGVmY2FwIE9QRVJBVEUgKClcXG4gICAgKGVuZm9yY2Uta2V5c2V0ICducy1vcGVyYXRlLWtleXNldCkpXFxuXFxuICAoZGVmY29uc3QgR1VBUkRfU1VDQ0VTUyAoY3JlYXRlLXVzZXItZ3VhcmQgKHN1Y2Nlc3MpKSlcXG4gIChkZWZjb25zdCBHVUFSRF9GQUlMVVJFIChjcmVhdGUtdXNlci1ndWFyZCAoZmFpbHVyZSkpKVxcblxcbiAgKGRlZnVuIHN1Y2Nlc3MgKClcXG4gICAgdHJ1ZSlcXG4gIChkZWZ1biBmYWlsdXJlICgpXFxuICAgIChlbmZvcmNlIGZhbHNlIFxcXCJEaXNhYmxlZFxcXCIpKVxcblxcbiAgKGRlZnVuIHZhbGlkYXRlLW5hbWUgKG5hbWUpXFxuICAgIChlbmZvcmNlICghPSBcXFwiXFxcIiBuYW1lKSBcXFwiRW1wdHkgbmFtZSBub3QgYWxsb3dlZFxcXCIpXFxuICAgIChlbmZvcmNlICg8IChsZW5ndGggbmFtZSkgNjQpIFxcXCJOYW1lIG11c3QgYmUgbGVzcyB0aGFuIDY0IGNoYXJhY3RlcnMgbG9uZ1xcXCIpXFxuICAgIChlbmZvcmNlIChpcy1jaGFyc2V0IENIQVJTRVRfTEFUSU4xIG5hbWUpXFxuICAgICAgICAgICAgIFxcXCJOYW1lIG11c3QgYmUgaW4gbGF0aW4xIGNoYXJzZXRcXFwiKSlcXG5cXG4gIChkZWZ1biBjcmVhdGUtcHJpbmNpcGFsLW5hbWVzcGFjZTpzdHJpbmdcXG4gICAgICAoIGc6Z3VhcmRcXG4gICAgICAgIClcXG4gICAgXFxcIiBGb3JtYXQgcHJpbmNpcGFsIG5hbWVzcGFjZSBhcyBQYWN0IGhhc2ggKEJMQUtFMmIyNTYpIG9mIHByaW5jaXBhbCBcXFxcXFxuICAgIFxcXFwgaW4gaGV4IHRydW5jYXRlZCB0byAxNjAgYml0cyAoNDAgY2hhcmFjdGVycyksIHByZXBlbmRlZCB3aXRoICduXycuXFxcXFxcbiAgICBcXFxcIE9ubHkgdzogYW5kIGs6IGFjY291bnQgcHJvdG9jb2xzIGFyZSBzdXBwb3J0ZWQuIFxcXCJcXG5cXG4gICAgKGxldFxcbiAgICAgICgodHkgKHR5cGVvZi1wcmluY2lwYWwgKGNyZWF0ZS1wcmluY2lwYWwgZykpKSlcXG5cXG4gICAgICA7OyBvbmx5IHc6IGFuZCBrOiBjdXJyZW50bHkgc3VwcG9ydGVkXFxuICAgICAgKGlmIChvciAoPSB0eSBcXFwiazpcXFwiKSAoPSB0eSBcXFwidzpcXFwiKSlcXG4gICAgICAgICgrIFxcXCJuX1xcXCIgKHRha2UgNDAgKGludC10by1zdHIgMTYgKHN0ci10by1pbnQgNjQgKGhhc2ggZykpKSkpXFxuICAgICAgICAoZW5mb3JjZSBmYWxzZVxcbiAgICAgICAgICAoZm9ybWF0IFxcXCJVbnN1cHBvcnRlZCBndWFyZCBwcm90b2NvbDoge31cXFwiIFt0eV0pKVxcbiAgICAgICAgKSlcXG4gIClcXG5cXG4gIChkZWZ1biB2YWxpZGF0ZTpib29sXFxuICAgICAgKCBucy1uYW1lOnN0cmluZ1xcbiAgICAgICAgbnMtYWRtaW46Z3VhcmRcXG4gICAgICAgIClcXG4gICAgXFxcIiBNYW5hZ2VzIG5hbWVzcGFjZSBpbnN0YWxsIGZvciBDaGFpbndlYi4gXFxcXFxcbiAgICBcXFxcIEFsbG93cyBwcmluY2lwYWwgbmFtZXNwYWNlcy4gXFxcXFxcbiAgICBcXFxcIE5vbi1wcmluY2lwYWwgbmFtZXNwYWNlcyByZXF1aXJlIGFjdGl2ZSByb3cgaW4gcmVnaXN0cnkgXFxcXFxcbiAgICBcXFxcIGZvciBOUy1OQU1FIHdpdGggZ3VhcmQgbWF0Y2hpbmcgTlMtQURNSU4uXFxcIlxcblxcbiAgICAoaWYgKD0gKGNyZWF0ZS1wcmluY2lwYWwtbmFtZXNwYWNlIG5zLWFkbWluKSBucy1uYW1lKVxcblxcbiAgICAgIHRydWUgOzsgYWxsb3cgcHJpbmNpcGFsIG5hbWVzcGFjZXNcXG5cXG4gICAgICAod2l0aC1kZWZhdWx0LXJlYWQgcmVnaXN0cnkgbnMtbmFtZSAgICAgICA7OyBvdGhlcndpc2UgZW5mb3JjZSByZWdpc3RyeVxcbiAgICAgICAgeyAnYWRtaW4tZ3VhcmQgOiBucy1hZG1pblxcbiAgICAgICAgLCAnYWN0aXZlIDogZmFsc2UgfVxcbiAgICAgICAgeyAnYWRtaW4tZ3VhcmQgOj0gYWdcXG4gICAgICAgICwgJ2FjdGl2ZSA6PSBpcy1hY3RpdmUgfVxcblxcbiAgICAgICAgKGVuZm9yY2UgaXMtYWN0aXZlIFxcXCJJbmFjdGl2ZSBvciB1bnJlZ2lzdGVyZWQgbmFtZXNwYWNlXFxcIilcXG4gICAgICAgIChlbmZvcmNlICg9IG5zLWFkbWluIGFnKSBcXFwiQWRtaW4gZ3VhcmQgbXVzdCBtYXRjaCBndWFyZCBpbiByZWdpc3RyeVxcXCIpXFxuXFxuICAgICAgICB0cnVlKVxcbiAgICAgICkpXFxuXFxuICAoZGVmdW4gd3JpdGUtcmVnaXN0cnk6c3RyaW5nXFxuICAgICAgKCBucy1uYW1lOnN0cmluZ1xcbiAgICAgICAgZ3VhcmQ6Z3VhcmRcXG4gICAgICAgIGFjdGl2ZTpib29sXFxuICAgICAgICApXFxuICAgIFxcXCIgV3JpdGUgZW50cnkgd2l0aCBHVUFSRCBhbmQgQUNUSVZFIGludG8gcmVnaXN0cnkgZm9yIE5BTUUuIFxcXFxcXG4gICAgXFxcXCBHdWFyZGVkIGJ5IG9wZXJhdGUga2V5c2V0LiBcXFwiXFxuXFxuICAgICh3aXRoLWNhcGFiaWxpdHkgKE9QRVJBVEUpXFxuXFxuICAgICAgKHZhbGlkYXRlLW5hbWUgbnMtbmFtZSlcXG5cXG4gICAgICAod3JpdGUgcmVnaXN0cnkgbnMtbmFtZVxcbiAgICAgICAgeyAnYWRtaW4tZ3VhcmQ6IGd1YXJkXFxuICAgICAgICAsICdhY3RpdmU6IGFjdGl2ZSB9KVxcblxcbiAgICAgIFxcXCJSZWdpc3RlciBlbnRyeSB3cml0dGVuXFxcIikpXFxuXFxuICAoZGVmdW4gcXVlcnk6b2JqZWN0e3JlZy1lbnRyeX1cXG4gICAgICAoIG5zLW5hbWU6c3RyaW5nIClcXG4gICAgKHJlYWQgcmVnaXN0cnkgbnMtbmFtZSkpXFxuXFxuKVxcblxcbihjcmVhdGUtdGFibGUgcmVnaXN0cnkpXFxuXFxuKHdyaXRlLXJlZ2lzdHJ5IFxcXCJrYWRlbmFcXFwiXFxuICAoa2V5c2V0LXJlZi1ndWFyZCAnbnMtb3BlcmF0ZS1rZXlzZXQpIHRydWUpXFxuKHdyaXRlLXJlZ2lzdHJ5IFxcXCJ1c2VyXFxcIiBHVUFSRF9GQUlMVVJFIHRydWUpXFxuKHdyaXRlLXJlZ2lzdHJ5IFxcXCJmcmVlXFxcIiBHVUFSRF9GQUlMVVJFIHRydWUpXFxuXFxuKGRlZmluZS1uYW1lc3BhY2UgXFxcImthZGVuYVxcXCJcXG4gIChrZXlzZXQtcmVmLWd1YXJkICducy1vcGVyYXRlLWtleXNldClcXG4gIChrZXlzZXQtcmVmLWd1YXJkICducy1vcGVyYXRlLWtleXNldCkpXFxuXFxuKGRlZmluZS1uYW1lc3BhY2UgXFxcInVzZXJcXFwiIEdVQVJEX1NVQ0NFU1MgR1VBUkRfRkFJTFVSRSlcXG4oZGVmaW5lLW5hbWVzcGFjZSBcXFwiZnJlZVxcXCIgR1VBUkRfU1VDQ0VTUyBHVUFSRF9GQUlMVVJFKVxcbjs7cm90YXRlIHRvIHJlYWwgb3BlcmF0ZSBrZXlzZXRcXG4oZGVmaW5lLWtleXNldCAnbnMtb3BlcmF0ZS1rZXlzZXQgKHJlYWQta2V5c2V0ICducy1vcGVyYXRlLWtleXNldCkpXFxuXCJ9fSxcInNpZ25lcnNcIjpbXSxcIm1ldGFcIjp7XCJjcmVhdGlvblRpbWVcIjowLFwidHRsXCI6MTcyODAwLFwiZ2FzTGltaXRcIjowLFwiY2hhaW5JZFwiOlwiXCIsXCJnYXNQcmljZVwiOjAsXCJzZW5kZXJcIjpcIlwifSxcIm5vbmNlXCI6XCJsb2FkLW5zLWRldm5ldC1zZW5kZXIwMFwifSJ9", unsafeFromText "eyJnYXMiOjAsInJlc3VsdCI6eyJzdGF0dXMiOiJzdWNjZXNzIiwiZGF0YSI6IktleXNldCB3cml0ZSBzdWNjZXNzIn0sInJlcUtleSI6IkNabXlsV2ZpZVJNQk11NXcyRU9tcEZ3Sy10N2JjT1RzNG1LMmFUMzN1UjQiLCJsb2dzIjoidDdzQzg1Y1hlWFdSdG90M1lEb2pSejZibWtncEN6enJQQ0Z6QThzTkg3OCIsIm1ldGFEYXRhIjpudWxsLCJjb250aW51YXRpb24iOm51bGwsInR4SWQiOjV9") + , (unsafeFromText "eyJoYXNoIjoiWE5BNmxPSjFXLTdYWXY1WWI0QXFsNzRveFlJN09KcWpPUVQ1b1k0OHEtZyIsInNpZ3MiOltdLCJjbWQiOiJ7XCJuZXR3b3JrSWRcIjpudWxsLFwicGF5bG9hZFwiOntcImV4ZWNcIjp7XCJkYXRhXCI6e1wiYWxsb2NhdGlvbi10ZXN0MDFcIjpbXCI3MDExYzM3OTE0MGZmODk5ZjdlNjEzYWMwYTk3ODRhN2MwYTUxNWQzMGZlMGFiMmIwYzA3ZTVhYTE3NjM1ZTNlXCJdLFwiYWxsb2NhdGlvbjAyXCI6W1wiZTllNGU3MWJkMDYzZGNmN2UwNmJkNWIxYTE2Njg4ODk3ZDE1Y2E4YmQyZTUwOWM0NTNjNjE2MjE5YzE4NmNjNVwiXSxcImFsbG9jYXRpb24wMFwiOltcImQ4MmQwZGNkZTk4MjU1MDVkODZhZmI2ZGNjMTA0MTFkNmI2N2E0MjlhNzllMjFiZGE0YmIxMTliZjI4YWI4NzFcIl0sXCJhbGxvY2F0aW9uLXRlc3QwMlwiOltcIjA2NTQ0ZTIyYmZlZjIzMGQ2ZDIyZjk0ODZhYzZjYjc2YmYyNThlYmZiZjAxMzdlZTU4ZjY1NzQzZTFhNWI4YzRcIl0sXCJhbGxvY2F0aW9uMDFcIjpbXCJiNGM4YTNlYTkxZDMxNDZiMDU2MDk5NDc0MGYwZTNlZWQ5MWM1OWQyZWVjYTFkYzk5ZjBjMjg3Mjg0NWMyOTRkXCJdfSxcImNvZGVcIjpcIihkZWZpbmUta2V5c2V0IFxcXCJhbGxvY2F0aW9uMDBcXFwiIChyZWFkLWtleXNldCBcXFwiYWxsb2NhdGlvbjAwXFxcIikpXFxuKGRlZmluZS1rZXlzZXQgXFxcImFsbG9jYXRpb24wMVxcXCIgKHJlYWQta2V5c2V0IFxcXCJhbGxvY2F0aW9uMDFcXFwiKSlcXG4oZGVmaW5lLWtleXNldCBcXFwiYWxsb2NhdGlvbjAyXFxcIiAocmVhZC1rZXlzZXQgXFxcImFsbG9jYXRpb24wMlxcXCIpKVxcbihkZWZpbmUta2V5c2V0IFxcXCJhbGxvY2F0aW9uLXRlc3QwMVxcXCIgKHJlYWQta2V5c2V0IFxcXCJhbGxvY2F0aW9uLXRlc3QwMVxcXCIpKVxcbihkZWZpbmUta2V5c2V0IFxcXCJhbGxvY2F0aW9uLXRlc3QwMlxcXCIgKHJlYWQta2V5c2V0IFxcXCJhbGxvY2F0aW9uLXRlc3QwMlxcXCIpKVwifX0sXCJzaWduZXJzXCI6W10sXCJtZXRhXCI6e1wiY3JlYXRpb25UaW1lXCI6MCxcInR0bFwiOjE3MjgwMCxcImdhc0xpbWl0XCI6MCxcImNoYWluSWRcIjpcIlwiLFwiZ2FzUHJpY2VcIjowLFwic2VuZGVyXCI6XCJcIn0sXCJub25jZVwiOlwiZGV2bmV0LWtleXNldHNcIn0ifQ", unsafeFromText "eyJnYXMiOjAsInJlc3VsdCI6eyJzdGF0dXMiOiJzdWNjZXNzIiwiZGF0YSI6IktleXNldCB3cml0ZSBzdWNjZXNzIn0sInJlcUtleSI6IlhOQTZsT0oxVy03WFl2NVliNEFxbDc0b3hZSTdPSnFqT1FUNW9ZNDhxLWciLCJsb2dzIjoiYXJRSWpQVGRrcXhoQTNjWl9WaVE3OXM3Uk5XRTlGV2Rha0xWdXl4Nlc0YyIsIm1ldGFEYXRhIjpudWxsLCJjb250aW51YXRpb24iOm51bGwsInR4SWQiOjZ9") + , (unsafeFromText "eyJoYXNoIjoiNWtxZ0tzWWtwbjZCcS1KUnhNYnA1VG9jUWhRWGRJVVNiM1NGQm1Ba3VWcyIsInNpZ3MiOltdLCJjbWQiOiJ7XCJuZXR3b3JrSWRcIjpudWxsLFwicGF5bG9hZFwiOntcImV4ZWNcIjp7XCJkYXRhXCI6bnVsbCxcImNvZGVcIjpcIihjb2luLmNyZWF0ZS1hbGxvY2F0aW9uLWFjY291bnQgXFxcImFsbG9jYXRpb24wMFxcXCIgKHRpbWUgXFxcIjE5MDAtMTAtMTVUMTg6MDA6MDBaXFxcIikgXFxcImFsbG9jYXRpb24wMFxcXCIgMTAwMDAwMC4wKVxcbihjb2luLmNyZWF0ZS1hbGxvY2F0aW9uLWFjY291bnQgXFxcImFsbG9jYXRpb24wMVxcXCIgKHRpbWUgXFxcIjIxMDAtMTAtMzFUMTg6MDA6MDBaXFxcIikgXFxcImFsbG9jYXRpb24wMVxcXCIgMTAwMDAwMC4wKVxcbihjb2luLmNyZWF0ZS1hbGxvY2F0aW9uLWFjY291bnQgXFxcImFsbG9jYXRpb24wMlxcXCIgKHRpbWUgXFxcIjE5MDAtMTAtMzFUMTg6MDA6MDBaXFxcIikgXFxcImFsbG9jYXRpb24wMlxcXCIgMTAwMDAwMC4wKVxcbihjb2luLmNyZWF0ZS1hbGxvY2F0aW9uLWFjY291bnQgXFxcImFsbG9jYXRpb24tdGVzdDAxXFxcIiAodGltZSBcXFwiMTkwMC0xMC0zMVQxODowMDowMFpcXFwiKSBcXFwiYWxsb2NhdGlvbi10ZXN0MDFcXFwiIDEwMDAwMDAuMClcXG4oY29pbi5jcmVhdGUtYWxsb2NhdGlvbi1hY2NvdW50IFxcXCJhbGxvY2F0aW9uLXRlc3QwMlxcXCIgKHRpbWUgXFxcIjE5MDAtMTAtMzFUMTg6MDA6MDBaXFxcIikgXFxcImFsbG9jYXRpb24tdGVzdDAyXFxcIiAyMDAwMDAwLjApXCJ9fSxcInNpZ25lcnNcIjpbXSxcIm1ldGFcIjp7XCJjcmVhdGlvblRpbWVcIjowLFwidHRsXCI6MTcyODAwLFwiZ2FzTGltaXRcIjowLFwiY2hhaW5JZFwiOlwiXCIsXCJnYXNQcmljZVwiOjAsXCJzZW5kZXJcIjpcIlwifSxcIm5vbmNlXCI6XCJkZXZuZXQtYWxsb2NhdGlvbnNcIn0ifQ", unsafeFromText "eyJnYXMiOjAsInJlc3VsdCI6eyJzdGF0dXMiOiJzdWNjZXNzIiwiZGF0YSI6IldyaXRlIHN1Y2NlZWRlZCJ9LCJyZXFLZXkiOiI1a3FnS3NZa3BuNkJxLUpSeE1icDVUb2NRaFFYZElVU2IzU0ZCbUFrdVZzIiwibG9ncyI6IkhpX3ZfVEhFT2s2aEJFRU0yWmV2Vzh3eVJsQWpUZzNjVUQydXBlVkx0b1UiLCJtZXRhRGF0YSI6bnVsbCwiY29udGludWF0aW9uIjpudWxsLCJ0eElkIjo3fQ") + , (unsafeFromText "eyJoYXNoIjoibWd3Z3lCdTRGS3NEQ042Q3dWOEJNcFdNcnBwb2UtVkJKYTFYRjktLTFQRSIsInNpZ3MiOltdLCJjbWQiOiJ7XCJuZXR3b3JrSWRcIjpudWxsLFwicGF5bG9hZFwiOntcImV4ZWNcIjp7XCJkYXRhXCI6e1wic2VuZGVyMDdcIjpbXCI0YzMxZGM5ZWU3ZjI0MTc3Zjc4YjZmNTE4MDEyYTIwODMyNmUyYWYxZjM3YmIwYTI0MDViNTA1NmQwY2FkNjI4XCJdLFwic2VuZGVyMDFcIjpbXCI2YmUyZjQ4NWE3YWY3NWZlZGI0YjdmMTUzYTkwM2Y3ZTYwMDBjYTRhYTUwMTE3OWM5MWEyNDUwYjc3N2JkMmE3XCJdLFwic2VuZGVyMDZcIjpbXCI1ZmZjMWY3ZmVmN2E0NDczODYyNTc2MmY3NWE0MjI5NDU0OTUxZTAzZjJhZmM2ZjgxMzA5YzBjMWJkZjllZTZmXCJdLFwic2VuZGVyMDBcIjpbXCIzNjg4MjBmODBjMzI0YmJjN2MyYjA2MTA2ODhhN2RhNDNlMzlmOTFkMTE4NzMyNjcxY2Q5Yzc1MDBmZjQzY2NhXCJdLFwiZTdmN1wiOltcImU3Zjc2MzRlOTI1NTQxZjM2OGI4MjdhZDVjNzI0MjE5MDUxMDBmNjIwNTI4NWE3OGMxOWQ3YjRhMzg3MTE4MDVcIl0sXCJzZW5kZXIwNVwiOltcImYwOWQ4ZjYzOTRhZWE0MjVmZTY3ODNkODhjZDgxMzYzZDgwMTdmMTZhZmQzNzExYzU3NWJlMGY1Y2Q1YzliYjlcIl0sXCJzZW5kZXIwNFwiOltcIjJkNzBhYTRmNjk3YzNhM2I4ZGQ2ZDk3NzQ1YWMwNzRlZGNmZDBlYjY1YzM3Nzc0Y2RlMjUxMzU0ODNiZWE3MWVcIl0sXCJtdWx0aS0wMi0wMy0wNC1hbnlcIjp7XCJwcmVkXCI6XCJrZXlzLWFueVwiLFwia2V5c1wiOltcIjJkNzBhYTRmNjk3YzNhM2I4ZGQ2ZDk3NzQ1YWMwNzRlZGNmZDBlYjY1YzM3Nzc0Y2RlMjUxMzU0ODNiZWE3MWVcIixcIjNhOWRkNTMyZDczZGFjZTE5NWRiYjY0ZDFkYmE2NTcyZmI3ODNkMGZkZDMyNDY4NWUzMmZiZGEyZjg5Zjk5YTZcIixcIjQzZjJhZGIxZGUxOTIwMDBjYjM3NzdiYWNjN2Y5ODNiNjYxNGZkOWMxNzE1Y2Q0NGNkNDg0YjZkM2EwZDM0YzhcIl19LFwic2VuZGVyMDlcIjpbXCJjNTlkOTg0MGIwYjY2MDkwODM2NTQ2YjdlYjRhNzM2MDYyNTc1MjdlYzhjMmI0ODIzMDBmZDIyOTI2NGIwN2U2XCJdLFwic2VuZGVyMDNcIjpbXCI0M2YyYWRiMWRlMTkyMDAwY2IzNzc3YmFjYzdmOTgzYjY2MTRmZDljMTcxNWNkNDRjZDQ4NGI2ZDNhMGQzNGM4XCJdLFwibXVsdGktMDAtMDFcIjpbXCIzNjg4MjBmODBjMzI0YmJjN2MyYjA2MTA2ODhhN2RhNDNlMzlmOTFkMTE4NzMyNjcxY2Q5Yzc1MDBmZjQzY2NhXCIsXCI2YmUyZjQ4NWE3YWY3NWZlZGI0YjdmMTUzYTkwM2Y3ZTYwMDBjYTRhYTUwMTE3OWM5MWEyNDUwYjc3N2JkMmE3XCJdLFwic2VuZGVyMDhcIjpbXCI2M2IyZWJhNGVkNzBkNDYxMmQzZTdiYzkwZGIyZmJmNGM3NmY3YjA3NDM2M2U4NmQ3M2YwYmM2MTdmOGU4YjgxXCJdLFwic2VuZGVyMDJcIjpbXCIzYTlkZDUzMmQ3M2RhY2UxOTVkYmI2NGQxZGJhNjU3MmZiNzgzZDBmZGQzMjQ2ODVlMzJmYmRhMmY4OWY5OWE2XCJdfSxcImNvZGVcIjpcIihjb2luLmNvaW5iYXNlIFxcXCJzZW5kZXIwMFxcXCIgKHJlYWQta2V5c2V0IFxcXCJzZW5kZXIwMFxcXCIpIDEwMDAwMDAwMC4wKVxcbihjb2luLmNvaW5iYXNlIFxcXCJzZW5kZXIwMVxcXCIgKHJlYWQta2V5c2V0IFxcXCJzZW5kZXIwMVxcXCIpIDExMDAwMDAwMC4wKVxcbihjb2luLmNvaW5iYXNlIFxcXCJzZW5kZXIwMlxcXCIgKHJlYWQta2V5c2V0IFxcXCJzZW5kZXIwMlxcXCIpIDEyMDAwMDAwMC4wKVxcbihjb2luLmNvaW5iYXNlIFxcXCJzZW5kZXIwM1xcXCIgKHJlYWQta2V5c2V0IFxcXCJzZW5kZXIwM1xcXCIpIDEzMDAwMDAwMC4wKVxcbihjb2luLmNvaW5iYXNlIFxcXCJzZW5kZXIwNFxcXCIgKHJlYWQta2V5c2V0IFxcXCJzZW5kZXIwNFxcXCIpIDE0MDAwMDAwMC4wKVxcbihjb2luLmNvaW5iYXNlIFxcXCJzZW5kZXIwNVxcXCIgKHJlYWQta2V5c2V0IFxcXCJzZW5kZXIwNVxcXCIpIDE1MDAwMDAwMC4wKVxcbihjb2luLmNvaW5iYXNlIFxcXCJzZW5kZXIwNlxcXCIgKHJlYWQta2V5c2V0IFxcXCJzZW5kZXIwNlxcXCIpIDE2MDAwMDAwMC4wKVxcbihjb2luLmNvaW5iYXNlIFxcXCJzZW5kZXIwN1xcXCIgKHJlYWQta2V5c2V0IFxcXCJzZW5kZXIwN1xcXCIpIDE3MDAwMDAwMC4wKVxcbihjb2luLmNvaW5iYXNlIFxcXCJzZW5kZXIwOFxcXCIgKHJlYWQta2V5c2V0IFxcXCJzZW5kZXIwOFxcXCIpIDE4MDAwMDAwMC4wKVxcbihjb2luLmNvaW5iYXNlIFxcXCJzZW5kZXIwOVxcXCIgKHJlYWQta2V5c2V0IFxcXCJzZW5kZXIwOVxcXCIpIDE5MDAwMDAwMC4wKVxcbihjb2luLmNvaW5iYXNlIFxcXCJtdWx0aS0wMC0wMVxcXCIgKHJlYWQta2V5c2V0IFxcXCJtdWx0aS0wMC0wMVxcXCIpIDEwMTAwMDAwMC4wKVxcbihjb2luLmNvaW5iYXNlIFxcXCJtdWx0aS0wMi0wMy0wNC1hbnlcXFwiIChyZWFkLWtleXNldCBcXFwibXVsdGktMDItMDMtMDQtYW55XFxcIikgMTIzNDAwMDAwLjApXFxuXFxuKGNvaW4uY29pbmJhc2UgXFxcImU3Zjc2MzRlOTI1NTQxZjM2OGI4MjdhZDVjNzI0MjE5MDUxMDBmNjIwNTI4NWE3OGMxOWQ3YjRhMzg3MTE4MDVcXFwiIChyZWFkLWtleXNldCBcXFwiZTdmN1xcXCIpIDE1MC4wKVwifX0sXCJzaWduZXJzXCI6W10sXCJtZXRhXCI6e1wiY3JlYXRpb25UaW1lXCI6MCxcInR0bFwiOjE3MjgwMCxcImdhc0xpbWl0XCI6MCxcImNoYWluSWRcIjpcIlwiLFwiZ2FzUHJpY2VcIjowLFwic2VuZGVyXCI6XCJcIn0sXCJub25jZVwiOlwiZGV2bmV0LWdyYW50c05cIn0ifQ", unsafeFromText "eyJnYXMiOjAsInJlc3VsdCI6eyJzdGF0dXMiOiJzdWNjZXNzIiwiZGF0YSI6IldyaXRlIHN1Y2NlZWRlZCJ9LCJyZXFLZXkiOiJtZ3dneUJ1NEZLc0RDTjZDd1Y4Qk1wV01ycHBvZS1WQkphMVhGOS0tMVBFIiwibG9ncyI6IkF3MTVuVFF0YmlQYlVCQm1reGpRV09JZlc3ZHNfUi1sWjhNMGZDMXAxZHciLCJldmVudHMiOlt7InBhcmFtcyI6WyIiLCJzZW5kZXIwMCIsMTAwMDAwMDAwXSwibmFtZSI6IlRSQU5TRkVSIiwibW9kdWxlIjp7Im5hbWVzcGFjZSI6bnVsbCwibmFtZSI6ImNvaW4ifSwibW9kdWxlSGFzaCI6IjNpSUJRZEpuc3Q0NFoyWmdYb0hQa0FhdXliSjBoODVsX2VuX1NHSE5pYkUifSx7InBhcmFtcyI6WyIiLCJzZW5kZXIwMSIsMTEwMDAwMDAwXSwibmFtZSI6IlRSQU5TRkVSIiwibW9kdWxlIjp7Im5hbWVzcGFjZSI6bnVsbCwibmFtZSI6ImNvaW4ifSwibW9kdWxlSGFzaCI6IjNpSUJRZEpuc3Q0NFoyWmdYb0hQa0FhdXliSjBoODVsX2VuX1NHSE5pYkUifSx7InBhcmFtcyI6WyIiLCJzZW5kZXIwMiIsMTIwMDAwMDAwXSwibmFtZSI6IlRSQU5TRkVSIiwibW9kdWxlIjp7Im5hbWVzcGFjZSI6bnVsbCwibmFtZSI6ImNvaW4ifSwibW9kdWxlSGFzaCI6IjNpSUJRZEpuc3Q0NFoyWmdYb0hQa0FhdXliSjBoODVsX2VuX1NHSE5pYkUifSx7InBhcmFtcyI6WyIiLCJzZW5kZXIwMyIsMTMwMDAwMDAwXSwibmFtZSI6IlRSQU5TRkVSIiwibW9kdWxlIjp7Im5hbWVzcGFjZSI6bnVsbCwibmFtZSI6ImNvaW4ifSwibW9kdWxlSGFzaCI6IjNpSUJRZEpuc3Q0NFoyWmdYb0hQa0FhdXliSjBoODVsX2VuX1NHSE5pYkUifSx7InBhcmFtcyI6WyIiLCJzZW5kZXIwNCIsMTQwMDAwMDAwXSwibmFtZSI6IlRSQU5TRkVSIiwibW9kdWxlIjp7Im5hbWVzcGFjZSI6bnVsbCwibmFtZSI6ImNvaW4ifSwibW9kdWxlSGFzaCI6IjNpSUJRZEpuc3Q0NFoyWmdYb0hQa0FhdXliSjBoODVsX2VuX1NHSE5pYkUifSx7InBhcmFtcyI6WyIiLCJzZW5kZXIwNSIsMTUwMDAwMDAwXSwibmFtZSI6IlRSQU5TRkVSIiwibW9kdWxlIjp7Im5hbWVzcGFjZSI6bnVsbCwibmFtZSI6ImNvaW4ifSwibW9kdWxlSGFzaCI6IjNpSUJRZEpuc3Q0NFoyWmdYb0hQa0FhdXliSjBoODVsX2VuX1NHSE5pYkUifSx7InBhcmFtcyI6WyIiLCJzZW5kZXIwNiIsMTYwMDAwMDAwXSwibmFtZSI6IlRSQU5TRkVSIiwibW9kdWxlIjp7Im5hbWVzcGFjZSI6bnVsbCwibmFtZSI6ImNvaW4ifSwibW9kdWxlSGFzaCI6IjNpSUJRZEpuc3Q0NFoyWmdYb0hQa0FhdXliSjBoODVsX2VuX1NHSE5pYkUifSx7InBhcmFtcyI6WyIiLCJzZW5kZXIwNyIsMTcwMDAwMDAwXSwibmFtZSI6IlRSQU5TRkVSIiwibW9kdWxlIjp7Im5hbWVzcGFjZSI6bnVsbCwibmFtZSI6ImNvaW4ifSwibW9kdWxlSGFzaCI6IjNpSUJRZEpuc3Q0NFoyWmdYb0hQa0FhdXliSjBoODVsX2VuX1NHSE5pYkUifSx7InBhcmFtcyI6WyIiLCJzZW5kZXIwOCIsMTgwMDAwMDAwXSwibmFtZSI6IlRSQU5TRkVSIiwibW9kdWxlIjp7Im5hbWVzcGFjZSI6bnVsbCwibmFtZSI6ImNvaW4ifSwibW9kdWxlSGFzaCI6IjNpSUJRZEpuc3Q0NFoyWmdYb0hQa0FhdXliSjBoODVsX2VuX1NHSE5pYkUifSx7InBhcmFtcyI6WyIiLCJzZW5kZXIwOSIsMTkwMDAwMDAwXSwibmFtZSI6IlRSQU5TRkVSIiwibW9kdWxlIjp7Im5hbWVzcGFjZSI6bnVsbCwibmFtZSI6ImNvaW4ifSwibW9kdWxlSGFzaCI6IjNpSUJRZEpuc3Q0NFoyWmdYb0hQa0FhdXliSjBoODVsX2VuX1NHSE5pYkUifSx7InBhcmFtcyI6WyIiLCJtdWx0aS0wMC0wMSIsMTAxMDAwMDAwXSwibmFtZSI6IlRSQU5TRkVSIiwibW9kdWxlIjp7Im5hbWVzcGFjZSI6bnVsbCwibmFtZSI6ImNvaW4ifSwibW9kdWxlSGFzaCI6IjNpSUJRZEpuc3Q0NFoyWmdYb0hQa0FhdXliSjBoODVsX2VuX1NHSE5pYkUifSx7InBhcmFtcyI6WyIiLCJtdWx0aS0wMi0wMy0wNC1hbnkiLDEyMzQwMDAwMF0sIm5hbWUiOiJUUkFOU0ZFUiIsIm1vZHVsZSI6eyJuYW1lc3BhY2UiOm51bGwsIm5hbWUiOiJjb2luIn0sIm1vZHVsZUhhc2giOiIzaUlCUWRKbnN0NDRaMlpnWG9IUGtBYXV5YkowaDg1bF9lbl9TR0hOaWJFIn0seyJwYXJhbXMiOlsiIiwiZTdmNzYzNGU5MjU1NDFmMzY4YjgyN2FkNWM3MjQyMTkwNTEwMGY2MjA1Mjg1YTc4YzE5ZDdiNGEzODcxMTgwNSIsMTUwXSwibmFtZSI6IlRSQU5TRkVSIiwibW9kdWxlIjp7Im5hbWVzcGFjZSI6bnVsbCwibmFtZSI6ImNvaW4ifSwibW9kdWxlSGFzaCI6IjNpSUJRZEpuc3Q0NFoyWmdYb0hQa0FhdXliSjBoODVsX2VuX1NHSE5pYkUifV0sIm1ldGFEYXRhIjpudWxsLCJjb250aW51YXRpb24iOm51bGwsInR4SWQiOjh9") ] diff --git a/src/Chainweb/BlockHeader/Genesis/Mainnet0Payload.hs b/src/Chainweb/BlockHeader/Genesis/Mainnet0Payload.hs index 9544fe7b5d..63af083156 100644 --- a/src/Chainweb/BlockHeader/Genesis/Mainnet0Payload.hs +++ b/src/Chainweb/BlockHeader/Genesis/Mainnet0Payload.hs @@ -8,7 +8,7 @@ import qualified Data.Text as T import qualified Data.Vector as V import GHC.Stack -import Chainweb.Payload +import Chainweb.Pact.Payload import Chainweb.Utils (unsafeFromText, toText) payloadBlock :: HasCallStack => PayloadWithOutputs diff --git a/src/Chainweb/BlockHeader/Genesis/Mainnet10to19Payload.hs b/src/Chainweb/BlockHeader/Genesis/Mainnet10to19Payload.hs index df3e96f250..9907b05fde 100644 --- a/src/Chainweb/BlockHeader/Genesis/Mainnet10to19Payload.hs +++ b/src/Chainweb/BlockHeader/Genesis/Mainnet10to19Payload.hs @@ -8,7 +8,7 @@ import qualified Data.Text as T import qualified Data.Vector as V import GHC.Stack -import Chainweb.Payload +import Chainweb.Pact.Payload import Chainweb.Utils (unsafeFromText, toText) payloadBlock :: HasCallStack => PayloadWithOutputs diff --git a/src/Chainweb/BlockHeader/Genesis/Mainnet1Payload.hs b/src/Chainweb/BlockHeader/Genesis/Mainnet1Payload.hs index 657f0f5a0e..331e6af01e 100644 --- a/src/Chainweb/BlockHeader/Genesis/Mainnet1Payload.hs +++ b/src/Chainweb/BlockHeader/Genesis/Mainnet1Payload.hs @@ -8,7 +8,7 @@ import qualified Data.Text as T import qualified Data.Vector as V import GHC.Stack -import Chainweb.Payload +import Chainweb.Pact.Payload import Chainweb.Utils (unsafeFromText, toText) payloadBlock :: HasCallStack => PayloadWithOutputs diff --git a/src/Chainweb/BlockHeader/Genesis/Mainnet2Payload.hs b/src/Chainweb/BlockHeader/Genesis/Mainnet2Payload.hs index 6a5e84b38c..6ec2b0394c 100644 --- a/src/Chainweb/BlockHeader/Genesis/Mainnet2Payload.hs +++ b/src/Chainweb/BlockHeader/Genesis/Mainnet2Payload.hs @@ -8,7 +8,7 @@ import qualified Data.Text as T import qualified Data.Vector as V import GHC.Stack -import Chainweb.Payload +import Chainweb.Pact.Payload import Chainweb.Utils (unsafeFromText, toText) payloadBlock :: HasCallStack => PayloadWithOutputs diff --git a/src/Chainweb/BlockHeader/Genesis/Mainnet3Payload.hs b/src/Chainweb/BlockHeader/Genesis/Mainnet3Payload.hs index 4f68c246ff..d189beea8e 100644 --- a/src/Chainweb/BlockHeader/Genesis/Mainnet3Payload.hs +++ b/src/Chainweb/BlockHeader/Genesis/Mainnet3Payload.hs @@ -8,7 +8,7 @@ import qualified Data.Text as T import qualified Data.Vector as V import GHC.Stack -import Chainweb.Payload +import Chainweb.Pact.Payload import Chainweb.Utils (unsafeFromText, toText) payloadBlock :: HasCallStack => PayloadWithOutputs diff --git a/src/Chainweb/BlockHeader/Genesis/Mainnet4Payload.hs b/src/Chainweb/BlockHeader/Genesis/Mainnet4Payload.hs index 299e5d658b..2a3e9ead55 100644 --- a/src/Chainweb/BlockHeader/Genesis/Mainnet4Payload.hs +++ b/src/Chainweb/BlockHeader/Genesis/Mainnet4Payload.hs @@ -8,7 +8,7 @@ import qualified Data.Text as T import qualified Data.Vector as V import GHC.Stack -import Chainweb.Payload +import Chainweb.Pact.Payload import Chainweb.Utils (unsafeFromText, toText) payloadBlock :: HasCallStack => PayloadWithOutputs diff --git a/src/Chainweb/BlockHeader/Genesis/Mainnet5Payload.hs b/src/Chainweb/BlockHeader/Genesis/Mainnet5Payload.hs index 4d24ec216b..7b2abbb432 100644 --- a/src/Chainweb/BlockHeader/Genesis/Mainnet5Payload.hs +++ b/src/Chainweb/BlockHeader/Genesis/Mainnet5Payload.hs @@ -8,7 +8,7 @@ import qualified Data.Text as T import qualified Data.Vector as V import GHC.Stack -import Chainweb.Payload +import Chainweb.Pact.Payload import Chainweb.Utils (unsafeFromText, toText) payloadBlock :: HasCallStack => PayloadWithOutputs diff --git a/src/Chainweb/BlockHeader/Genesis/Mainnet6Payload.hs b/src/Chainweb/BlockHeader/Genesis/Mainnet6Payload.hs index 4f10d85dd2..e9d20375de 100644 --- a/src/Chainweb/BlockHeader/Genesis/Mainnet6Payload.hs +++ b/src/Chainweb/BlockHeader/Genesis/Mainnet6Payload.hs @@ -8,7 +8,7 @@ import qualified Data.Text as T import qualified Data.Vector as V import GHC.Stack -import Chainweb.Payload +import Chainweb.Pact.Payload import Chainweb.Utils (unsafeFromText, toText) payloadBlock :: HasCallStack => PayloadWithOutputs diff --git a/src/Chainweb/BlockHeader/Genesis/Mainnet7Payload.hs b/src/Chainweb/BlockHeader/Genesis/Mainnet7Payload.hs index 865680ede4..813c852132 100644 --- a/src/Chainweb/BlockHeader/Genesis/Mainnet7Payload.hs +++ b/src/Chainweb/BlockHeader/Genesis/Mainnet7Payload.hs @@ -8,7 +8,7 @@ import qualified Data.Text as T import qualified Data.Vector as V import GHC.Stack -import Chainweb.Payload +import Chainweb.Pact.Payload import Chainweb.Utils (unsafeFromText, toText) payloadBlock :: HasCallStack => PayloadWithOutputs diff --git a/src/Chainweb/BlockHeader/Genesis/Mainnet8Payload.hs b/src/Chainweb/BlockHeader/Genesis/Mainnet8Payload.hs index e357f2f93e..12686e4dfd 100644 --- a/src/Chainweb/BlockHeader/Genesis/Mainnet8Payload.hs +++ b/src/Chainweb/BlockHeader/Genesis/Mainnet8Payload.hs @@ -8,7 +8,7 @@ import qualified Data.Text as T import qualified Data.Vector as V import GHC.Stack -import Chainweb.Payload +import Chainweb.Pact.Payload import Chainweb.Utils (unsafeFromText, toText) payloadBlock :: HasCallStack => PayloadWithOutputs diff --git a/src/Chainweb/BlockHeader/Genesis/Mainnet9Payload.hs b/src/Chainweb/BlockHeader/Genesis/Mainnet9Payload.hs index f6f1194604..d56fd82e9d 100644 --- a/src/Chainweb/BlockHeader/Genesis/Mainnet9Payload.hs +++ b/src/Chainweb/BlockHeader/Genesis/Mainnet9Payload.hs @@ -8,7 +8,7 @@ import qualified Data.Text as T import qualified Data.Vector as V import GHC.Stack -import Chainweb.Payload +import Chainweb.Pact.Payload import Chainweb.Utils (unsafeFromText, toText) payloadBlock :: HasCallStack => PayloadWithOutputs diff --git a/src/Chainweb/BlockHeader/Genesis/Pact53TransitionTimedCPM0Payload.hs b/src/Chainweb/BlockHeader/Genesis/Pact53TransitionTimedCPM0Payload.hs index ce8c967ea3..40d7c11766 100644 --- a/src/Chainweb/BlockHeader/Genesis/Pact53TransitionTimedCPM0Payload.hs +++ b/src/Chainweb/BlockHeader/Genesis/Pact53TransitionTimedCPM0Payload.hs @@ -8,7 +8,7 @@ import qualified Data.Text as T import qualified Data.Vector as V import GHC.Stack -import Chainweb.Payload +import Chainweb.Pact.Payload import Chainweb.Utils (unsafeFromText, toText) payloadBlock :: HasCallStack => PayloadWithOutputs @@ -21,7 +21,7 @@ payloadBlock where actualHash, expectedHash :: BlockPayloadHash actualHash = _payloadWithOutputsPayloadHash payload - expectedHash = unsafeFromText "S7PsDlRGDjPYLdeM3eeEZdvuYtdAthe3_LIVVwlDOaU" + expectedHash = unsafeFromText "oq5QZGFJNhFZDMmrLCWVp_-gBcp1_DBqHYimdL7v468" payload = newPayloadWithOutputs minerData coinbase txs minerData = unsafeFromText "eyJhY2NvdW50IjoiTm9NaW5lciIsInByZWRpY2F0ZSI6IjwiLCJwdWJsaWMta2V5cyI6W119" @@ -35,5 +35,5 @@ payloadBlock , (unsafeFromText "eyJoYXNoIjoiQ1pteWxXZmllUk1CTXU1dzJFT21wRndLLXQ3YmNPVHM0bUsyYVQzM3VSNCIsInNpZ3MiOltdLCJjbWQiOiJ7XCJuZXR3b3JrSWRcIjpudWxsLFwicGF5bG9hZFwiOntcImV4ZWNcIjp7XCJkYXRhXCI6e1wibnMtYWRtaW4ta2V5c2V0XCI6W1wiMzY4ODIwZjgwYzMyNGJiYzdjMmIwNjEwNjg4YTdkYTQzZTM5ZjkxZDExODczMjY3MWNkOWM3NTAwZmY0M2NjYVwiXSxcIm5zLW9wZXJhdGUta2V5c2V0XCI6W1wiMzY4ODIwZjgwYzMyNGJiYzdjMmIwNjEwNjg4YTdkYTQzZTM5ZjkxZDExODczMjY3MWNkOWM3NTAwZmY0M2NjYVwiXSxcIm5zLWdlbmVzaXMta2V5c2V0XCI6e1wicHJlZFwiOlwiPVwiLFwia2V5c1wiOltdfX0sXCJjb2RlXCI6XCIoZGVmaW5lLWtleXNldCAnbnMtYWRtaW4ta2V5c2V0IChyZWFkLWtleXNldCAnbnMtYWRtaW4ta2V5c2V0KSlcXG4oZGVmaW5lLWtleXNldCAnbnMtb3BlcmF0ZS1rZXlzZXQgKHJlYWQta2V5c2V0ICducy1nZW5lc2lzLWtleXNldCkpXFxuXFxuKG1vZHVsZSBucyBHT1ZFUk5BTkNFXFxuICBcXFwiQWRtaW5pc3RlcnMgZGVmaW5pdGlvbiBvZiBuZXcgbmFtZXNwYWNlcyBpbiBDaGFpbndlYi5cXFwiXFxuXFxuICAoZGVmc2NoZW1hIHJlZy1lbnRyeVxcbiAgICBhZG1pbi1ndWFyZDpndWFyZFxcbiAgICBhY3RpdmU6Ym9vbClcXG5cXG4gIChkZWZ0YWJsZSByZWdpc3RyeTp7cmVnLWVudHJ5fSlcXG5cXG4gIChkZWZjYXAgR09WRVJOQU5DRSAoKVxcbiAgICAoZW5mb3JjZS1rZXlzZXQgJ25zLWFkbWluLWtleXNldCkpXFxuXFxuICAoZGVmY2FwIE9QRVJBVEUgKClcXG4gICAgKGVuZm9yY2Uta2V5c2V0ICducy1vcGVyYXRlLWtleXNldCkpXFxuXFxuICAoZGVmY29uc3QgR1VBUkRfU1VDQ0VTUyAoY3JlYXRlLXVzZXItZ3VhcmQgKHN1Y2Nlc3MpKSlcXG4gIChkZWZjb25zdCBHVUFSRF9GQUlMVVJFIChjcmVhdGUtdXNlci1ndWFyZCAoZmFpbHVyZSkpKVxcblxcbiAgKGRlZnVuIHN1Y2Nlc3MgKClcXG4gICAgdHJ1ZSlcXG4gIChkZWZ1biBmYWlsdXJlICgpXFxuICAgIChlbmZvcmNlIGZhbHNlIFxcXCJEaXNhYmxlZFxcXCIpKVxcblxcbiAgKGRlZnVuIHZhbGlkYXRlLW5hbWUgKG5hbWUpXFxuICAgIChlbmZvcmNlICghPSBcXFwiXFxcIiBuYW1lKSBcXFwiRW1wdHkgbmFtZSBub3QgYWxsb3dlZFxcXCIpXFxuICAgIChlbmZvcmNlICg8IChsZW5ndGggbmFtZSkgNjQpIFxcXCJOYW1lIG11c3QgYmUgbGVzcyB0aGFuIDY0IGNoYXJhY3RlcnMgbG9uZ1xcXCIpXFxuICAgIChlbmZvcmNlIChpcy1jaGFyc2V0IENIQVJTRVRfTEFUSU4xIG5hbWUpXFxuICAgICAgICAgICAgIFxcXCJOYW1lIG11c3QgYmUgaW4gbGF0aW4xIGNoYXJzZXRcXFwiKSlcXG5cXG4gIChkZWZ1biBjcmVhdGUtcHJpbmNpcGFsLW5hbWVzcGFjZTpzdHJpbmdcXG4gICAgICAoIGc6Z3VhcmRcXG4gICAgICAgIClcXG4gICAgXFxcIiBGb3JtYXQgcHJpbmNpcGFsIG5hbWVzcGFjZSBhcyBQYWN0IGhhc2ggKEJMQUtFMmIyNTYpIG9mIHByaW5jaXBhbCBcXFxcXFxuICAgIFxcXFwgaW4gaGV4IHRydW5jYXRlZCB0byAxNjAgYml0cyAoNDAgY2hhcmFjdGVycyksIHByZXBlbmRlZCB3aXRoICduXycuXFxcXFxcbiAgICBcXFxcIE9ubHkgdzogYW5kIGs6IGFjY291bnQgcHJvdG9jb2xzIGFyZSBzdXBwb3J0ZWQuIFxcXCJcXG5cXG4gICAgKGxldFxcbiAgICAgICgodHkgKHR5cGVvZi1wcmluY2lwYWwgKGNyZWF0ZS1wcmluY2lwYWwgZykpKSlcXG5cXG4gICAgICA7OyBvbmx5IHc6IGFuZCBrOiBjdXJyZW50bHkgc3VwcG9ydGVkXFxuICAgICAgKGlmIChvciAoPSB0eSBcXFwiazpcXFwiKSAoPSB0eSBcXFwidzpcXFwiKSlcXG4gICAgICAgICgrIFxcXCJuX1xcXCIgKHRha2UgNDAgKGludC10by1zdHIgMTYgKHN0ci10by1pbnQgNjQgKGhhc2ggZykpKSkpXFxuICAgICAgICAoZW5mb3JjZSBmYWxzZVxcbiAgICAgICAgICAoZm9ybWF0IFxcXCJVbnN1cHBvcnRlZCBndWFyZCBwcm90b2NvbDoge31cXFwiIFt0eV0pKVxcbiAgICAgICAgKSlcXG4gIClcXG5cXG4gIChkZWZ1biB2YWxpZGF0ZTpib29sXFxuICAgICAgKCBucy1uYW1lOnN0cmluZ1xcbiAgICAgICAgbnMtYWRtaW46Z3VhcmRcXG4gICAgICAgIClcXG4gICAgXFxcIiBNYW5hZ2VzIG5hbWVzcGFjZSBpbnN0YWxsIGZvciBDaGFpbndlYi4gXFxcXFxcbiAgICBcXFxcIEFsbG93cyBwcmluY2lwYWwgbmFtZXNwYWNlcy4gXFxcXFxcbiAgICBcXFxcIE5vbi1wcmluY2lwYWwgbmFtZXNwYWNlcyByZXF1aXJlIGFjdGl2ZSByb3cgaW4gcmVnaXN0cnkgXFxcXFxcbiAgICBcXFxcIGZvciBOUy1OQU1FIHdpdGggZ3VhcmQgbWF0Y2hpbmcgTlMtQURNSU4uXFxcIlxcblxcbiAgICAoaWYgKD0gKGNyZWF0ZS1wcmluY2lwYWwtbmFtZXNwYWNlIG5zLWFkbWluKSBucy1uYW1lKVxcblxcbiAgICAgIHRydWUgOzsgYWxsb3cgcHJpbmNpcGFsIG5hbWVzcGFjZXNcXG5cXG4gICAgICAod2l0aC1kZWZhdWx0LXJlYWQgcmVnaXN0cnkgbnMtbmFtZSAgICAgICA7OyBvdGhlcndpc2UgZW5mb3JjZSByZWdpc3RyeVxcbiAgICAgICAgeyAnYWRtaW4tZ3VhcmQgOiBucy1hZG1pblxcbiAgICAgICAgLCAnYWN0aXZlIDogZmFsc2UgfVxcbiAgICAgICAgeyAnYWRtaW4tZ3VhcmQgOj0gYWdcXG4gICAgICAgICwgJ2FjdGl2ZSA6PSBpcy1hY3RpdmUgfVxcblxcbiAgICAgICAgKGVuZm9yY2UgaXMtYWN0aXZlIFxcXCJJbmFjdGl2ZSBvciB1bnJlZ2lzdGVyZWQgbmFtZXNwYWNlXFxcIilcXG4gICAgICAgIChlbmZvcmNlICg9IG5zLWFkbWluIGFnKSBcXFwiQWRtaW4gZ3VhcmQgbXVzdCBtYXRjaCBndWFyZCBpbiByZWdpc3RyeVxcXCIpXFxuXFxuICAgICAgICB0cnVlKVxcbiAgICAgICkpXFxuXFxuICAoZGVmdW4gd3JpdGUtcmVnaXN0cnk6c3RyaW5nXFxuICAgICAgKCBucy1uYW1lOnN0cmluZ1xcbiAgICAgICAgZ3VhcmQ6Z3VhcmRcXG4gICAgICAgIGFjdGl2ZTpib29sXFxuICAgICAgICApXFxuICAgIFxcXCIgV3JpdGUgZW50cnkgd2l0aCBHVUFSRCBhbmQgQUNUSVZFIGludG8gcmVnaXN0cnkgZm9yIE5BTUUuIFxcXFxcXG4gICAgXFxcXCBHdWFyZGVkIGJ5IG9wZXJhdGUga2V5c2V0LiBcXFwiXFxuXFxuICAgICh3aXRoLWNhcGFiaWxpdHkgKE9QRVJBVEUpXFxuXFxuICAgICAgKHZhbGlkYXRlLW5hbWUgbnMtbmFtZSlcXG5cXG4gICAgICAod3JpdGUgcmVnaXN0cnkgbnMtbmFtZVxcbiAgICAgICAgeyAnYWRtaW4tZ3VhcmQ6IGd1YXJkXFxuICAgICAgICAsICdhY3RpdmU6IGFjdGl2ZSB9KVxcblxcbiAgICAgIFxcXCJSZWdpc3RlciBlbnRyeSB3cml0dGVuXFxcIikpXFxuXFxuICAoZGVmdW4gcXVlcnk6b2JqZWN0e3JlZy1lbnRyeX1cXG4gICAgICAoIG5zLW5hbWU6c3RyaW5nIClcXG4gICAgKHJlYWQgcmVnaXN0cnkgbnMtbmFtZSkpXFxuXFxuKVxcblxcbihjcmVhdGUtdGFibGUgcmVnaXN0cnkpXFxuXFxuKHdyaXRlLXJlZ2lzdHJ5IFxcXCJrYWRlbmFcXFwiXFxuICAoa2V5c2V0LXJlZi1ndWFyZCAnbnMtb3BlcmF0ZS1rZXlzZXQpIHRydWUpXFxuKHdyaXRlLXJlZ2lzdHJ5IFxcXCJ1c2VyXFxcIiBHVUFSRF9GQUlMVVJFIHRydWUpXFxuKHdyaXRlLXJlZ2lzdHJ5IFxcXCJmcmVlXFxcIiBHVUFSRF9GQUlMVVJFIHRydWUpXFxuXFxuKGRlZmluZS1uYW1lc3BhY2UgXFxcImthZGVuYVxcXCJcXG4gIChrZXlzZXQtcmVmLWd1YXJkICducy1vcGVyYXRlLWtleXNldClcXG4gIChrZXlzZXQtcmVmLWd1YXJkICducy1vcGVyYXRlLWtleXNldCkpXFxuXFxuKGRlZmluZS1uYW1lc3BhY2UgXFxcInVzZXJcXFwiIEdVQVJEX1NVQ0NFU1MgR1VBUkRfRkFJTFVSRSlcXG4oZGVmaW5lLW5hbWVzcGFjZSBcXFwiZnJlZVxcXCIgR1VBUkRfU1VDQ0VTUyBHVUFSRF9GQUlMVVJFKVxcbjs7cm90YXRlIHRvIHJlYWwgb3BlcmF0ZSBrZXlzZXRcXG4oZGVmaW5lLWtleXNldCAnbnMtb3BlcmF0ZS1rZXlzZXQgKHJlYWQta2V5c2V0ICducy1vcGVyYXRlLWtleXNldCkpXFxuXCJ9fSxcInNpZ25lcnNcIjpbXSxcIm1ldGFcIjp7XCJjcmVhdGlvblRpbWVcIjowLFwidHRsXCI6MTcyODAwLFwiZ2FzTGltaXRcIjowLFwiY2hhaW5JZFwiOlwiXCIsXCJnYXNQcmljZVwiOjAsXCJzZW5kZXJcIjpcIlwifSxcIm5vbmNlXCI6XCJsb2FkLW5zLWRldm5ldC1zZW5kZXIwMFwifSJ9", unsafeFromText "eyJnYXMiOjAsInJlc3VsdCI6eyJzdGF0dXMiOiJzdWNjZXNzIiwiZGF0YSI6IktleXNldCB3cml0ZSBzdWNjZXNzIn0sInJlcUtleSI6IkNabXlsV2ZpZVJNQk11NXcyRU9tcEZ3Sy10N2JjT1RzNG1LMmFUMzN1UjQiLCJsb2dzIjoiUUhPVmJXQ09OZTcydDJXZ28xN0w4Z1JpRk55alJndFdnZFZNRWNXX0ZiayIsIm1ldGFEYXRhIjpudWxsLCJjb250aW51YXRpb24iOm51bGwsInR4SWQiOjV9") , (unsafeFromText "eyJoYXNoIjoiWE5BNmxPSjFXLTdYWXY1WWI0QXFsNzRveFlJN09KcWpPUVQ1b1k0OHEtZyIsInNpZ3MiOltdLCJjbWQiOiJ7XCJuZXR3b3JrSWRcIjpudWxsLFwicGF5bG9hZFwiOntcImV4ZWNcIjp7XCJkYXRhXCI6e1wiYWxsb2NhdGlvbi10ZXN0MDFcIjpbXCI3MDExYzM3OTE0MGZmODk5ZjdlNjEzYWMwYTk3ODRhN2MwYTUxNWQzMGZlMGFiMmIwYzA3ZTVhYTE3NjM1ZTNlXCJdLFwiYWxsb2NhdGlvbjAyXCI6W1wiZTllNGU3MWJkMDYzZGNmN2UwNmJkNWIxYTE2Njg4ODk3ZDE1Y2E4YmQyZTUwOWM0NTNjNjE2MjE5YzE4NmNjNVwiXSxcImFsbG9jYXRpb24wMFwiOltcImQ4MmQwZGNkZTk4MjU1MDVkODZhZmI2ZGNjMTA0MTFkNmI2N2E0MjlhNzllMjFiZGE0YmIxMTliZjI4YWI4NzFcIl0sXCJhbGxvY2F0aW9uLXRlc3QwMlwiOltcIjA2NTQ0ZTIyYmZlZjIzMGQ2ZDIyZjk0ODZhYzZjYjc2YmYyNThlYmZiZjAxMzdlZTU4ZjY1NzQzZTFhNWI4YzRcIl0sXCJhbGxvY2F0aW9uMDFcIjpbXCJiNGM4YTNlYTkxZDMxNDZiMDU2MDk5NDc0MGYwZTNlZWQ5MWM1OWQyZWVjYTFkYzk5ZjBjMjg3Mjg0NWMyOTRkXCJdfSxcImNvZGVcIjpcIihkZWZpbmUta2V5c2V0IFxcXCJhbGxvY2F0aW9uMDBcXFwiIChyZWFkLWtleXNldCBcXFwiYWxsb2NhdGlvbjAwXFxcIikpXFxuKGRlZmluZS1rZXlzZXQgXFxcImFsbG9jYXRpb24wMVxcXCIgKHJlYWQta2V5c2V0IFxcXCJhbGxvY2F0aW9uMDFcXFwiKSlcXG4oZGVmaW5lLWtleXNldCBcXFwiYWxsb2NhdGlvbjAyXFxcIiAocmVhZC1rZXlzZXQgXFxcImFsbG9jYXRpb24wMlxcXCIpKVxcbihkZWZpbmUta2V5c2V0IFxcXCJhbGxvY2F0aW9uLXRlc3QwMVxcXCIgKHJlYWQta2V5c2V0IFxcXCJhbGxvY2F0aW9uLXRlc3QwMVxcXCIpKVxcbihkZWZpbmUta2V5c2V0IFxcXCJhbGxvY2F0aW9uLXRlc3QwMlxcXCIgKHJlYWQta2V5c2V0IFxcXCJhbGxvY2F0aW9uLXRlc3QwMlxcXCIpKVwifX0sXCJzaWduZXJzXCI6W10sXCJtZXRhXCI6e1wiY3JlYXRpb25UaW1lXCI6MCxcInR0bFwiOjE3MjgwMCxcImdhc0xpbWl0XCI6MCxcImNoYWluSWRcIjpcIlwiLFwiZ2FzUHJpY2VcIjowLFwic2VuZGVyXCI6XCJcIn0sXCJub25jZVwiOlwiZGV2bmV0LWtleXNldHNcIn0ifQ", unsafeFromText "eyJnYXMiOjAsInJlc3VsdCI6eyJzdGF0dXMiOiJzdWNjZXNzIiwiZGF0YSI6IktleXNldCB3cml0ZSBzdWNjZXNzIn0sInJlcUtleSI6IlhOQTZsT0oxVy03WFl2NVliNEFxbDc0b3hZSTdPSnFqT1FUNW9ZNDhxLWciLCJsb2dzIjoiYXJRSWpQVGRrcXhoQTNjWl9WaVE3OXM3Uk5XRTlGV2Rha0xWdXl4Nlc0YyIsIm1ldGFEYXRhIjpudWxsLCJjb250aW51YXRpb24iOm51bGwsInR4SWQiOjZ9") , (unsafeFromText "eyJoYXNoIjoiNWtxZ0tzWWtwbjZCcS1KUnhNYnA1VG9jUWhRWGRJVVNiM1NGQm1Ba3VWcyIsInNpZ3MiOltdLCJjbWQiOiJ7XCJuZXR3b3JrSWRcIjpudWxsLFwicGF5bG9hZFwiOntcImV4ZWNcIjp7XCJkYXRhXCI6bnVsbCxcImNvZGVcIjpcIihjb2luLmNyZWF0ZS1hbGxvY2F0aW9uLWFjY291bnQgXFxcImFsbG9jYXRpb24wMFxcXCIgKHRpbWUgXFxcIjE5MDAtMTAtMTVUMTg6MDA6MDBaXFxcIikgXFxcImFsbG9jYXRpb24wMFxcXCIgMTAwMDAwMC4wKVxcbihjb2luLmNyZWF0ZS1hbGxvY2F0aW9uLWFjY291bnQgXFxcImFsbG9jYXRpb24wMVxcXCIgKHRpbWUgXFxcIjIxMDAtMTAtMzFUMTg6MDA6MDBaXFxcIikgXFxcImFsbG9jYXRpb24wMVxcXCIgMTAwMDAwMC4wKVxcbihjb2luLmNyZWF0ZS1hbGxvY2F0aW9uLWFjY291bnQgXFxcImFsbG9jYXRpb24wMlxcXCIgKHRpbWUgXFxcIjE5MDAtMTAtMzFUMTg6MDA6MDBaXFxcIikgXFxcImFsbG9jYXRpb24wMlxcXCIgMTAwMDAwMC4wKVxcbihjb2luLmNyZWF0ZS1hbGxvY2F0aW9uLWFjY291bnQgXFxcImFsbG9jYXRpb24tdGVzdDAxXFxcIiAodGltZSBcXFwiMTkwMC0xMC0zMVQxODowMDowMFpcXFwiKSBcXFwiYWxsb2NhdGlvbi10ZXN0MDFcXFwiIDEwMDAwMDAuMClcXG4oY29pbi5jcmVhdGUtYWxsb2NhdGlvbi1hY2NvdW50IFxcXCJhbGxvY2F0aW9uLXRlc3QwMlxcXCIgKHRpbWUgXFxcIjE5MDAtMTAtMzFUMTg6MDA6MDBaXFxcIikgXFxcImFsbG9jYXRpb24tdGVzdDAyXFxcIiAyMDAwMDAwLjApXCJ9fSxcInNpZ25lcnNcIjpbXSxcIm1ldGFcIjp7XCJjcmVhdGlvblRpbWVcIjowLFwidHRsXCI6MTcyODAwLFwiZ2FzTGltaXRcIjowLFwiY2hhaW5JZFwiOlwiXCIsXCJnYXNQcmljZVwiOjAsXCJzZW5kZXJcIjpcIlwifSxcIm5vbmNlXCI6XCJkZXZuZXQtYWxsb2NhdGlvbnNcIn0ifQ", unsafeFromText "eyJnYXMiOjAsInJlc3VsdCI6eyJzdGF0dXMiOiJzdWNjZXNzIiwiZGF0YSI6IldyaXRlIHN1Y2NlZWRlZCJ9LCJyZXFLZXkiOiI1a3FnS3NZa3BuNkJxLUpSeE1icDVUb2NRaFFYZElVU2IzU0ZCbUFrdVZzIiwibG9ncyI6IkhpX3ZfVEhFT2s2aEJFRU0yWmV2Vzh3eVJsQWpUZzNjVUQydXBlVkx0b1UiLCJtZXRhRGF0YSI6bnVsbCwiY29udGludWF0aW9uIjpudWxsLCJ0eElkIjo3fQ") - , (unsafeFromText "eyJoYXNoIjoiY2tiMmZnNWVJeXRoS3U5YVN3TkhIWllsWVY2V1R1NGlYaUZDamc5WFFLWSIsInNpZ3MiOltdLCJjbWQiOiJ7XCJuZXR3b3JrSWRcIjpudWxsLFwicGF5bG9hZFwiOntcImV4ZWNcIjp7XCJkYXRhXCI6e1wic2VuZGVyMDdcIjpbXCI0YzMxZGM5ZWU3ZjI0MTc3Zjc4YjZmNTE4MDEyYTIwODMyNmUyYWYxZjM3YmIwYTI0MDViNTA1NmQwY2FkNjI4XCJdLFwic2VuZGVyMDFcIjpbXCI2YmUyZjQ4NWE3YWY3NWZlZGI0YjdmMTUzYTkwM2Y3ZTYwMDBjYTRhYTUwMTE3OWM5MWEyNDUwYjc3N2JkMmE3XCJdLFwic2VuZGVyMDZcIjpbXCI1ZmZjMWY3ZmVmN2E0NDczODYyNTc2MmY3NWE0MjI5NDU0OTUxZTAzZjJhZmM2ZjgxMzA5YzBjMWJkZjllZTZmXCJdLFwic2VuZGVyMDBcIjpbXCIzNjg4MjBmODBjMzI0YmJjN2MyYjA2MTA2ODhhN2RhNDNlMzlmOTFkMTE4NzMyNjcxY2Q5Yzc1MDBmZjQzY2NhXCJdLFwiZTdmN1wiOltcImU3Zjc2MzRlOTI1NTQxZjM2OGI4MjdhZDVjNzI0MjE5MDUxMDBmNjIwNTI4NWE3OGMxOWQ3YjRhMzg3MTE4MDVcIl0sXCJzZW5kZXIwNVwiOltcImYwOWQ4ZjYzOTRhZWE0MjVmZTY3ODNkODhjZDgxMzYzZDgwMTdmMTZhZmQzNzExYzU3NWJlMGY1Y2Q1YzliYjlcIl0sXCJzZW5kZXIwNFwiOltcIjJkNzBhYTRmNjk3YzNhM2I4ZGQ2ZDk3NzQ1YWMwNzRlZGNmZDBlYjY1YzM3Nzc0Y2RlMjUxMzU0ODNiZWE3MWVcIl0sXCJtdWx0aS0wMi0wMy0wNC1hbnlcIjp7XCJwcmVkXCI6XCJrZXlzLWFueVwiLFwia2V5c1wiOltcIjNhOWRkNTMyZDczZGFjZTE5NWRiYjY0ZDFkYmE2NTcyZmI3ODNkMGZkZDMyNDY4NWUzMmZiZGEyZjg5Zjk5YTZcIixcIjQzZjJhZGIxZGUxOTIwMDBjYjM3NzdiYWNjN2Y5ODNiNjYxNGZkOWMxNzE1Y2Q0NGNkNDg0YjZkM2EwZDM0YzhcIixcIjJkNzBhYTRmNjk3YzNhM2I4ZGQ2ZDk3NzQ1YWMwNzRlZGNmZDBlYjY1YzM3Nzc0Y2RlMjUxMzU0ODNiZWE3MWVcIl19LFwic2VuZGVyMDlcIjpbXCJjNTlkOTg0MGIwYjY2MDkwODM2NTQ2YjdlYjRhNzM2MDYyNTc1MjdlYzhjMmI0ODIzMDBmZDIyOTI2NGIwN2U2XCJdLFwic2VuZGVyMDNcIjpbXCI0M2YyYWRiMWRlMTkyMDAwY2IzNzc3YmFjYzdmOTgzYjY2MTRmZDljMTcxNWNkNDRjZDQ4NGI2ZDNhMGQzNGM4XCJdLFwibXVsdGktMDAtMDFcIjpbXCIzNjg4MjBmODBjMzI0YmJjN2MyYjA2MTA2ODhhN2RhNDNlMzlmOTFkMTE4NzMyNjcxY2Q5Yzc1MDBmZjQzY2NhXCIsXCI2YmUyZjQ4NWE3YWY3NWZlZGI0YjdmMTUzYTkwM2Y3ZTYwMDBjYTRhYTUwMTE3OWM5MWEyNDUwYjc3N2JkMmE3XCJdLFwic2VuZGVyMDhcIjpbXCI2M2IyZWJhNGVkNzBkNDYxMmQzZTdiYzkwZGIyZmJmNGM3NmY3YjA3NDM2M2U4NmQ3M2YwYmM2MTdmOGU4YjgxXCJdLFwic2VuZGVyMDJcIjpbXCIzYTlkZDUzMmQ3M2RhY2UxOTVkYmI2NGQxZGJhNjU3MmZiNzgzZDBmZGQzMjQ2ODVlMzJmYmRhMmY4OWY5OWE2XCJdfSxcImNvZGVcIjpcIihjb2luLmNvaW5iYXNlIFxcXCJzZW5kZXIwMFxcXCIgKHJlYWQta2V5c2V0IFxcXCJzZW5kZXIwMFxcXCIpIDEwMDAwMDAwMC4wKVxcbihjb2luLmNvaW5iYXNlIFxcXCJzZW5kZXIwMVxcXCIgKHJlYWQta2V5c2V0IFxcXCJzZW5kZXIwMVxcXCIpIDExMDAwMDAwMC4wKVxcbihjb2luLmNvaW5iYXNlIFxcXCJzZW5kZXIwMlxcXCIgKHJlYWQta2V5c2V0IFxcXCJzZW5kZXIwMlxcXCIpIDEyMDAwMDAwMC4wKVxcbihjb2luLmNvaW5iYXNlIFxcXCJzZW5kZXIwM1xcXCIgKHJlYWQta2V5c2V0IFxcXCJzZW5kZXIwM1xcXCIpIDEzMDAwMDAwMC4wKVxcbihjb2luLmNvaW5iYXNlIFxcXCJzZW5kZXIwNFxcXCIgKHJlYWQta2V5c2V0IFxcXCJzZW5kZXIwNFxcXCIpIDE0MDAwMDAwMC4wKVxcbihjb2luLmNvaW5iYXNlIFxcXCJzZW5kZXIwNVxcXCIgKHJlYWQta2V5c2V0IFxcXCJzZW5kZXIwNVxcXCIpIDE1MDAwMDAwMC4wKVxcbihjb2luLmNvaW5iYXNlIFxcXCJzZW5kZXIwNlxcXCIgKHJlYWQta2V5c2V0IFxcXCJzZW5kZXIwNlxcXCIpIDE2MDAwMDAwMC4wKVxcbihjb2luLmNvaW5iYXNlIFxcXCJzZW5kZXIwN1xcXCIgKHJlYWQta2V5c2V0IFxcXCJzZW5kZXIwN1xcXCIpIDE3MDAwMDAwMC4wKVxcbihjb2luLmNvaW5iYXNlIFxcXCJzZW5kZXIwOFxcXCIgKHJlYWQta2V5c2V0IFxcXCJzZW5kZXIwOFxcXCIpIDE4MDAwMDAwMC4wKVxcbihjb2luLmNvaW5iYXNlIFxcXCJzZW5kZXIwOVxcXCIgKHJlYWQta2V5c2V0IFxcXCJzZW5kZXIwOVxcXCIpIDE5MDAwMDAwMC4wKVxcbihjb2luLmNvaW5iYXNlIFxcXCJtdWx0aS0wMC0wMVxcXCIgKHJlYWQta2V5c2V0IFxcXCJtdWx0aS0wMC0wMVxcXCIpIDEwMTAwMDAwMC4wKVxcbihjb2luLmNvaW5iYXNlIFxcXCJtdWx0aS0wMi0wMy0wNC1hbnlcXFwiIChyZWFkLWtleXNldCBcXFwibXVsdGktMDItMDMtMDQtYW55XFxcIikgMTIzNDAwMDAwLjApXFxuXFxuKGNvaW4uY29pbmJhc2UgXFxcImU3Zjc2MzRlOTI1NTQxZjM2OGI4MjdhZDVjNzI0MjE5MDUxMDBmNjIwNTI4NWE3OGMxOWQ3YjRhMzg3MTE4MDVcXFwiIChyZWFkLWtleXNldCBcXFwiZTdmN1xcXCIpIDE1MC4wKVxcblxcbjsgZW5vdWdoIHRvIGNvdmVyIHRoZSBnYXMgY29zdHMgZm9yIGFsbG9jYXRpb24gcmVsZWFzZVxcbihjb2luLmNvaW5iYXNlIFxcXCJhbGxvY2F0aW9uMDBcXFwiIChrZXlzZXQtcmVmLWd1YXJkIFxcXCJhbGxvY2F0aW9uMDBcXFwiKSAxMDAwMDAuMClcXG4oY29pbi5jb2luYmFzZSBcXFwiYWxsb2NhdGlvbjAxXFxcIiAoa2V5c2V0LXJlZi1ndWFyZCBcXFwiYWxsb2NhdGlvbjAxXFxcIikgMTAwMDAwLjApXFxuKGNvaW4uY29pbmJhc2UgXFxcImFsbG9jYXRpb24wMlxcXCIgKGtleXNldC1yZWYtZ3VhcmQgXFxcImFsbG9jYXRpb24wMlxcXCIpIDEwMDAwMC4wKVwifX0sXCJzaWduZXJzXCI6W10sXCJtZXRhXCI6e1wiY3JlYXRpb25UaW1lXCI6MCxcInR0bFwiOjE3MjgwMCxcImdhc0xpbWl0XCI6MCxcImNoYWluSWRcIjpcIlwiLFwiZ2FzUHJpY2VcIjowLFwic2VuZGVyXCI6XCJcIn0sXCJub25jZVwiOlwiZGV2bmV0LWdyYW50czBcIn0ifQ", unsafeFromText "eyJnYXMiOjAsInJlc3VsdCI6eyJzdGF0dXMiOiJzdWNjZXNzIiwiZGF0YSI6IldyaXRlIHN1Y2NlZWRlZCJ9LCJyZXFLZXkiOiJja2IyZmc1ZUl5dGhLdTlhU3dOSEhaWWxZVjZXVHU0aVhpRkNqZzlYUUtZIiwibG9ncyI6ImFCUXM2aDJGVUN1a00tM0pjQmdLZGFvRU1Ta3p2OTJkM0VmT2t5MXNrMmciLCJldmVudHMiOlt7InBhcmFtcyI6WyIiLCJzZW5kZXIwMCIsMTAwMDAwMDAwXSwibmFtZSI6IlRSQU5TRkVSIiwibW9kdWxlIjp7Im5hbWVzcGFjZSI6bnVsbCwibmFtZSI6ImNvaW4ifSwibW9kdWxlSGFzaCI6IjNpSUJRZEpuc3Q0NFoyWmdYb0hQa0FhdXliSjBoODVsX2VuX1NHSE5pYkUifSx7InBhcmFtcyI6WyIiLCJzZW5kZXIwMSIsMTEwMDAwMDAwXSwibmFtZSI6IlRSQU5TRkVSIiwibW9kdWxlIjp7Im5hbWVzcGFjZSI6bnVsbCwibmFtZSI6ImNvaW4ifSwibW9kdWxlSGFzaCI6IjNpSUJRZEpuc3Q0NFoyWmdYb0hQa0FhdXliSjBoODVsX2VuX1NHSE5pYkUifSx7InBhcmFtcyI6WyIiLCJzZW5kZXIwMiIsMTIwMDAwMDAwXSwibmFtZSI6IlRSQU5TRkVSIiwibW9kdWxlIjp7Im5hbWVzcGFjZSI6bnVsbCwibmFtZSI6ImNvaW4ifSwibW9kdWxlSGFzaCI6IjNpSUJRZEpuc3Q0NFoyWmdYb0hQa0FhdXliSjBoODVsX2VuX1NHSE5pYkUifSx7InBhcmFtcyI6WyIiLCJzZW5kZXIwMyIsMTMwMDAwMDAwXSwibmFtZSI6IlRSQU5TRkVSIiwibW9kdWxlIjp7Im5hbWVzcGFjZSI6bnVsbCwibmFtZSI6ImNvaW4ifSwibW9kdWxlSGFzaCI6IjNpSUJRZEpuc3Q0NFoyWmdYb0hQa0FhdXliSjBoODVsX2VuX1NHSE5pYkUifSx7InBhcmFtcyI6WyIiLCJzZW5kZXIwNCIsMTQwMDAwMDAwXSwibmFtZSI6IlRSQU5TRkVSIiwibW9kdWxlIjp7Im5hbWVzcGFjZSI6bnVsbCwibmFtZSI6ImNvaW4ifSwibW9kdWxlSGFzaCI6IjNpSUJRZEpuc3Q0NFoyWmdYb0hQa0FhdXliSjBoODVsX2VuX1NHSE5pYkUifSx7InBhcmFtcyI6WyIiLCJzZW5kZXIwNSIsMTUwMDAwMDAwXSwibmFtZSI6IlRSQU5TRkVSIiwibW9kdWxlIjp7Im5hbWVzcGFjZSI6bnVsbCwibmFtZSI6ImNvaW4ifSwibW9kdWxlSGFzaCI6IjNpSUJRZEpuc3Q0NFoyWmdYb0hQa0FhdXliSjBoODVsX2VuX1NHSE5pYkUifSx7InBhcmFtcyI6WyIiLCJzZW5kZXIwNiIsMTYwMDAwMDAwXSwibmFtZSI6IlRSQU5TRkVSIiwibW9kdWxlIjp7Im5hbWVzcGFjZSI6bnVsbCwibmFtZSI6ImNvaW4ifSwibW9kdWxlSGFzaCI6IjNpSUJRZEpuc3Q0NFoyWmdYb0hQa0FhdXliSjBoODVsX2VuX1NHSE5pYkUifSx7InBhcmFtcyI6WyIiLCJzZW5kZXIwNyIsMTcwMDAwMDAwXSwibmFtZSI6IlRSQU5TRkVSIiwibW9kdWxlIjp7Im5hbWVzcGFjZSI6bnVsbCwibmFtZSI6ImNvaW4ifSwibW9kdWxlSGFzaCI6IjNpSUJRZEpuc3Q0NFoyWmdYb0hQa0FhdXliSjBoODVsX2VuX1NHSE5pYkUifSx7InBhcmFtcyI6WyIiLCJzZW5kZXIwOCIsMTgwMDAwMDAwXSwibmFtZSI6IlRSQU5TRkVSIiwibW9kdWxlIjp7Im5hbWVzcGFjZSI6bnVsbCwibmFtZSI6ImNvaW4ifSwibW9kdWxlSGFzaCI6IjNpSUJRZEpuc3Q0NFoyWmdYb0hQa0FhdXliSjBoODVsX2VuX1NHSE5pYkUifSx7InBhcmFtcyI6WyIiLCJzZW5kZXIwOSIsMTkwMDAwMDAwXSwibmFtZSI6IlRSQU5TRkVSIiwibW9kdWxlIjp7Im5hbWVzcGFjZSI6bnVsbCwibmFtZSI6ImNvaW4ifSwibW9kdWxlSGFzaCI6IjNpSUJRZEpuc3Q0NFoyWmdYb0hQa0FhdXliSjBoODVsX2VuX1NHSE5pYkUifSx7InBhcmFtcyI6WyIiLCJtdWx0aS0wMC0wMSIsMTAxMDAwMDAwXSwibmFtZSI6IlRSQU5TRkVSIiwibW9kdWxlIjp7Im5hbWVzcGFjZSI6bnVsbCwibmFtZSI6ImNvaW4ifSwibW9kdWxlSGFzaCI6IjNpSUJRZEpuc3Q0NFoyWmdYb0hQa0FhdXliSjBoODVsX2VuX1NHSE5pYkUifSx7InBhcmFtcyI6WyIiLCJtdWx0aS0wMi0wMy0wNC1hbnkiLDEyMzQwMDAwMF0sIm5hbWUiOiJUUkFOU0ZFUiIsIm1vZHVsZSI6eyJuYW1lc3BhY2UiOm51bGwsIm5hbWUiOiJjb2luIn0sIm1vZHVsZUhhc2giOiIzaUlCUWRKbnN0NDRaMlpnWG9IUGtBYXV5YkowaDg1bF9lbl9TR0hOaWJFIn0seyJwYXJhbXMiOlsiIiwiZTdmNzYzNGU5MjU1NDFmMzY4YjgyN2FkNWM3MjQyMTkwNTEwMGY2MjA1Mjg1YTc4YzE5ZDdiNGEzODcxMTgwNSIsMTUwXSwibmFtZSI6IlRSQU5TRkVSIiwibW9kdWxlIjp7Im5hbWVzcGFjZSI6bnVsbCwibmFtZSI6ImNvaW4ifSwibW9kdWxlSGFzaCI6IjNpSUJRZEpuc3Q0NFoyWmdYb0hQa0FhdXliSjBoODVsX2VuX1NHSE5pYkUifSx7InBhcmFtcyI6WyIiLCJhbGxvY2F0aW9uMDAiLDEwMDAwMF0sIm5hbWUiOiJUUkFOU0ZFUiIsIm1vZHVsZSI6eyJuYW1lc3BhY2UiOm51bGwsIm5hbWUiOiJjb2luIn0sIm1vZHVsZUhhc2giOiIzaUlCUWRKbnN0NDRaMlpnWG9IUGtBYXV5YkowaDg1bF9lbl9TR0hOaWJFIn0seyJwYXJhbXMiOlsiIiwiYWxsb2NhdGlvbjAxIiwxMDAwMDBdLCJuYW1lIjoiVFJBTlNGRVIiLCJtb2R1bGUiOnsibmFtZXNwYWNlIjpudWxsLCJuYW1lIjoiY29pbiJ9LCJtb2R1bGVIYXNoIjoiM2lJQlFkSm5zdDQ0WjJaZ1hvSFBrQWF1eWJKMGg4NWxfZW5fU0dITmliRSJ9LHsicGFyYW1zIjpbIiIsImFsbG9jYXRpb24wMiIsMTAwMDAwXSwibmFtZSI6IlRSQU5TRkVSIiwibW9kdWxlIjp7Im5hbWVzcGFjZSI6bnVsbCwibmFtZSI6ImNvaW4ifSwibW9kdWxlSGFzaCI6IjNpSUJRZEpuc3Q0NFoyWmdYb0hQa0FhdXliSjBoODVsX2VuX1NHSE5pYkUifV0sIm1ldGFEYXRhIjpudWxsLCJjb250aW51YXRpb24iOm51bGwsInR4SWQiOjh9") + , (unsafeFromText "eyJoYXNoIjoiejJtR1ZxektqeHp5bUdHLWNpWjBCSEpGM1EzeGtvOFYyNEE4ejBxcEl4ayIsInNpZ3MiOltdLCJjbWQiOiJ7XCJuZXR3b3JrSWRcIjpudWxsLFwicGF5bG9hZFwiOntcImV4ZWNcIjp7XCJkYXRhXCI6e1wic2VuZGVyMDdcIjpbXCI0YzMxZGM5ZWU3ZjI0MTc3Zjc4YjZmNTE4MDEyYTIwODMyNmUyYWYxZjM3YmIwYTI0MDViNTA1NmQwY2FkNjI4XCJdLFwic2VuZGVyMDFcIjpbXCI2YmUyZjQ4NWE3YWY3NWZlZGI0YjdmMTUzYTkwM2Y3ZTYwMDBjYTRhYTUwMTE3OWM5MWEyNDUwYjc3N2JkMmE3XCJdLFwic2VuZGVyMDZcIjpbXCI1ZmZjMWY3ZmVmN2E0NDczODYyNTc2MmY3NWE0MjI5NDU0OTUxZTAzZjJhZmM2ZjgxMzA5YzBjMWJkZjllZTZmXCJdLFwic2VuZGVyMDBcIjpbXCIzNjg4MjBmODBjMzI0YmJjN2MyYjA2MTA2ODhhN2RhNDNlMzlmOTFkMTE4NzMyNjcxY2Q5Yzc1MDBmZjQzY2NhXCJdLFwiZTdmN1wiOltcImU3Zjc2MzRlOTI1NTQxZjM2OGI4MjdhZDVjNzI0MjE5MDUxMDBmNjIwNTI4NWE3OGMxOWQ3YjRhMzg3MTE4MDVcIl0sXCJzZW5kZXIwNVwiOltcImYwOWQ4ZjYzOTRhZWE0MjVmZTY3ODNkODhjZDgxMzYzZDgwMTdmMTZhZmQzNzExYzU3NWJlMGY1Y2Q1YzliYjlcIl0sXCJzZW5kZXIwNFwiOltcIjJkNzBhYTRmNjk3YzNhM2I4ZGQ2ZDk3NzQ1YWMwNzRlZGNmZDBlYjY1YzM3Nzc0Y2RlMjUxMzU0ODNiZWE3MWVcIl0sXCJtdWx0aS0wMi0wMy0wNC1hbnlcIjp7XCJwcmVkXCI6XCJrZXlzLWFueVwiLFwia2V5c1wiOltcIjJkNzBhYTRmNjk3YzNhM2I4ZGQ2ZDk3NzQ1YWMwNzRlZGNmZDBlYjY1YzM3Nzc0Y2RlMjUxMzU0ODNiZWE3MWVcIixcIjNhOWRkNTMyZDczZGFjZTE5NWRiYjY0ZDFkYmE2NTcyZmI3ODNkMGZkZDMyNDY4NWUzMmZiZGEyZjg5Zjk5YTZcIixcIjQzZjJhZGIxZGUxOTIwMDBjYjM3NzdiYWNjN2Y5ODNiNjYxNGZkOWMxNzE1Y2Q0NGNkNDg0YjZkM2EwZDM0YzhcIl19LFwic2VuZGVyMDlcIjpbXCJjNTlkOTg0MGIwYjY2MDkwODM2NTQ2YjdlYjRhNzM2MDYyNTc1MjdlYzhjMmI0ODIzMDBmZDIyOTI2NGIwN2U2XCJdLFwic2VuZGVyMDNcIjpbXCI0M2YyYWRiMWRlMTkyMDAwY2IzNzc3YmFjYzdmOTgzYjY2MTRmZDljMTcxNWNkNDRjZDQ4NGI2ZDNhMGQzNGM4XCJdLFwibXVsdGktMDAtMDFcIjpbXCIzNjg4MjBmODBjMzI0YmJjN2MyYjA2MTA2ODhhN2RhNDNlMzlmOTFkMTE4NzMyNjcxY2Q5Yzc1MDBmZjQzY2NhXCIsXCI2YmUyZjQ4NWE3YWY3NWZlZGI0YjdmMTUzYTkwM2Y3ZTYwMDBjYTRhYTUwMTE3OWM5MWEyNDUwYjc3N2JkMmE3XCJdLFwic2VuZGVyMDhcIjpbXCI2M2IyZWJhNGVkNzBkNDYxMmQzZTdiYzkwZGIyZmJmNGM3NmY3YjA3NDM2M2U4NmQ3M2YwYmM2MTdmOGU4YjgxXCJdLFwic2VuZGVyMDJcIjpbXCIzYTlkZDUzMmQ3M2RhY2UxOTVkYmI2NGQxZGJhNjU3MmZiNzgzZDBmZGQzMjQ2ODVlMzJmYmRhMmY4OWY5OWE2XCJdfSxcImNvZGVcIjpcIihjb2luLmNvaW5iYXNlIFxcXCJzZW5kZXIwMFxcXCIgKHJlYWQta2V5c2V0IFxcXCJzZW5kZXIwMFxcXCIpIDEwMDAwMDAwMC4wKVxcbihjb2luLmNvaW5iYXNlIFxcXCJzZW5kZXIwMVxcXCIgKHJlYWQta2V5c2V0IFxcXCJzZW5kZXIwMVxcXCIpIDExMDAwMDAwMC4wKVxcbihjb2luLmNvaW5iYXNlIFxcXCJzZW5kZXIwMlxcXCIgKHJlYWQta2V5c2V0IFxcXCJzZW5kZXIwMlxcXCIpIDEyMDAwMDAwMC4wKVxcbihjb2luLmNvaW5iYXNlIFxcXCJzZW5kZXIwM1xcXCIgKHJlYWQta2V5c2V0IFxcXCJzZW5kZXIwM1xcXCIpIDEzMDAwMDAwMC4wKVxcbihjb2luLmNvaW5iYXNlIFxcXCJzZW5kZXIwNFxcXCIgKHJlYWQta2V5c2V0IFxcXCJzZW5kZXIwNFxcXCIpIDE0MDAwMDAwMC4wKVxcbihjb2luLmNvaW5iYXNlIFxcXCJzZW5kZXIwNVxcXCIgKHJlYWQta2V5c2V0IFxcXCJzZW5kZXIwNVxcXCIpIDE1MDAwMDAwMC4wKVxcbihjb2luLmNvaW5iYXNlIFxcXCJzZW5kZXIwNlxcXCIgKHJlYWQta2V5c2V0IFxcXCJzZW5kZXIwNlxcXCIpIDE2MDAwMDAwMC4wKVxcbihjb2luLmNvaW5iYXNlIFxcXCJzZW5kZXIwN1xcXCIgKHJlYWQta2V5c2V0IFxcXCJzZW5kZXIwN1xcXCIpIDE3MDAwMDAwMC4wKVxcbihjb2luLmNvaW5iYXNlIFxcXCJzZW5kZXIwOFxcXCIgKHJlYWQta2V5c2V0IFxcXCJzZW5kZXIwOFxcXCIpIDE4MDAwMDAwMC4wKVxcbihjb2luLmNvaW5iYXNlIFxcXCJzZW5kZXIwOVxcXCIgKHJlYWQta2V5c2V0IFxcXCJzZW5kZXIwOVxcXCIpIDE5MDAwMDAwMC4wKVxcbihjb2luLmNvaW5iYXNlIFxcXCJtdWx0aS0wMC0wMVxcXCIgKHJlYWQta2V5c2V0IFxcXCJtdWx0aS0wMC0wMVxcXCIpIDEwMTAwMDAwMC4wKVxcbihjb2luLmNvaW5iYXNlIFxcXCJtdWx0aS0wMi0wMy0wNC1hbnlcXFwiIChyZWFkLWtleXNldCBcXFwibXVsdGktMDItMDMtMDQtYW55XFxcIikgMTIzNDAwMDAwLjApXFxuXFxuKGNvaW4uY29pbmJhc2UgXFxcImU3Zjc2MzRlOTI1NTQxZjM2OGI4MjdhZDVjNzI0MjE5MDUxMDBmNjIwNTI4NWE3OGMxOWQ3YjRhMzg3MTE4MDVcXFwiIChyZWFkLWtleXNldCBcXFwiZTdmN1xcXCIpIDE1MC4wKVxcblxcbjsgZW5vdWdoIHRvIGNvdmVyIHRoZSBnYXMgY29zdHMgZm9yIGFsbG9jYXRpb24gcmVsZWFzZVxcbihjb2luLmNvaW5iYXNlIFxcXCJhbGxvY2F0aW9uMDBcXFwiIChrZXlzZXQtcmVmLWd1YXJkIFxcXCJhbGxvY2F0aW9uMDBcXFwiKSAxMDAwMDAuMClcXG4oY29pbi5jb2luYmFzZSBcXFwiYWxsb2NhdGlvbjAxXFxcIiAoa2V5c2V0LXJlZi1ndWFyZCBcXFwiYWxsb2NhdGlvbjAxXFxcIikgMTAwMDAwLjApXFxuKGNvaW4uY29pbmJhc2UgXFxcImFsbG9jYXRpb24wMlxcXCIgKGtleXNldC1yZWYtZ3VhcmQgXFxcImFsbG9jYXRpb24wMlxcXCIpIDEwMDAwMC4wKVwifX0sXCJzaWduZXJzXCI6W10sXCJtZXRhXCI6e1wiY3JlYXRpb25UaW1lXCI6MCxcInR0bFwiOjE3MjgwMCxcImdhc0xpbWl0XCI6MCxcImNoYWluSWRcIjpcIlwiLFwiZ2FzUHJpY2VcIjowLFwic2VuZGVyXCI6XCJcIn0sXCJub25jZVwiOlwiZGV2bmV0LWdyYW50czBcIn0ifQ", unsafeFromText "eyJnYXMiOjAsInJlc3VsdCI6eyJzdGF0dXMiOiJzdWNjZXNzIiwiZGF0YSI6IldyaXRlIHN1Y2NlZWRlZCJ9LCJyZXFLZXkiOiJ6Mm1HVnF6S2p4enltR0ctY2laMEJISkYzUTN4a284VjI0QTh6MHFwSXhrIiwibG9ncyI6ImFCUXM2aDJGVUN1a00tM0pjQmdLZGFvRU1Ta3p2OTJkM0VmT2t5MXNrMmciLCJldmVudHMiOlt7InBhcmFtcyI6WyIiLCJzZW5kZXIwMCIsMTAwMDAwMDAwXSwibmFtZSI6IlRSQU5TRkVSIiwibW9kdWxlIjp7Im5hbWVzcGFjZSI6bnVsbCwibmFtZSI6ImNvaW4ifSwibW9kdWxlSGFzaCI6IjNpSUJRZEpuc3Q0NFoyWmdYb0hQa0FhdXliSjBoODVsX2VuX1NHSE5pYkUifSx7InBhcmFtcyI6WyIiLCJzZW5kZXIwMSIsMTEwMDAwMDAwXSwibmFtZSI6IlRSQU5TRkVSIiwibW9kdWxlIjp7Im5hbWVzcGFjZSI6bnVsbCwibmFtZSI6ImNvaW4ifSwibW9kdWxlSGFzaCI6IjNpSUJRZEpuc3Q0NFoyWmdYb0hQa0FhdXliSjBoODVsX2VuX1NHSE5pYkUifSx7InBhcmFtcyI6WyIiLCJzZW5kZXIwMiIsMTIwMDAwMDAwXSwibmFtZSI6IlRSQU5TRkVSIiwibW9kdWxlIjp7Im5hbWVzcGFjZSI6bnVsbCwibmFtZSI6ImNvaW4ifSwibW9kdWxlSGFzaCI6IjNpSUJRZEpuc3Q0NFoyWmdYb0hQa0FhdXliSjBoODVsX2VuX1NHSE5pYkUifSx7InBhcmFtcyI6WyIiLCJzZW5kZXIwMyIsMTMwMDAwMDAwXSwibmFtZSI6IlRSQU5TRkVSIiwibW9kdWxlIjp7Im5hbWVzcGFjZSI6bnVsbCwibmFtZSI6ImNvaW4ifSwibW9kdWxlSGFzaCI6IjNpSUJRZEpuc3Q0NFoyWmdYb0hQa0FhdXliSjBoODVsX2VuX1NHSE5pYkUifSx7InBhcmFtcyI6WyIiLCJzZW5kZXIwNCIsMTQwMDAwMDAwXSwibmFtZSI6IlRSQU5TRkVSIiwibW9kdWxlIjp7Im5hbWVzcGFjZSI6bnVsbCwibmFtZSI6ImNvaW4ifSwibW9kdWxlSGFzaCI6IjNpSUJRZEpuc3Q0NFoyWmdYb0hQa0FhdXliSjBoODVsX2VuX1NHSE5pYkUifSx7InBhcmFtcyI6WyIiLCJzZW5kZXIwNSIsMTUwMDAwMDAwXSwibmFtZSI6IlRSQU5TRkVSIiwibW9kdWxlIjp7Im5hbWVzcGFjZSI6bnVsbCwibmFtZSI6ImNvaW4ifSwibW9kdWxlSGFzaCI6IjNpSUJRZEpuc3Q0NFoyWmdYb0hQa0FhdXliSjBoODVsX2VuX1NHSE5pYkUifSx7InBhcmFtcyI6WyIiLCJzZW5kZXIwNiIsMTYwMDAwMDAwXSwibmFtZSI6IlRSQU5TRkVSIiwibW9kdWxlIjp7Im5hbWVzcGFjZSI6bnVsbCwibmFtZSI6ImNvaW4ifSwibW9kdWxlSGFzaCI6IjNpSUJRZEpuc3Q0NFoyWmdYb0hQa0FhdXliSjBoODVsX2VuX1NHSE5pYkUifSx7InBhcmFtcyI6WyIiLCJzZW5kZXIwNyIsMTcwMDAwMDAwXSwibmFtZSI6IlRSQU5TRkVSIiwibW9kdWxlIjp7Im5hbWVzcGFjZSI6bnVsbCwibmFtZSI6ImNvaW4ifSwibW9kdWxlSGFzaCI6IjNpSUJRZEpuc3Q0NFoyWmdYb0hQa0FhdXliSjBoODVsX2VuX1NHSE5pYkUifSx7InBhcmFtcyI6WyIiLCJzZW5kZXIwOCIsMTgwMDAwMDAwXSwibmFtZSI6IlRSQU5TRkVSIiwibW9kdWxlIjp7Im5hbWVzcGFjZSI6bnVsbCwibmFtZSI6ImNvaW4ifSwibW9kdWxlSGFzaCI6IjNpSUJRZEpuc3Q0NFoyWmdYb0hQa0FhdXliSjBoODVsX2VuX1NHSE5pYkUifSx7InBhcmFtcyI6WyIiLCJzZW5kZXIwOSIsMTkwMDAwMDAwXSwibmFtZSI6IlRSQU5TRkVSIiwibW9kdWxlIjp7Im5hbWVzcGFjZSI6bnVsbCwibmFtZSI6ImNvaW4ifSwibW9kdWxlSGFzaCI6IjNpSUJRZEpuc3Q0NFoyWmdYb0hQa0FhdXliSjBoODVsX2VuX1NHSE5pYkUifSx7InBhcmFtcyI6WyIiLCJtdWx0aS0wMC0wMSIsMTAxMDAwMDAwXSwibmFtZSI6IlRSQU5TRkVSIiwibW9kdWxlIjp7Im5hbWVzcGFjZSI6bnVsbCwibmFtZSI6ImNvaW4ifSwibW9kdWxlSGFzaCI6IjNpSUJRZEpuc3Q0NFoyWmdYb0hQa0FhdXliSjBoODVsX2VuX1NHSE5pYkUifSx7InBhcmFtcyI6WyIiLCJtdWx0aS0wMi0wMy0wNC1hbnkiLDEyMzQwMDAwMF0sIm5hbWUiOiJUUkFOU0ZFUiIsIm1vZHVsZSI6eyJuYW1lc3BhY2UiOm51bGwsIm5hbWUiOiJjb2luIn0sIm1vZHVsZUhhc2giOiIzaUlCUWRKbnN0NDRaMlpnWG9IUGtBYXV5YkowaDg1bF9lbl9TR0hOaWJFIn0seyJwYXJhbXMiOlsiIiwiZTdmNzYzNGU5MjU1NDFmMzY4YjgyN2FkNWM3MjQyMTkwNTEwMGY2MjA1Mjg1YTc4YzE5ZDdiNGEzODcxMTgwNSIsMTUwXSwibmFtZSI6IlRSQU5TRkVSIiwibW9kdWxlIjp7Im5hbWVzcGFjZSI6bnVsbCwibmFtZSI6ImNvaW4ifSwibW9kdWxlSGFzaCI6IjNpSUJRZEpuc3Q0NFoyWmdYb0hQa0FhdXliSjBoODVsX2VuX1NHSE5pYkUifSx7InBhcmFtcyI6WyIiLCJhbGxvY2F0aW9uMDAiLDEwMDAwMF0sIm5hbWUiOiJUUkFOU0ZFUiIsIm1vZHVsZSI6eyJuYW1lc3BhY2UiOm51bGwsIm5hbWUiOiJjb2luIn0sIm1vZHVsZUhhc2giOiIzaUlCUWRKbnN0NDRaMlpnWG9IUGtBYXV5YkowaDg1bF9lbl9TR0hOaWJFIn0seyJwYXJhbXMiOlsiIiwiYWxsb2NhdGlvbjAxIiwxMDAwMDBdLCJuYW1lIjoiVFJBTlNGRVIiLCJtb2R1bGUiOnsibmFtZXNwYWNlIjpudWxsLCJuYW1lIjoiY29pbiJ9LCJtb2R1bGVIYXNoIjoiM2lJQlFkSm5zdDQ0WjJaZ1hvSFBrQWF1eWJKMGg4NWxfZW5fU0dITmliRSJ9LHsicGFyYW1zIjpbIiIsImFsbG9jYXRpb24wMiIsMTAwMDAwXSwibmFtZSI6IlRSQU5TRkVSIiwibW9kdWxlIjp7Im5hbWVzcGFjZSI6bnVsbCwibmFtZSI6ImNvaW4ifSwibW9kdWxlSGFzaCI6IjNpSUJRZEpuc3Q0NFoyWmdYb0hQa0FhdXliSjBoODVsX2VuX1NHSE5pYkUifV0sIm1ldGFEYXRhIjpudWxsLCJjb250aW51YXRpb24iOm51bGwsInR4SWQiOjh9") ] diff --git a/src/Chainweb/BlockHeader/Genesis/Pact53TransitionTimedCPM1to9Payload.hs b/src/Chainweb/BlockHeader/Genesis/Pact53TransitionTimedCPM1to9Payload.hs index cbe7800a24..419d4df22c 100644 --- a/src/Chainweb/BlockHeader/Genesis/Pact53TransitionTimedCPM1to9Payload.hs +++ b/src/Chainweb/BlockHeader/Genesis/Pact53TransitionTimedCPM1to9Payload.hs @@ -8,7 +8,7 @@ import qualified Data.Text as T import qualified Data.Vector as V import GHC.Stack -import Chainweb.Payload +import Chainweb.Pact.Payload import Chainweb.Utils (unsafeFromText, toText) payloadBlock :: HasCallStack => PayloadWithOutputs @@ -21,7 +21,7 @@ payloadBlock where actualHash, expectedHash :: BlockPayloadHash actualHash = _payloadWithOutputsPayloadHash payload - expectedHash = unsafeFromText "yHOBLd5WogOZQno-TBaG3gFePMVDvY1RPFuAib4SyWY" + expectedHash = unsafeFromText "gMX0oIeFRI4dKlraTBi2pLwfvVDqBH-5qEbcWAkk1jg" payload = newPayloadWithOutputs minerData coinbase txs minerData = unsafeFromText "eyJhY2NvdW50IjoiTm9NaW5lciIsInByZWRpY2F0ZSI6IjwiLCJwdWJsaWMta2V5cyI6W119" @@ -35,5 +35,5 @@ payloadBlock , (unsafeFromText "eyJoYXNoIjoiQ1pteWxXZmllUk1CTXU1dzJFT21wRndLLXQ3YmNPVHM0bUsyYVQzM3VSNCIsInNpZ3MiOltdLCJjbWQiOiJ7XCJuZXR3b3JrSWRcIjpudWxsLFwicGF5bG9hZFwiOntcImV4ZWNcIjp7XCJkYXRhXCI6e1wibnMtYWRtaW4ta2V5c2V0XCI6W1wiMzY4ODIwZjgwYzMyNGJiYzdjMmIwNjEwNjg4YTdkYTQzZTM5ZjkxZDExODczMjY3MWNkOWM3NTAwZmY0M2NjYVwiXSxcIm5zLW9wZXJhdGUta2V5c2V0XCI6W1wiMzY4ODIwZjgwYzMyNGJiYzdjMmIwNjEwNjg4YTdkYTQzZTM5ZjkxZDExODczMjY3MWNkOWM3NTAwZmY0M2NjYVwiXSxcIm5zLWdlbmVzaXMta2V5c2V0XCI6e1wicHJlZFwiOlwiPVwiLFwia2V5c1wiOltdfX0sXCJjb2RlXCI6XCIoZGVmaW5lLWtleXNldCAnbnMtYWRtaW4ta2V5c2V0IChyZWFkLWtleXNldCAnbnMtYWRtaW4ta2V5c2V0KSlcXG4oZGVmaW5lLWtleXNldCAnbnMtb3BlcmF0ZS1rZXlzZXQgKHJlYWQta2V5c2V0ICducy1nZW5lc2lzLWtleXNldCkpXFxuXFxuKG1vZHVsZSBucyBHT1ZFUk5BTkNFXFxuICBcXFwiQWRtaW5pc3RlcnMgZGVmaW5pdGlvbiBvZiBuZXcgbmFtZXNwYWNlcyBpbiBDaGFpbndlYi5cXFwiXFxuXFxuICAoZGVmc2NoZW1hIHJlZy1lbnRyeVxcbiAgICBhZG1pbi1ndWFyZDpndWFyZFxcbiAgICBhY3RpdmU6Ym9vbClcXG5cXG4gIChkZWZ0YWJsZSByZWdpc3RyeTp7cmVnLWVudHJ5fSlcXG5cXG4gIChkZWZjYXAgR09WRVJOQU5DRSAoKVxcbiAgICAoZW5mb3JjZS1rZXlzZXQgJ25zLWFkbWluLWtleXNldCkpXFxuXFxuICAoZGVmY2FwIE9QRVJBVEUgKClcXG4gICAgKGVuZm9yY2Uta2V5c2V0ICducy1vcGVyYXRlLWtleXNldCkpXFxuXFxuICAoZGVmY29uc3QgR1VBUkRfU1VDQ0VTUyAoY3JlYXRlLXVzZXItZ3VhcmQgKHN1Y2Nlc3MpKSlcXG4gIChkZWZjb25zdCBHVUFSRF9GQUlMVVJFIChjcmVhdGUtdXNlci1ndWFyZCAoZmFpbHVyZSkpKVxcblxcbiAgKGRlZnVuIHN1Y2Nlc3MgKClcXG4gICAgdHJ1ZSlcXG4gIChkZWZ1biBmYWlsdXJlICgpXFxuICAgIChlbmZvcmNlIGZhbHNlIFxcXCJEaXNhYmxlZFxcXCIpKVxcblxcbiAgKGRlZnVuIHZhbGlkYXRlLW5hbWUgKG5hbWUpXFxuICAgIChlbmZvcmNlICghPSBcXFwiXFxcIiBuYW1lKSBcXFwiRW1wdHkgbmFtZSBub3QgYWxsb3dlZFxcXCIpXFxuICAgIChlbmZvcmNlICg8IChsZW5ndGggbmFtZSkgNjQpIFxcXCJOYW1lIG11c3QgYmUgbGVzcyB0aGFuIDY0IGNoYXJhY3RlcnMgbG9uZ1xcXCIpXFxuICAgIChlbmZvcmNlIChpcy1jaGFyc2V0IENIQVJTRVRfTEFUSU4xIG5hbWUpXFxuICAgICAgICAgICAgIFxcXCJOYW1lIG11c3QgYmUgaW4gbGF0aW4xIGNoYXJzZXRcXFwiKSlcXG5cXG4gIChkZWZ1biBjcmVhdGUtcHJpbmNpcGFsLW5hbWVzcGFjZTpzdHJpbmdcXG4gICAgICAoIGc6Z3VhcmRcXG4gICAgICAgIClcXG4gICAgXFxcIiBGb3JtYXQgcHJpbmNpcGFsIG5hbWVzcGFjZSBhcyBQYWN0IGhhc2ggKEJMQUtFMmIyNTYpIG9mIHByaW5jaXBhbCBcXFxcXFxuICAgIFxcXFwgaW4gaGV4IHRydW5jYXRlZCB0byAxNjAgYml0cyAoNDAgY2hhcmFjdGVycyksIHByZXBlbmRlZCB3aXRoICduXycuXFxcXFxcbiAgICBcXFxcIE9ubHkgdzogYW5kIGs6IGFjY291bnQgcHJvdG9jb2xzIGFyZSBzdXBwb3J0ZWQuIFxcXCJcXG5cXG4gICAgKGxldFxcbiAgICAgICgodHkgKHR5cGVvZi1wcmluY2lwYWwgKGNyZWF0ZS1wcmluY2lwYWwgZykpKSlcXG5cXG4gICAgICA7OyBvbmx5IHc6IGFuZCBrOiBjdXJyZW50bHkgc3VwcG9ydGVkXFxuICAgICAgKGlmIChvciAoPSB0eSBcXFwiazpcXFwiKSAoPSB0eSBcXFwidzpcXFwiKSlcXG4gICAgICAgICgrIFxcXCJuX1xcXCIgKHRha2UgNDAgKGludC10by1zdHIgMTYgKHN0ci10by1pbnQgNjQgKGhhc2ggZykpKSkpXFxuICAgICAgICAoZW5mb3JjZSBmYWxzZVxcbiAgICAgICAgICAoZm9ybWF0IFxcXCJVbnN1cHBvcnRlZCBndWFyZCBwcm90b2NvbDoge31cXFwiIFt0eV0pKVxcbiAgICAgICAgKSlcXG4gIClcXG5cXG4gIChkZWZ1biB2YWxpZGF0ZTpib29sXFxuICAgICAgKCBucy1uYW1lOnN0cmluZ1xcbiAgICAgICAgbnMtYWRtaW46Z3VhcmRcXG4gICAgICAgIClcXG4gICAgXFxcIiBNYW5hZ2VzIG5hbWVzcGFjZSBpbnN0YWxsIGZvciBDaGFpbndlYi4gXFxcXFxcbiAgICBcXFxcIEFsbG93cyBwcmluY2lwYWwgbmFtZXNwYWNlcy4gXFxcXFxcbiAgICBcXFxcIE5vbi1wcmluY2lwYWwgbmFtZXNwYWNlcyByZXF1aXJlIGFjdGl2ZSByb3cgaW4gcmVnaXN0cnkgXFxcXFxcbiAgICBcXFxcIGZvciBOUy1OQU1FIHdpdGggZ3VhcmQgbWF0Y2hpbmcgTlMtQURNSU4uXFxcIlxcblxcbiAgICAoaWYgKD0gKGNyZWF0ZS1wcmluY2lwYWwtbmFtZXNwYWNlIG5zLWFkbWluKSBucy1uYW1lKVxcblxcbiAgICAgIHRydWUgOzsgYWxsb3cgcHJpbmNpcGFsIG5hbWVzcGFjZXNcXG5cXG4gICAgICAod2l0aC1kZWZhdWx0LXJlYWQgcmVnaXN0cnkgbnMtbmFtZSAgICAgICA7OyBvdGhlcndpc2UgZW5mb3JjZSByZWdpc3RyeVxcbiAgICAgICAgeyAnYWRtaW4tZ3VhcmQgOiBucy1hZG1pblxcbiAgICAgICAgLCAnYWN0aXZlIDogZmFsc2UgfVxcbiAgICAgICAgeyAnYWRtaW4tZ3VhcmQgOj0gYWdcXG4gICAgICAgICwgJ2FjdGl2ZSA6PSBpcy1hY3RpdmUgfVxcblxcbiAgICAgICAgKGVuZm9yY2UgaXMtYWN0aXZlIFxcXCJJbmFjdGl2ZSBvciB1bnJlZ2lzdGVyZWQgbmFtZXNwYWNlXFxcIilcXG4gICAgICAgIChlbmZvcmNlICg9IG5zLWFkbWluIGFnKSBcXFwiQWRtaW4gZ3VhcmQgbXVzdCBtYXRjaCBndWFyZCBpbiByZWdpc3RyeVxcXCIpXFxuXFxuICAgICAgICB0cnVlKVxcbiAgICAgICkpXFxuXFxuICAoZGVmdW4gd3JpdGUtcmVnaXN0cnk6c3RyaW5nXFxuICAgICAgKCBucy1uYW1lOnN0cmluZ1xcbiAgICAgICAgZ3VhcmQ6Z3VhcmRcXG4gICAgICAgIGFjdGl2ZTpib29sXFxuICAgICAgICApXFxuICAgIFxcXCIgV3JpdGUgZW50cnkgd2l0aCBHVUFSRCBhbmQgQUNUSVZFIGludG8gcmVnaXN0cnkgZm9yIE5BTUUuIFxcXFxcXG4gICAgXFxcXCBHdWFyZGVkIGJ5IG9wZXJhdGUga2V5c2V0LiBcXFwiXFxuXFxuICAgICh3aXRoLWNhcGFiaWxpdHkgKE9QRVJBVEUpXFxuXFxuICAgICAgKHZhbGlkYXRlLW5hbWUgbnMtbmFtZSlcXG5cXG4gICAgICAod3JpdGUgcmVnaXN0cnkgbnMtbmFtZVxcbiAgICAgICAgeyAnYWRtaW4tZ3VhcmQ6IGd1YXJkXFxuICAgICAgICAsICdhY3RpdmU6IGFjdGl2ZSB9KVxcblxcbiAgICAgIFxcXCJSZWdpc3RlciBlbnRyeSB3cml0dGVuXFxcIikpXFxuXFxuICAoZGVmdW4gcXVlcnk6b2JqZWN0e3JlZy1lbnRyeX1cXG4gICAgICAoIG5zLW5hbWU6c3RyaW5nIClcXG4gICAgKHJlYWQgcmVnaXN0cnkgbnMtbmFtZSkpXFxuXFxuKVxcblxcbihjcmVhdGUtdGFibGUgcmVnaXN0cnkpXFxuXFxuKHdyaXRlLXJlZ2lzdHJ5IFxcXCJrYWRlbmFcXFwiXFxuICAoa2V5c2V0LXJlZi1ndWFyZCAnbnMtb3BlcmF0ZS1rZXlzZXQpIHRydWUpXFxuKHdyaXRlLXJlZ2lzdHJ5IFxcXCJ1c2VyXFxcIiBHVUFSRF9GQUlMVVJFIHRydWUpXFxuKHdyaXRlLXJlZ2lzdHJ5IFxcXCJmcmVlXFxcIiBHVUFSRF9GQUlMVVJFIHRydWUpXFxuXFxuKGRlZmluZS1uYW1lc3BhY2UgXFxcImthZGVuYVxcXCJcXG4gIChrZXlzZXQtcmVmLWd1YXJkICducy1vcGVyYXRlLWtleXNldClcXG4gIChrZXlzZXQtcmVmLWd1YXJkICducy1vcGVyYXRlLWtleXNldCkpXFxuXFxuKGRlZmluZS1uYW1lc3BhY2UgXFxcInVzZXJcXFwiIEdVQVJEX1NVQ0NFU1MgR1VBUkRfRkFJTFVSRSlcXG4oZGVmaW5lLW5hbWVzcGFjZSBcXFwiZnJlZVxcXCIgR1VBUkRfU1VDQ0VTUyBHVUFSRF9GQUlMVVJFKVxcbjs7cm90YXRlIHRvIHJlYWwgb3BlcmF0ZSBrZXlzZXRcXG4oZGVmaW5lLWtleXNldCAnbnMtb3BlcmF0ZS1rZXlzZXQgKHJlYWQta2V5c2V0ICducy1vcGVyYXRlLWtleXNldCkpXFxuXCJ9fSxcInNpZ25lcnNcIjpbXSxcIm1ldGFcIjp7XCJjcmVhdGlvblRpbWVcIjowLFwidHRsXCI6MTcyODAwLFwiZ2FzTGltaXRcIjowLFwiY2hhaW5JZFwiOlwiXCIsXCJnYXNQcmljZVwiOjAsXCJzZW5kZXJcIjpcIlwifSxcIm5vbmNlXCI6XCJsb2FkLW5zLWRldm5ldC1zZW5kZXIwMFwifSJ9", unsafeFromText "eyJnYXMiOjAsInJlc3VsdCI6eyJzdGF0dXMiOiJzdWNjZXNzIiwiZGF0YSI6IktleXNldCB3cml0ZSBzdWNjZXNzIn0sInJlcUtleSI6IkNabXlsV2ZpZVJNQk11NXcyRU9tcEZ3Sy10N2JjT1RzNG1LMmFUMzN1UjQiLCJsb2dzIjoiUUhPVmJXQ09OZTcydDJXZ28xN0w4Z1JpRk55alJndFdnZFZNRWNXX0ZiayIsIm1ldGFEYXRhIjpudWxsLCJjb250aW51YXRpb24iOm51bGwsInR4SWQiOjV9") , (unsafeFromText "eyJoYXNoIjoiWE5BNmxPSjFXLTdYWXY1WWI0QXFsNzRveFlJN09KcWpPUVQ1b1k0OHEtZyIsInNpZ3MiOltdLCJjbWQiOiJ7XCJuZXR3b3JrSWRcIjpudWxsLFwicGF5bG9hZFwiOntcImV4ZWNcIjp7XCJkYXRhXCI6e1wiYWxsb2NhdGlvbi10ZXN0MDFcIjpbXCI3MDExYzM3OTE0MGZmODk5ZjdlNjEzYWMwYTk3ODRhN2MwYTUxNWQzMGZlMGFiMmIwYzA3ZTVhYTE3NjM1ZTNlXCJdLFwiYWxsb2NhdGlvbjAyXCI6W1wiZTllNGU3MWJkMDYzZGNmN2UwNmJkNWIxYTE2Njg4ODk3ZDE1Y2E4YmQyZTUwOWM0NTNjNjE2MjE5YzE4NmNjNVwiXSxcImFsbG9jYXRpb24wMFwiOltcImQ4MmQwZGNkZTk4MjU1MDVkODZhZmI2ZGNjMTA0MTFkNmI2N2E0MjlhNzllMjFiZGE0YmIxMTliZjI4YWI4NzFcIl0sXCJhbGxvY2F0aW9uLXRlc3QwMlwiOltcIjA2NTQ0ZTIyYmZlZjIzMGQ2ZDIyZjk0ODZhYzZjYjc2YmYyNThlYmZiZjAxMzdlZTU4ZjY1NzQzZTFhNWI4YzRcIl0sXCJhbGxvY2F0aW9uMDFcIjpbXCJiNGM4YTNlYTkxZDMxNDZiMDU2MDk5NDc0MGYwZTNlZWQ5MWM1OWQyZWVjYTFkYzk5ZjBjMjg3Mjg0NWMyOTRkXCJdfSxcImNvZGVcIjpcIihkZWZpbmUta2V5c2V0IFxcXCJhbGxvY2F0aW9uMDBcXFwiIChyZWFkLWtleXNldCBcXFwiYWxsb2NhdGlvbjAwXFxcIikpXFxuKGRlZmluZS1rZXlzZXQgXFxcImFsbG9jYXRpb24wMVxcXCIgKHJlYWQta2V5c2V0IFxcXCJhbGxvY2F0aW9uMDFcXFwiKSlcXG4oZGVmaW5lLWtleXNldCBcXFwiYWxsb2NhdGlvbjAyXFxcIiAocmVhZC1rZXlzZXQgXFxcImFsbG9jYXRpb24wMlxcXCIpKVxcbihkZWZpbmUta2V5c2V0IFxcXCJhbGxvY2F0aW9uLXRlc3QwMVxcXCIgKHJlYWQta2V5c2V0IFxcXCJhbGxvY2F0aW9uLXRlc3QwMVxcXCIpKVxcbihkZWZpbmUta2V5c2V0IFxcXCJhbGxvY2F0aW9uLXRlc3QwMlxcXCIgKHJlYWQta2V5c2V0IFxcXCJhbGxvY2F0aW9uLXRlc3QwMlxcXCIpKVwifX0sXCJzaWduZXJzXCI6W10sXCJtZXRhXCI6e1wiY3JlYXRpb25UaW1lXCI6MCxcInR0bFwiOjE3MjgwMCxcImdhc0xpbWl0XCI6MCxcImNoYWluSWRcIjpcIlwiLFwiZ2FzUHJpY2VcIjowLFwic2VuZGVyXCI6XCJcIn0sXCJub25jZVwiOlwiZGV2bmV0LWtleXNldHNcIn0ifQ", unsafeFromText "eyJnYXMiOjAsInJlc3VsdCI6eyJzdGF0dXMiOiJzdWNjZXNzIiwiZGF0YSI6IktleXNldCB3cml0ZSBzdWNjZXNzIn0sInJlcUtleSI6IlhOQTZsT0oxVy03WFl2NVliNEFxbDc0b3hZSTdPSnFqT1FUNW9ZNDhxLWciLCJsb2dzIjoiYXJRSWpQVGRrcXhoQTNjWl9WaVE3OXM3Uk5XRTlGV2Rha0xWdXl4Nlc0YyIsIm1ldGFEYXRhIjpudWxsLCJjb250aW51YXRpb24iOm51bGwsInR4SWQiOjZ9") , (unsafeFromText "eyJoYXNoIjoiNWtxZ0tzWWtwbjZCcS1KUnhNYnA1VG9jUWhRWGRJVVNiM1NGQm1Ba3VWcyIsInNpZ3MiOltdLCJjbWQiOiJ7XCJuZXR3b3JrSWRcIjpudWxsLFwicGF5bG9hZFwiOntcImV4ZWNcIjp7XCJkYXRhXCI6bnVsbCxcImNvZGVcIjpcIihjb2luLmNyZWF0ZS1hbGxvY2F0aW9uLWFjY291bnQgXFxcImFsbG9jYXRpb24wMFxcXCIgKHRpbWUgXFxcIjE5MDAtMTAtMTVUMTg6MDA6MDBaXFxcIikgXFxcImFsbG9jYXRpb24wMFxcXCIgMTAwMDAwMC4wKVxcbihjb2luLmNyZWF0ZS1hbGxvY2F0aW9uLWFjY291bnQgXFxcImFsbG9jYXRpb24wMVxcXCIgKHRpbWUgXFxcIjIxMDAtMTAtMzFUMTg6MDA6MDBaXFxcIikgXFxcImFsbG9jYXRpb24wMVxcXCIgMTAwMDAwMC4wKVxcbihjb2luLmNyZWF0ZS1hbGxvY2F0aW9uLWFjY291bnQgXFxcImFsbG9jYXRpb24wMlxcXCIgKHRpbWUgXFxcIjE5MDAtMTAtMzFUMTg6MDA6MDBaXFxcIikgXFxcImFsbG9jYXRpb24wMlxcXCIgMTAwMDAwMC4wKVxcbihjb2luLmNyZWF0ZS1hbGxvY2F0aW9uLWFjY291bnQgXFxcImFsbG9jYXRpb24tdGVzdDAxXFxcIiAodGltZSBcXFwiMTkwMC0xMC0zMVQxODowMDowMFpcXFwiKSBcXFwiYWxsb2NhdGlvbi10ZXN0MDFcXFwiIDEwMDAwMDAuMClcXG4oY29pbi5jcmVhdGUtYWxsb2NhdGlvbi1hY2NvdW50IFxcXCJhbGxvY2F0aW9uLXRlc3QwMlxcXCIgKHRpbWUgXFxcIjE5MDAtMTAtMzFUMTg6MDA6MDBaXFxcIikgXFxcImFsbG9jYXRpb24tdGVzdDAyXFxcIiAyMDAwMDAwLjApXCJ9fSxcInNpZ25lcnNcIjpbXSxcIm1ldGFcIjp7XCJjcmVhdGlvblRpbWVcIjowLFwidHRsXCI6MTcyODAwLFwiZ2FzTGltaXRcIjowLFwiY2hhaW5JZFwiOlwiXCIsXCJnYXNQcmljZVwiOjAsXCJzZW5kZXJcIjpcIlwifSxcIm5vbmNlXCI6XCJkZXZuZXQtYWxsb2NhdGlvbnNcIn0ifQ", unsafeFromText "eyJnYXMiOjAsInJlc3VsdCI6eyJzdGF0dXMiOiJzdWNjZXNzIiwiZGF0YSI6IldyaXRlIHN1Y2NlZWRlZCJ9LCJyZXFLZXkiOiI1a3FnS3NZa3BuNkJxLUpSeE1icDVUb2NRaFFYZElVU2IzU0ZCbUFrdVZzIiwibG9ncyI6IkhpX3ZfVEhFT2s2aEJFRU0yWmV2Vzh3eVJsQWpUZzNjVUQydXBlVkx0b1UiLCJtZXRhRGF0YSI6bnVsbCwiY29udGludWF0aW9uIjpudWxsLCJ0eElkIjo3fQ") - , (unsafeFromText "eyJoYXNoIjoiZjIxVTFJRnlRN0ZfLTRlTnR6QTFuWnZjQ0g5cnY5ZnZsNWM1a0RyNXFsdyIsInNpZ3MiOltdLCJjbWQiOiJ7XCJuZXR3b3JrSWRcIjpudWxsLFwicGF5bG9hZFwiOntcImV4ZWNcIjp7XCJkYXRhXCI6e1wic2VuZGVyMDdcIjpbXCI0YzMxZGM5ZWU3ZjI0MTc3Zjc4YjZmNTE4MDEyYTIwODMyNmUyYWYxZjM3YmIwYTI0MDViNTA1NmQwY2FkNjI4XCJdLFwic2VuZGVyMDFcIjpbXCI2YmUyZjQ4NWE3YWY3NWZlZGI0YjdmMTUzYTkwM2Y3ZTYwMDBjYTRhYTUwMTE3OWM5MWEyNDUwYjc3N2JkMmE3XCJdLFwic2VuZGVyMDZcIjpbXCI1ZmZjMWY3ZmVmN2E0NDczODYyNTc2MmY3NWE0MjI5NDU0OTUxZTAzZjJhZmM2ZjgxMzA5YzBjMWJkZjllZTZmXCJdLFwic2VuZGVyMDBcIjpbXCIzNjg4MjBmODBjMzI0YmJjN2MyYjA2MTA2ODhhN2RhNDNlMzlmOTFkMTE4NzMyNjcxY2Q5Yzc1MDBmZjQzY2NhXCJdLFwiZTdmN1wiOltcImU3Zjc2MzRlOTI1NTQxZjM2OGI4MjdhZDVjNzI0MjE5MDUxMDBmNjIwNTI4NWE3OGMxOWQ3YjRhMzg3MTE4MDVcIl0sXCJzZW5kZXIwNVwiOltcImYwOWQ4ZjYzOTRhZWE0MjVmZTY3ODNkODhjZDgxMzYzZDgwMTdmMTZhZmQzNzExYzU3NWJlMGY1Y2Q1YzliYjlcIl0sXCJzZW5kZXIwNFwiOltcIjJkNzBhYTRmNjk3YzNhM2I4ZGQ2ZDk3NzQ1YWMwNzRlZGNmZDBlYjY1YzM3Nzc0Y2RlMjUxMzU0ODNiZWE3MWVcIl0sXCJtdWx0aS0wMi0wMy0wNC1hbnlcIjp7XCJwcmVkXCI6XCJrZXlzLWFueVwiLFwia2V5c1wiOltcIjNhOWRkNTMyZDczZGFjZTE5NWRiYjY0ZDFkYmE2NTcyZmI3ODNkMGZkZDMyNDY4NWUzMmZiZGEyZjg5Zjk5YTZcIixcIjQzZjJhZGIxZGUxOTIwMDBjYjM3NzdiYWNjN2Y5ODNiNjYxNGZkOWMxNzE1Y2Q0NGNkNDg0YjZkM2EwZDM0YzhcIixcIjJkNzBhYTRmNjk3YzNhM2I4ZGQ2ZDk3NzQ1YWMwNzRlZGNmZDBlYjY1YzM3Nzc0Y2RlMjUxMzU0ODNiZWE3MWVcIl19LFwic2VuZGVyMDlcIjpbXCJjNTlkOTg0MGIwYjY2MDkwODM2NTQ2YjdlYjRhNzM2MDYyNTc1MjdlYzhjMmI0ODIzMDBmZDIyOTI2NGIwN2U2XCJdLFwic2VuZGVyMDNcIjpbXCI0M2YyYWRiMWRlMTkyMDAwY2IzNzc3YmFjYzdmOTgzYjY2MTRmZDljMTcxNWNkNDRjZDQ4NGI2ZDNhMGQzNGM4XCJdLFwibXVsdGktMDAtMDFcIjpbXCIzNjg4MjBmODBjMzI0YmJjN2MyYjA2MTA2ODhhN2RhNDNlMzlmOTFkMTE4NzMyNjcxY2Q5Yzc1MDBmZjQzY2NhXCIsXCI2YmUyZjQ4NWE3YWY3NWZlZGI0YjdmMTUzYTkwM2Y3ZTYwMDBjYTRhYTUwMTE3OWM5MWEyNDUwYjc3N2JkMmE3XCJdLFwic2VuZGVyMDhcIjpbXCI2M2IyZWJhNGVkNzBkNDYxMmQzZTdiYzkwZGIyZmJmNGM3NmY3YjA3NDM2M2U4NmQ3M2YwYmM2MTdmOGU4YjgxXCJdLFwic2VuZGVyMDJcIjpbXCIzYTlkZDUzMmQ3M2RhY2UxOTVkYmI2NGQxZGJhNjU3MmZiNzgzZDBmZGQzMjQ2ODVlMzJmYmRhMmY4OWY5OWE2XCJdfSxcImNvZGVcIjpcIihjb2luLmNvaW5iYXNlIFxcXCJzZW5kZXIwMFxcXCIgKHJlYWQta2V5c2V0IFxcXCJzZW5kZXIwMFxcXCIpIDEwMDAwMDAwMC4wKVxcbihjb2luLmNvaW5iYXNlIFxcXCJzZW5kZXIwMVxcXCIgKHJlYWQta2V5c2V0IFxcXCJzZW5kZXIwMVxcXCIpIDExMDAwMDAwMC4wKVxcbihjb2luLmNvaW5iYXNlIFxcXCJzZW5kZXIwMlxcXCIgKHJlYWQta2V5c2V0IFxcXCJzZW5kZXIwMlxcXCIpIDEyMDAwMDAwMC4wKVxcbihjb2luLmNvaW5iYXNlIFxcXCJzZW5kZXIwM1xcXCIgKHJlYWQta2V5c2V0IFxcXCJzZW5kZXIwM1xcXCIpIDEzMDAwMDAwMC4wKVxcbihjb2luLmNvaW5iYXNlIFxcXCJzZW5kZXIwNFxcXCIgKHJlYWQta2V5c2V0IFxcXCJzZW5kZXIwNFxcXCIpIDE0MDAwMDAwMC4wKVxcbihjb2luLmNvaW5iYXNlIFxcXCJzZW5kZXIwNVxcXCIgKHJlYWQta2V5c2V0IFxcXCJzZW5kZXIwNVxcXCIpIDE1MDAwMDAwMC4wKVxcbihjb2luLmNvaW5iYXNlIFxcXCJzZW5kZXIwNlxcXCIgKHJlYWQta2V5c2V0IFxcXCJzZW5kZXIwNlxcXCIpIDE2MDAwMDAwMC4wKVxcbihjb2luLmNvaW5iYXNlIFxcXCJzZW5kZXIwN1xcXCIgKHJlYWQta2V5c2V0IFxcXCJzZW5kZXIwN1xcXCIpIDE3MDAwMDAwMC4wKVxcbihjb2luLmNvaW5iYXNlIFxcXCJzZW5kZXIwOFxcXCIgKHJlYWQta2V5c2V0IFxcXCJzZW5kZXIwOFxcXCIpIDE4MDAwMDAwMC4wKVxcbihjb2luLmNvaW5iYXNlIFxcXCJzZW5kZXIwOVxcXCIgKHJlYWQta2V5c2V0IFxcXCJzZW5kZXIwOVxcXCIpIDE5MDAwMDAwMC4wKVxcbihjb2luLmNvaW5iYXNlIFxcXCJtdWx0aS0wMC0wMVxcXCIgKHJlYWQta2V5c2V0IFxcXCJtdWx0aS0wMC0wMVxcXCIpIDEwMTAwMDAwMC4wKVxcbihjb2luLmNvaW5iYXNlIFxcXCJtdWx0aS0wMi0wMy0wNC1hbnlcXFwiIChyZWFkLWtleXNldCBcXFwibXVsdGktMDItMDMtMDQtYW55XFxcIikgMTIzNDAwMDAwLjApXFxuXFxuKGNvaW4uY29pbmJhc2UgXFxcImU3Zjc2MzRlOTI1NTQxZjM2OGI4MjdhZDVjNzI0MjE5MDUxMDBmNjIwNTI4NWE3OGMxOWQ3YjRhMzg3MTE4MDVcXFwiIChyZWFkLWtleXNldCBcXFwiZTdmN1xcXCIpIDE1MC4wKVwifX0sXCJzaWduZXJzXCI6W10sXCJtZXRhXCI6e1wiY3JlYXRpb25UaW1lXCI6MCxcInR0bFwiOjE3MjgwMCxcImdhc0xpbWl0XCI6MCxcImNoYWluSWRcIjpcIlwiLFwiZ2FzUHJpY2VcIjowLFwic2VuZGVyXCI6XCJcIn0sXCJub25jZVwiOlwiZGV2bmV0LWdyYW50c05cIn0ifQ", unsafeFromText "eyJnYXMiOjAsInJlc3VsdCI6eyJzdGF0dXMiOiJzdWNjZXNzIiwiZGF0YSI6IldyaXRlIHN1Y2NlZWRlZCJ9LCJyZXFLZXkiOiJmMjFVMUlGeVE3Rl8tNGVOdHpBMW5admNDSDlydjlmdmw1YzVrRHI1cWx3IiwibG9ncyI6IkF3MTVuVFF0YmlQYlVCQm1reGpRV09JZlc3ZHNfUi1sWjhNMGZDMXAxZHciLCJldmVudHMiOlt7InBhcmFtcyI6WyIiLCJzZW5kZXIwMCIsMTAwMDAwMDAwXSwibmFtZSI6IlRSQU5TRkVSIiwibW9kdWxlIjp7Im5hbWVzcGFjZSI6bnVsbCwibmFtZSI6ImNvaW4ifSwibW9kdWxlSGFzaCI6IjNpSUJRZEpuc3Q0NFoyWmdYb0hQa0FhdXliSjBoODVsX2VuX1NHSE5pYkUifSx7InBhcmFtcyI6WyIiLCJzZW5kZXIwMSIsMTEwMDAwMDAwXSwibmFtZSI6IlRSQU5TRkVSIiwibW9kdWxlIjp7Im5hbWVzcGFjZSI6bnVsbCwibmFtZSI6ImNvaW4ifSwibW9kdWxlSGFzaCI6IjNpSUJRZEpuc3Q0NFoyWmdYb0hQa0FhdXliSjBoODVsX2VuX1NHSE5pYkUifSx7InBhcmFtcyI6WyIiLCJzZW5kZXIwMiIsMTIwMDAwMDAwXSwibmFtZSI6IlRSQU5TRkVSIiwibW9kdWxlIjp7Im5hbWVzcGFjZSI6bnVsbCwibmFtZSI6ImNvaW4ifSwibW9kdWxlSGFzaCI6IjNpSUJRZEpuc3Q0NFoyWmdYb0hQa0FhdXliSjBoODVsX2VuX1NHSE5pYkUifSx7InBhcmFtcyI6WyIiLCJzZW5kZXIwMyIsMTMwMDAwMDAwXSwibmFtZSI6IlRSQU5TRkVSIiwibW9kdWxlIjp7Im5hbWVzcGFjZSI6bnVsbCwibmFtZSI6ImNvaW4ifSwibW9kdWxlSGFzaCI6IjNpSUJRZEpuc3Q0NFoyWmdYb0hQa0FhdXliSjBoODVsX2VuX1NHSE5pYkUifSx7InBhcmFtcyI6WyIiLCJzZW5kZXIwNCIsMTQwMDAwMDAwXSwibmFtZSI6IlRSQU5TRkVSIiwibW9kdWxlIjp7Im5hbWVzcGFjZSI6bnVsbCwibmFtZSI6ImNvaW4ifSwibW9kdWxlSGFzaCI6IjNpSUJRZEpuc3Q0NFoyWmdYb0hQa0FhdXliSjBoODVsX2VuX1NHSE5pYkUifSx7InBhcmFtcyI6WyIiLCJzZW5kZXIwNSIsMTUwMDAwMDAwXSwibmFtZSI6IlRSQU5TRkVSIiwibW9kdWxlIjp7Im5hbWVzcGFjZSI6bnVsbCwibmFtZSI6ImNvaW4ifSwibW9kdWxlSGFzaCI6IjNpSUJRZEpuc3Q0NFoyWmdYb0hQa0FhdXliSjBoODVsX2VuX1NHSE5pYkUifSx7InBhcmFtcyI6WyIiLCJzZW5kZXIwNiIsMTYwMDAwMDAwXSwibmFtZSI6IlRSQU5TRkVSIiwibW9kdWxlIjp7Im5hbWVzcGFjZSI6bnVsbCwibmFtZSI6ImNvaW4ifSwibW9kdWxlSGFzaCI6IjNpSUJRZEpuc3Q0NFoyWmdYb0hQa0FhdXliSjBoODVsX2VuX1NHSE5pYkUifSx7InBhcmFtcyI6WyIiLCJzZW5kZXIwNyIsMTcwMDAwMDAwXSwibmFtZSI6IlRSQU5TRkVSIiwibW9kdWxlIjp7Im5hbWVzcGFjZSI6bnVsbCwibmFtZSI6ImNvaW4ifSwibW9kdWxlSGFzaCI6IjNpSUJRZEpuc3Q0NFoyWmdYb0hQa0FhdXliSjBoODVsX2VuX1NHSE5pYkUifSx7InBhcmFtcyI6WyIiLCJzZW5kZXIwOCIsMTgwMDAwMDAwXSwibmFtZSI6IlRSQU5TRkVSIiwibW9kdWxlIjp7Im5hbWVzcGFjZSI6bnVsbCwibmFtZSI6ImNvaW4ifSwibW9kdWxlSGFzaCI6IjNpSUJRZEpuc3Q0NFoyWmdYb0hQa0FhdXliSjBoODVsX2VuX1NHSE5pYkUifSx7InBhcmFtcyI6WyIiLCJzZW5kZXIwOSIsMTkwMDAwMDAwXSwibmFtZSI6IlRSQU5TRkVSIiwibW9kdWxlIjp7Im5hbWVzcGFjZSI6bnVsbCwibmFtZSI6ImNvaW4ifSwibW9kdWxlSGFzaCI6IjNpSUJRZEpuc3Q0NFoyWmdYb0hQa0FhdXliSjBoODVsX2VuX1NHSE5pYkUifSx7InBhcmFtcyI6WyIiLCJtdWx0aS0wMC0wMSIsMTAxMDAwMDAwXSwibmFtZSI6IlRSQU5TRkVSIiwibW9kdWxlIjp7Im5hbWVzcGFjZSI6bnVsbCwibmFtZSI6ImNvaW4ifSwibW9kdWxlSGFzaCI6IjNpSUJRZEpuc3Q0NFoyWmdYb0hQa0FhdXliSjBoODVsX2VuX1NHSE5pYkUifSx7InBhcmFtcyI6WyIiLCJtdWx0aS0wMi0wMy0wNC1hbnkiLDEyMzQwMDAwMF0sIm5hbWUiOiJUUkFOU0ZFUiIsIm1vZHVsZSI6eyJuYW1lc3BhY2UiOm51bGwsIm5hbWUiOiJjb2luIn0sIm1vZHVsZUhhc2giOiIzaUlCUWRKbnN0NDRaMlpnWG9IUGtBYXV5YkowaDg1bF9lbl9TR0hOaWJFIn0seyJwYXJhbXMiOlsiIiwiZTdmNzYzNGU5MjU1NDFmMzY4YjgyN2FkNWM3MjQyMTkwNTEwMGY2MjA1Mjg1YTc4YzE5ZDdiNGEzODcxMTgwNSIsMTUwXSwibmFtZSI6IlRSQU5TRkVSIiwibW9kdWxlIjp7Im5hbWVzcGFjZSI6bnVsbCwibmFtZSI6ImNvaW4ifSwibW9kdWxlSGFzaCI6IjNpSUJRZEpuc3Q0NFoyWmdYb0hQa0FhdXliSjBoODVsX2VuX1NHSE5pYkUifV0sIm1ldGFEYXRhIjpudWxsLCJjb250aW51YXRpb24iOm51bGwsInR4SWQiOjh9") + , (unsafeFromText "eyJoYXNoIjoibWd3Z3lCdTRGS3NEQ042Q3dWOEJNcFdNcnBwb2UtVkJKYTFYRjktLTFQRSIsInNpZ3MiOltdLCJjbWQiOiJ7XCJuZXR3b3JrSWRcIjpudWxsLFwicGF5bG9hZFwiOntcImV4ZWNcIjp7XCJkYXRhXCI6e1wic2VuZGVyMDdcIjpbXCI0YzMxZGM5ZWU3ZjI0MTc3Zjc4YjZmNTE4MDEyYTIwODMyNmUyYWYxZjM3YmIwYTI0MDViNTA1NmQwY2FkNjI4XCJdLFwic2VuZGVyMDFcIjpbXCI2YmUyZjQ4NWE3YWY3NWZlZGI0YjdmMTUzYTkwM2Y3ZTYwMDBjYTRhYTUwMTE3OWM5MWEyNDUwYjc3N2JkMmE3XCJdLFwic2VuZGVyMDZcIjpbXCI1ZmZjMWY3ZmVmN2E0NDczODYyNTc2MmY3NWE0MjI5NDU0OTUxZTAzZjJhZmM2ZjgxMzA5YzBjMWJkZjllZTZmXCJdLFwic2VuZGVyMDBcIjpbXCIzNjg4MjBmODBjMzI0YmJjN2MyYjA2MTA2ODhhN2RhNDNlMzlmOTFkMTE4NzMyNjcxY2Q5Yzc1MDBmZjQzY2NhXCJdLFwiZTdmN1wiOltcImU3Zjc2MzRlOTI1NTQxZjM2OGI4MjdhZDVjNzI0MjE5MDUxMDBmNjIwNTI4NWE3OGMxOWQ3YjRhMzg3MTE4MDVcIl0sXCJzZW5kZXIwNVwiOltcImYwOWQ4ZjYzOTRhZWE0MjVmZTY3ODNkODhjZDgxMzYzZDgwMTdmMTZhZmQzNzExYzU3NWJlMGY1Y2Q1YzliYjlcIl0sXCJzZW5kZXIwNFwiOltcIjJkNzBhYTRmNjk3YzNhM2I4ZGQ2ZDk3NzQ1YWMwNzRlZGNmZDBlYjY1YzM3Nzc0Y2RlMjUxMzU0ODNiZWE3MWVcIl0sXCJtdWx0aS0wMi0wMy0wNC1hbnlcIjp7XCJwcmVkXCI6XCJrZXlzLWFueVwiLFwia2V5c1wiOltcIjJkNzBhYTRmNjk3YzNhM2I4ZGQ2ZDk3NzQ1YWMwNzRlZGNmZDBlYjY1YzM3Nzc0Y2RlMjUxMzU0ODNiZWE3MWVcIixcIjNhOWRkNTMyZDczZGFjZTE5NWRiYjY0ZDFkYmE2NTcyZmI3ODNkMGZkZDMyNDY4NWUzMmZiZGEyZjg5Zjk5YTZcIixcIjQzZjJhZGIxZGUxOTIwMDBjYjM3NzdiYWNjN2Y5ODNiNjYxNGZkOWMxNzE1Y2Q0NGNkNDg0YjZkM2EwZDM0YzhcIl19LFwic2VuZGVyMDlcIjpbXCJjNTlkOTg0MGIwYjY2MDkwODM2NTQ2YjdlYjRhNzM2MDYyNTc1MjdlYzhjMmI0ODIzMDBmZDIyOTI2NGIwN2U2XCJdLFwic2VuZGVyMDNcIjpbXCI0M2YyYWRiMWRlMTkyMDAwY2IzNzc3YmFjYzdmOTgzYjY2MTRmZDljMTcxNWNkNDRjZDQ4NGI2ZDNhMGQzNGM4XCJdLFwibXVsdGktMDAtMDFcIjpbXCIzNjg4MjBmODBjMzI0YmJjN2MyYjA2MTA2ODhhN2RhNDNlMzlmOTFkMTE4NzMyNjcxY2Q5Yzc1MDBmZjQzY2NhXCIsXCI2YmUyZjQ4NWE3YWY3NWZlZGI0YjdmMTUzYTkwM2Y3ZTYwMDBjYTRhYTUwMTE3OWM5MWEyNDUwYjc3N2JkMmE3XCJdLFwic2VuZGVyMDhcIjpbXCI2M2IyZWJhNGVkNzBkNDYxMmQzZTdiYzkwZGIyZmJmNGM3NmY3YjA3NDM2M2U4NmQ3M2YwYmM2MTdmOGU4YjgxXCJdLFwic2VuZGVyMDJcIjpbXCIzYTlkZDUzMmQ3M2RhY2UxOTVkYmI2NGQxZGJhNjU3MmZiNzgzZDBmZGQzMjQ2ODVlMzJmYmRhMmY4OWY5OWE2XCJdfSxcImNvZGVcIjpcIihjb2luLmNvaW5iYXNlIFxcXCJzZW5kZXIwMFxcXCIgKHJlYWQta2V5c2V0IFxcXCJzZW5kZXIwMFxcXCIpIDEwMDAwMDAwMC4wKVxcbihjb2luLmNvaW5iYXNlIFxcXCJzZW5kZXIwMVxcXCIgKHJlYWQta2V5c2V0IFxcXCJzZW5kZXIwMVxcXCIpIDExMDAwMDAwMC4wKVxcbihjb2luLmNvaW5iYXNlIFxcXCJzZW5kZXIwMlxcXCIgKHJlYWQta2V5c2V0IFxcXCJzZW5kZXIwMlxcXCIpIDEyMDAwMDAwMC4wKVxcbihjb2luLmNvaW5iYXNlIFxcXCJzZW5kZXIwM1xcXCIgKHJlYWQta2V5c2V0IFxcXCJzZW5kZXIwM1xcXCIpIDEzMDAwMDAwMC4wKVxcbihjb2luLmNvaW5iYXNlIFxcXCJzZW5kZXIwNFxcXCIgKHJlYWQta2V5c2V0IFxcXCJzZW5kZXIwNFxcXCIpIDE0MDAwMDAwMC4wKVxcbihjb2luLmNvaW5iYXNlIFxcXCJzZW5kZXIwNVxcXCIgKHJlYWQta2V5c2V0IFxcXCJzZW5kZXIwNVxcXCIpIDE1MDAwMDAwMC4wKVxcbihjb2luLmNvaW5iYXNlIFxcXCJzZW5kZXIwNlxcXCIgKHJlYWQta2V5c2V0IFxcXCJzZW5kZXIwNlxcXCIpIDE2MDAwMDAwMC4wKVxcbihjb2luLmNvaW5iYXNlIFxcXCJzZW5kZXIwN1xcXCIgKHJlYWQta2V5c2V0IFxcXCJzZW5kZXIwN1xcXCIpIDE3MDAwMDAwMC4wKVxcbihjb2luLmNvaW5iYXNlIFxcXCJzZW5kZXIwOFxcXCIgKHJlYWQta2V5c2V0IFxcXCJzZW5kZXIwOFxcXCIpIDE4MDAwMDAwMC4wKVxcbihjb2luLmNvaW5iYXNlIFxcXCJzZW5kZXIwOVxcXCIgKHJlYWQta2V5c2V0IFxcXCJzZW5kZXIwOVxcXCIpIDE5MDAwMDAwMC4wKVxcbihjb2luLmNvaW5iYXNlIFxcXCJtdWx0aS0wMC0wMVxcXCIgKHJlYWQta2V5c2V0IFxcXCJtdWx0aS0wMC0wMVxcXCIpIDEwMTAwMDAwMC4wKVxcbihjb2luLmNvaW5iYXNlIFxcXCJtdWx0aS0wMi0wMy0wNC1hbnlcXFwiIChyZWFkLWtleXNldCBcXFwibXVsdGktMDItMDMtMDQtYW55XFxcIikgMTIzNDAwMDAwLjApXFxuXFxuKGNvaW4uY29pbmJhc2UgXFxcImU3Zjc2MzRlOTI1NTQxZjM2OGI4MjdhZDVjNzI0MjE5MDUxMDBmNjIwNTI4NWE3OGMxOWQ3YjRhMzg3MTE4MDVcXFwiIChyZWFkLWtleXNldCBcXFwiZTdmN1xcXCIpIDE1MC4wKVwifX0sXCJzaWduZXJzXCI6W10sXCJtZXRhXCI6e1wiY3JlYXRpb25UaW1lXCI6MCxcInR0bFwiOjE3MjgwMCxcImdhc0xpbWl0XCI6MCxcImNoYWluSWRcIjpcIlwiLFwiZ2FzUHJpY2VcIjowLFwic2VuZGVyXCI6XCJcIn0sXCJub25jZVwiOlwiZGV2bmV0LWdyYW50c05cIn0ifQ", unsafeFromText "eyJnYXMiOjAsInJlc3VsdCI6eyJzdGF0dXMiOiJzdWNjZXNzIiwiZGF0YSI6IldyaXRlIHN1Y2NlZWRlZCJ9LCJyZXFLZXkiOiJtZ3dneUJ1NEZLc0RDTjZDd1Y4Qk1wV01ycHBvZS1WQkphMVhGOS0tMVBFIiwibG9ncyI6IkF3MTVuVFF0YmlQYlVCQm1reGpRV09JZlc3ZHNfUi1sWjhNMGZDMXAxZHciLCJldmVudHMiOlt7InBhcmFtcyI6WyIiLCJzZW5kZXIwMCIsMTAwMDAwMDAwXSwibmFtZSI6IlRSQU5TRkVSIiwibW9kdWxlIjp7Im5hbWVzcGFjZSI6bnVsbCwibmFtZSI6ImNvaW4ifSwibW9kdWxlSGFzaCI6IjNpSUJRZEpuc3Q0NFoyWmdYb0hQa0FhdXliSjBoODVsX2VuX1NHSE5pYkUifSx7InBhcmFtcyI6WyIiLCJzZW5kZXIwMSIsMTEwMDAwMDAwXSwibmFtZSI6IlRSQU5TRkVSIiwibW9kdWxlIjp7Im5hbWVzcGFjZSI6bnVsbCwibmFtZSI6ImNvaW4ifSwibW9kdWxlSGFzaCI6IjNpSUJRZEpuc3Q0NFoyWmdYb0hQa0FhdXliSjBoODVsX2VuX1NHSE5pYkUifSx7InBhcmFtcyI6WyIiLCJzZW5kZXIwMiIsMTIwMDAwMDAwXSwibmFtZSI6IlRSQU5TRkVSIiwibW9kdWxlIjp7Im5hbWVzcGFjZSI6bnVsbCwibmFtZSI6ImNvaW4ifSwibW9kdWxlSGFzaCI6IjNpSUJRZEpuc3Q0NFoyWmdYb0hQa0FhdXliSjBoODVsX2VuX1NHSE5pYkUifSx7InBhcmFtcyI6WyIiLCJzZW5kZXIwMyIsMTMwMDAwMDAwXSwibmFtZSI6IlRSQU5TRkVSIiwibW9kdWxlIjp7Im5hbWVzcGFjZSI6bnVsbCwibmFtZSI6ImNvaW4ifSwibW9kdWxlSGFzaCI6IjNpSUJRZEpuc3Q0NFoyWmdYb0hQa0FhdXliSjBoODVsX2VuX1NHSE5pYkUifSx7InBhcmFtcyI6WyIiLCJzZW5kZXIwNCIsMTQwMDAwMDAwXSwibmFtZSI6IlRSQU5TRkVSIiwibW9kdWxlIjp7Im5hbWVzcGFjZSI6bnVsbCwibmFtZSI6ImNvaW4ifSwibW9kdWxlSGFzaCI6IjNpSUJRZEpuc3Q0NFoyWmdYb0hQa0FhdXliSjBoODVsX2VuX1NHSE5pYkUifSx7InBhcmFtcyI6WyIiLCJzZW5kZXIwNSIsMTUwMDAwMDAwXSwibmFtZSI6IlRSQU5TRkVSIiwibW9kdWxlIjp7Im5hbWVzcGFjZSI6bnVsbCwibmFtZSI6ImNvaW4ifSwibW9kdWxlSGFzaCI6IjNpSUJRZEpuc3Q0NFoyWmdYb0hQa0FhdXliSjBoODVsX2VuX1NHSE5pYkUifSx7InBhcmFtcyI6WyIiLCJzZW5kZXIwNiIsMTYwMDAwMDAwXSwibmFtZSI6IlRSQU5TRkVSIiwibW9kdWxlIjp7Im5hbWVzcGFjZSI6bnVsbCwibmFtZSI6ImNvaW4ifSwibW9kdWxlSGFzaCI6IjNpSUJRZEpuc3Q0NFoyWmdYb0hQa0FhdXliSjBoODVsX2VuX1NHSE5pYkUifSx7InBhcmFtcyI6WyIiLCJzZW5kZXIwNyIsMTcwMDAwMDAwXSwibmFtZSI6IlRSQU5TRkVSIiwibW9kdWxlIjp7Im5hbWVzcGFjZSI6bnVsbCwibmFtZSI6ImNvaW4ifSwibW9kdWxlSGFzaCI6IjNpSUJRZEpuc3Q0NFoyWmdYb0hQa0FhdXliSjBoODVsX2VuX1NHSE5pYkUifSx7InBhcmFtcyI6WyIiLCJzZW5kZXIwOCIsMTgwMDAwMDAwXSwibmFtZSI6IlRSQU5TRkVSIiwibW9kdWxlIjp7Im5hbWVzcGFjZSI6bnVsbCwibmFtZSI6ImNvaW4ifSwibW9kdWxlSGFzaCI6IjNpSUJRZEpuc3Q0NFoyWmdYb0hQa0FhdXliSjBoODVsX2VuX1NHSE5pYkUifSx7InBhcmFtcyI6WyIiLCJzZW5kZXIwOSIsMTkwMDAwMDAwXSwibmFtZSI6IlRSQU5TRkVSIiwibW9kdWxlIjp7Im5hbWVzcGFjZSI6bnVsbCwibmFtZSI6ImNvaW4ifSwibW9kdWxlSGFzaCI6IjNpSUJRZEpuc3Q0NFoyWmdYb0hQa0FhdXliSjBoODVsX2VuX1NHSE5pYkUifSx7InBhcmFtcyI6WyIiLCJtdWx0aS0wMC0wMSIsMTAxMDAwMDAwXSwibmFtZSI6IlRSQU5TRkVSIiwibW9kdWxlIjp7Im5hbWVzcGFjZSI6bnVsbCwibmFtZSI6ImNvaW4ifSwibW9kdWxlSGFzaCI6IjNpSUJRZEpuc3Q0NFoyWmdYb0hQa0FhdXliSjBoODVsX2VuX1NHSE5pYkUifSx7InBhcmFtcyI6WyIiLCJtdWx0aS0wMi0wMy0wNC1hbnkiLDEyMzQwMDAwMF0sIm5hbWUiOiJUUkFOU0ZFUiIsIm1vZHVsZSI6eyJuYW1lc3BhY2UiOm51bGwsIm5hbWUiOiJjb2luIn0sIm1vZHVsZUhhc2giOiIzaUlCUWRKbnN0NDRaMlpnWG9IUGtBYXV5YkowaDg1bF9lbl9TR0hOaWJFIn0seyJwYXJhbXMiOlsiIiwiZTdmNzYzNGU5MjU1NDFmMzY4YjgyN2FkNWM3MjQyMTkwNTEwMGY2MjA1Mjg1YTc4YzE5ZDdiNGEzODcxMTgwNSIsMTUwXSwibmFtZSI6IlRSQU5TRkVSIiwibW9kdWxlIjp7Im5hbWVzcGFjZSI6bnVsbCwibmFtZSI6ImNvaW4ifSwibW9kdWxlSGFzaCI6IjNpSUJRZEpuc3Q0NFoyWmdYb0hQa0FhdXliSjBoODVsX2VuX1NHSE5pYkUifV0sIm1ldGFEYXRhIjpudWxsLCJjb250aW51YXRpb24iOm51bGwsInR4SWQiOjh9") ] diff --git a/src/Chainweb/BlockHeader/Genesis/Pact5InstantTimedCPM0Payload.hs b/src/Chainweb/BlockHeader/Genesis/Pact5InstantTimedCPM0Payload.hs index 73223246a0..e30fdc2eba 100644 --- a/src/Chainweb/BlockHeader/Genesis/Pact5InstantTimedCPM0Payload.hs +++ b/src/Chainweb/BlockHeader/Genesis/Pact5InstantTimedCPM0Payload.hs @@ -8,7 +8,7 @@ import qualified Data.Text as T import qualified Data.Vector as V import GHC.Stack -import Chainweb.Payload +import Chainweb.Pact.Payload import Chainweb.Utils (unsafeFromText, toText) payloadBlock :: HasCallStack => PayloadWithOutputs diff --git a/src/Chainweb/BlockHeader/Genesis/Pact5InstantTimedCPM1to9Payload.hs b/src/Chainweb/BlockHeader/Genesis/Pact5InstantTimedCPM1to9Payload.hs index 731b94558e..8a5da12aeb 100644 --- a/src/Chainweb/BlockHeader/Genesis/Pact5InstantTimedCPM1to9Payload.hs +++ b/src/Chainweb/BlockHeader/Genesis/Pact5InstantTimedCPM1to9Payload.hs @@ -8,7 +8,7 @@ import qualified Data.Text as T import qualified Data.Vector as V import GHC.Stack -import Chainweb.Payload +import Chainweb.Pact.Payload import Chainweb.Utils (unsafeFromText, toText) payloadBlock :: HasCallStack => PayloadWithOutputs diff --git a/src/Chainweb/BlockHeader/Genesis/QuirkedGasInstantTimedCPM0Payload.hs b/src/Chainweb/BlockHeader/Genesis/QuirkedGasInstantTimedCPM0Payload.hs new file mode 100644 index 0000000000..0a1e835215 --- /dev/null +++ b/src/Chainweb/BlockHeader/Genesis/QuirkedGasInstantTimedCPM0Payload.hs @@ -0,0 +1,39 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- This module is auto-generated. DO NOT EDIT IT MANUALLY. + +module Chainweb.BlockHeader.Genesis.QuirkedGasInstantTimedCPM0Payload ( payloadBlock ) where + +import qualified Data.Text as T +import qualified Data.Vector as V +import GHC.Stack + +import Chainweb.Pact.Payload +import Chainweb.Utils (unsafeFromText, toText) + +payloadBlock :: HasCallStack => PayloadWithOutputs +payloadBlock + | actualHash == expectedHash = payload + | otherwise = error + $ "inconsistent genesis payload detected. THIS IS A BUG in chainweb-node" + <> ". Expected: " <> T.unpack (toText expectedHash) + <> ", actual: " <> T.unpack (toText actualHash) + where + actualHash, expectedHash :: BlockPayloadHash + actualHash = _payloadWithOutputsPayloadHash payload + expectedHash = unsafeFromText "1I4CRQ2BGFZEFr7_X_U1hMPPZI4YMbfxEr6cyrRYlsA" + + payload = newPayloadWithOutputs minerData coinbase txs + minerData = unsafeFromText "eyJhY2NvdW50IjoiTm9NaW5lciIsInByZWRpY2F0ZSI6IjwiLCJwdWJsaWMta2V5cyI6W119" + coinbase = unsafeFromText "eyJnYXMiOjAsInJlc3VsdCI6eyJzdGF0dXMiOiJzdWNjZXNzIiwiZGF0YSI6Ik5PX0NPSU5CQVNFIn0sInJlcUtleSI6IkRsZFJ3Q2JsUTdMb3F5NndZSm5hb2RIbDMwZDNqM2VILXF0RnpmRXY0NmciLCJsb2dzIjpudWxsLCJtZXRhRGF0YSI6bnVsbCwiY29udGludWF0aW9uIjpudWxsLCJ0eElkIjpudWxsfQ" + txs = V.fromList + [ (unsafeFromText "eyJoYXNoIjoiNDhUMExqQW5TRnBGV3h2dmFQVi1fNkUtQ2pEQVBoV1lVRldidnlmMmxGcyIsInNpZ3MiOltdLCJjbWQiOiJ7XCJuZXR3b3JrSWRcIjpudWxsLFwicGF5bG9hZFwiOntcImV4ZWNcIjp7XCJkYXRhXCI6bnVsbCxcImNvZGVcIjpcIihpbnRlcmZhY2UgZnVuZ2libGUtdjFcXG5cXG4gIFxcXCIgU3RhbmRhcmQgZm9yIGZ1bmdpYmxlIGNvaW5zIGFuZCB0b2tlbnMgYXMgc3BlY2lmaWVkIGluIEtJUC0wMDAyLiBcXFwiXFxuXFxuICAgOyAtLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tXFxuICAgOyBTY2hlbWFcXG5cXG4gICAoZGVmc2NoZW1hIGFjY291bnQtZGV0YWlsc1xcbiAgICBAZG9jIFxcXCJTY2hlbWEgZm9yIHJlc3VsdHMgb2YgJ2FjY291bnQnIG9wZXJhdGlvbi5cXFwiXFxuICAgIEBtb2RlbCBbIChpbnZhcmlhbnQgKCE9IFxcXCJcXFwiIHNlbmRlcikpIF1cXG5cXG4gICAgYWNjb3VudDpzdHJpbmdcXG4gICAgYmFsYW5jZTpkZWNpbWFsXFxuICAgIGd1YXJkOmd1YXJkKVxcblxcblxcbiAgIDsgLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLVxcbiAgIDsgQ2Fwc1xcblxcbiAgIChkZWZjYXAgVFJBTlNGRVI6Ym9vbFxcbiAgICAgKCBzZW5kZXI6c3RyaW5nXFxuICAgICAgIHJlY2VpdmVyOnN0cmluZ1xcbiAgICAgICBhbW91bnQ6ZGVjaW1hbFxcbiAgICAgKVxcbiAgICAgQGRvYyBcXFwiIE1hbmFnZWQgY2FwYWJpbGl0eSBzZWFsaW5nIEFNT1VOVCBmb3IgdHJhbnNmZXIgZnJvbSBTRU5ERVIgdG8gXFxcXFxcbiAgICAgICAgICBcXFxcIFJFQ0VJVkVSLiBQZXJtaXRzIGFueSBudW1iZXIgb2YgdHJhbnNmZXJzIHVwIHRvIEFNT1VOVC5cXFwiXFxuICAgICBAbWFuYWdlZCBhbW91bnQgVFJBTlNGRVItbWdyXFxuICAgICApXFxuXFxuICAgKGRlZnVuIFRSQU5TRkVSLW1ncjpkZWNpbWFsXFxuICAgICAoIG1hbmFnZWQ6ZGVjaW1hbFxcbiAgICAgICByZXF1ZXN0ZWQ6ZGVjaW1hbFxcbiAgICAgKVxcbiAgICAgQGRvYyBcXFwiIE1hbmFnZXMgVFJBTlNGRVIgQU1PVU5UIGxpbmVhcmx5LCBcXFxcXFxuICAgICAgICAgIFxcXFwgc3VjaCB0aGF0IGEgcmVxdWVzdCBmb3IgMS4wIGFtb3VudCBvbiBhIDMuMCBcXFxcXFxuICAgICAgICAgIFxcXFwgbWFuYWdlZCBxdWFudGl0eSBlbWl0cyB1cGRhdGVkIGFtb3VudCAyLjAuXFxcIlxcbiAgICAgKVxcblxcbiAgIDsgLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLVxcbiAgIDsgRnVuY3Rpb25hbGl0eVxcblxcbiAgIChkZWZ1biB0cmFuc2Zlci1jcmVhdGU6c3RyaW5nXFxuICAgICAoIHNlbmRlcjpzdHJpbmdcXG4gICAgICAgcmVjZWl2ZXI6c3RyaW5nXFxuICAgICAgIHJlY2VpdmVyLWd1YXJkOmd1YXJkXFxuICAgICAgIGFtb3VudDpkZWNpbWFsXFxuICAgICApXFxuICAgICBAZG9jIFxcXCIgVHJhbnNmZXIgQU1PVU5UIGJldHdlZW4gYWNjb3VudHMgU0VOREVSIGFuZCBSRUNFSVZFUi4gXFxcXFxcbiAgICAgICAgICBcXFxcIEZhaWxzIGlmIFNFTkRFUiBkb2VzIG5vdCBleGlzdC4gSWYgUkVDRUlWRVIgZXhpc3RzLCBndWFyZCBcXFxcXFxuICAgICAgICAgIFxcXFwgbXVzdCBtYXRjaCBleGlzdGluZyB2YWx1ZS4gSWYgUkVDRUlWRVIgZG9lcyBub3QgZXhpc3QsIFxcXFxcXG4gICAgICAgICAgXFxcXCBSRUNFSVZFUiBhY2NvdW50IGlzIGNyZWF0ZWQgdXNpbmcgUkVDRUlWRVItR1VBUkQuIFxcXFxcXG4gICAgICAgICAgXFxcXCBTdWJqZWN0IHRvIG1hbmFnZW1lbnQgYnkgVFJBTlNGRVIgY2FwYWJpbGl0eS5cXFwiXFxuICAgICBAbW9kZWwgWyAocHJvcGVydHkgKD4gYW1vdW50IDAuMCkpXFxuICAgICAgICAgICAgICAocHJvcGVydHkgKCE9IHNlbmRlciBcXFwiXFxcIikpXFxuICAgICAgICAgICAgICAocHJvcGVydHkgKCE9IHJlY2VpdmVyIFxcXCJcXFwiKSlcXG4gICAgICAgICAgICAgIChwcm9wZXJ0eSAoIT0gc2VuZGVyIHJlY2VpdmVyKSlcXG4gICAgICAgICAgICBdXFxuICAgICApXFxuXFxuICAgKGRlZnBhY3QgdHJhbnNmZXItY3Jvc3NjaGFpbjpzdHJpbmdcXG4gICAgICggc2VuZGVyOnN0cmluZ1xcbiAgICAgICByZWNlaXZlcjpzdHJpbmdcXG4gICAgICAgcmVjZWl2ZXItZ3VhcmQ6Z3VhcmRcXG4gICAgICAgdGFyZ2V0LWNoYWluOnN0cmluZ1xcbiAgICAgICBhbW91bnQ6ZGVjaW1hbFxcbiAgICAgKVxcbiAgICAgQGRvYyBcXFwiIDItc3RlcCBwYWN0IHRvIHRyYW5zZmVyIEFNT1VOVCBmcm9tIFNFTkRFUiBvbiBjdXJyZW50IGNoYWluIFxcXFxcXG4gICAgICAgICAgXFxcXCB0byBSRUNFSVZFUiBvbiBUQVJHRVQtQ0hBSU4gdmlhIFNQViBwcm9vZi4gXFxcXFxcbiAgICAgICAgICBcXFxcIFRBUkdFVC1DSEFJTiBtdXN0IGJlIGRpZmZlcmVudCB0aGFuIGN1cnJlbnQgY2hhaW4gaWQuIFxcXFxcXG4gICAgICAgICAgXFxcXCBGaXJzdCBzdGVwIGRlYml0cyBBTU9VTlQgY29pbnMgaW4gU0VOREVSIGFjY291bnQgYW5kIHlpZWxkcyBcXFxcXFxuICAgICAgICAgIFxcXFwgUkVDRUlWRVIsIFJFQ0VJVkVSX0dVQVJEIGFuZCBBTU9VTlQgdG8gVEFSR0VULUNIQUlOLiBcXFxcXFxuICAgICAgICAgIFxcXFwgU2Vjb25kIHN0ZXAgY29udGludWF0aW9uIGlzIHNlbnQgaW50byBUQVJHRVQtQ0hBSU4gd2l0aCBwcm9vZiBcXFxcXFxuICAgICAgICAgIFxcXFwgb2J0YWluZWQgZnJvbSB0aGUgc3B2ICdvdXRwdXQnIGVuZHBvaW50IG9mIENoYWlud2ViLiBcXFxcXFxuICAgICAgICAgIFxcXFwgUHJvb2YgaXMgdmFsaWRhdGVkIGFuZCBSRUNFSVZFUiBpcyBjcmVkaXRlZCB3aXRoIEFNT1VOVCBcXFxcXFxuICAgICAgICAgIFxcXFwgY3JlYXRpbmcgYWNjb3VudCB3aXRoIFJFQ0VJVkVSX0dVQVJEIGFzIG5lY2Vzc2FyeS5cXFwiXFxuICAgICBAbW9kZWwgWyAocHJvcGVydHkgKD4gYW1vdW50IDAuMCkpXFxuICAgICAgICAgICAgICAocHJvcGVydHkgKCE9IHNlbmRlciBcXFwiXFxcIikpXFxuICAgICAgICAgICAgICAocHJvcGVydHkgKCE9IHJlY2VpdmVyIFxcXCJcXFwiKSlcXG4gICAgICAgICAgICAgIChwcm9wZXJ0eSAoIT0gc2VuZGVyIHJlY2VpdmVyKSlcXG4gICAgICAgICAgICAgIChwcm9wZXJ0eSAoIT0gdGFyZ2V0LWNoYWluIFxcXCJcXFwiKSlcXG4gICAgICAgICAgICBdXFxuICAgICApXFxuXFxuICAgKGRlZnVuIGdldC1iYWxhbmNlOmRlY2ltYWxcXG4gICAgICggYWNjb3VudDpzdHJpbmcgKVxcbiAgICAgXFxcIiBHZXQgYmFsYW5jZSBmb3IgQUNDT1VOVC4gRmFpbHMgaWYgYWNjb3VudCBkb2VzIG5vdCBleGlzdC5cXFwiXFxuICAgICApXFxuXFxuICAgKGRlZnVuIGRldGFpbHM6b2JqZWN0e2FjY291bnQtZGV0YWlsc31cXG4gICAgICggYWNjb3VudDogc3RyaW5nIClcXG4gICAgIFxcXCIgR2V0IGFuIG9iamVjdCB3aXRoIGRldGFpbHMgb2YgQUNDT1VOVC4gXFxcXFxcbiAgICAgXFxcXCBGYWlscyBpZiBhY2NvdW50IGRvZXMgbm90IGV4aXN0LlxcXCJcXG4gICAgIClcXG5cXG4gICAoZGVmdW4gcHJlY2lzaW9uOmludGVnZXJcXG4gICAgICgpXFxuICAgICBcXFwiUmV0dXJuIHRoZSBtYXhpbXVtIGFsbG93ZWQgZGVjaW1hbCBwcmVjaXNpb24uXFxcIlxcbiAgICAgKVxcblxcbiAgIChkZWZ1biBlbmZvcmNlLXVuaXQ6Ym9vbFxcbiAgICAgKCBhbW91bnQ6ZGVjaW1hbCApXFxuICAgICBcXFwiIEVuZm9yY2UgbWluaW11bSBwcmVjaXNpb24gYWxsb3dlZCBmb3IgdHJhbnNhY3Rpb25zLlxcXCJcXG4gICAgIClcXG5cXG4gICAoZGVmdW4gY3JlYXRlLWFjY291bnQ6c3RyaW5nXFxuICAgICAoIGFjY291bnQ6c3RyaW5nXFxuICAgICAgIGd1YXJkOmd1YXJkXFxuICAgICApXFxuICAgICBcXFwiIENyZWF0ZSBBQ0NPVU5UIHdpdGggMC4wIGJhbGFuY2UsIHdpdGggR1VBUkQgY29udHJvbGxpbmcgYWNjZXNzLlxcXCJcXG4gICAgIClcXG5cXG4gICAoZGVmdW4gcm90YXRlOnN0cmluZ1xcbiAgICAgKCBhY2NvdW50OnN0cmluZ1xcbiAgICAgICBuZXctZ3VhcmQ6Z3VhcmRcXG4gICAgIClcXG4gICAgIFxcXCIgUm90YXRlIGd1YXJkIGZvciBBQ0NPVU5ULiBUcmFuc2FjdGlvbiBpcyB2YWxpZGF0ZWQgYWdhaW5zdCBcXFxcXFxuICAgICBcXFxcIGV4aXN0aW5nIGd1YXJkIGJlZm9yZSBpbnN0YWxsaW5nIG5ldyBndWFyZC4gXFxcIlxcbiAgICAgKVxcblxcbilcXG5cIn19LFwic2lnbmVyc1wiOltdLFwibWV0YVwiOntcImNyZWF0aW9uVGltZVwiOjAsXCJ0dGxcIjoxNzI4MDAsXCJnYXNMaW1pdFwiOjAsXCJjaGFpbklkXCI6XCJcIixcImdhc1ByaWNlXCI6MCxcInNlbmRlclwiOlwiXCJ9LFwibm9uY2VcIjpcImdlbmVzaXMtMDFcIn0ifQ", unsafeFromText "eyJnYXMiOjAsInJlc3VsdCI6eyJzdGF0dXMiOiJzdWNjZXNzIiwiZGF0YSI6IkxvYWRlZCBpbnRlcmZhY2UgZnVuZ2libGUtdjEsIGhhc2ggTm1kUnRzekN3YWNqSEd5eUU5Tl9mbFFNUlJCaGNIVkZQNE9qaGlQZWoxRSJ9LCJyZXFLZXkiOiI0OFQwTGpBblNGcEZXeHZ2YVBWLV82RS1DakRBUGhXWVVGV2J2eWYybEZzIiwibG9ncyI6IlB3eDlycG9kS2prSGNPUlh2WFVRSUpjRVZRZDhPSXRNM0FlakNFRExMVXMiLCJtZXRhRGF0YSI6bnVsbCwiY29udGludWF0aW9uIjpudWxsLCJ0eElkIjowfQ") + , (unsafeFromText "eyJoYXNoIjoieW5ucDFYVVNSTjJrMUYwYTZ2dXM3RFp0SDZjcHN6MVhmX0d3V0xnTFhTTSIsInNpZ3MiOltdLCJjbWQiOiJ7XCJuZXR3b3JrSWRcIjpudWxsLFwicGF5bG9hZFwiOntcImV4ZWNcIjp7XCJkYXRhXCI6bnVsbCxcImNvZGVcIjpcIihpbnRlcmZhY2UgZnVuZ2libGUteGNoYWluLXYxXFxuXFxuICBcXFwiIFRoaXMgaW50ZXJmYWNlIG9mZmVycyBhIHN0YW5kYXJkIGNhcGFiaWxpdHkgZm9yIGNyb3NzLWNoYWluIFxcXFxcXG4gIFxcXFwgdHJhbnNmZXJzIGFuZCBhc3NvY2lhdGVkIGV2ZW50cy4gXFxcIlxcblxcbiAgKGRlZmNhcCBUUkFOU0ZFUl9YQ0hBSU46Ym9vbFxcbiAgICAoIHNlbmRlcjpzdHJpbmdcXG4gICAgICByZWNlaXZlcjpzdHJpbmdcXG4gICAgICBhbW91bnQ6ZGVjaW1hbFxcbiAgICAgIHRhcmdldC1jaGFpbjpzdHJpbmdcXG4gICAgKVxcbiAgICBAZG9jIFxcXCIgTWFuYWdlZCBjYXBhYmlsaXR5IHNlYWxpbmcgQU1PVU5UIGZvciB0cmFuc2ZlciBcXFxcXFxuICAgICAgICAgXFxcXCBmcm9tIFNFTkRFUiB0byBSRUNFSVZFUiBvbiBUQVJHRVQtQ0hBSU4uIFBlcm1pdHMgXFxcXFxcbiAgICAgICAgIFxcXFwgYW55IG51bWJlciBvZiBjcm9zcy1jaGFpbiB0cmFuc2ZlcnMgdXAgdG8gQU1PVU5ULlxcXCJcXG5cXG4gICAgQG1hbmFnZWQgYW1vdW50IFRSQU5TRkVSX1hDSEFJTi1tZ3JcXG4gICAgKVxcblxcbiAgKGRlZnVuIFRSQU5TRkVSX1hDSEFJTi1tZ3I6ZGVjaW1hbFxcbiAgICAoIG1hbmFnZWQ6ZGVjaW1hbFxcbiAgICAgIHJlcXVlc3RlZDpkZWNpbWFsXFxuICAgIClcXG4gICAgQGRvYyBcXFwiIEFsbG93cyBUUkFOU0ZFUi1YQ0hBSU4gQU1PVU5UIHRvIGJlIGxlc3MgdGhhbiBvciBcXFxcXFxuICAgICAgICAgXFxcXCBlcXVhbCBtYW5hZ2VkIHF1YW50aXR5IGFzIGEgb25lLXNob3QsIHJldHVybmluZyAwLjAuXFxcIlxcbiAgKVxcblxcbiAgKGRlZmNhcCBUUkFOU0ZFUl9YQ0hBSU5fUkVDRDpib29sXFxuICAgICggc2VuZGVyOnN0cmluZ1xcbiAgICAgIHJlY2VpdmVyOnN0cmluZ1xcbiAgICAgIGFtb3VudDpkZWNpbWFsXFxuICAgICAgc291cmNlLWNoYWluOnN0cmluZ1xcbiAgICApXFxuICAgIEBkb2MgXFxcIkV2ZW50IGVtaXR0ZWQgb24gcmVjZWlwdCBvZiBjcm9zcy1jaGFpbiB0cmFuc2Zlci5cXFwiXFxuICAgIEBldmVudFxcbiAgKVxcbilcXG5cIn19LFwic2lnbmVyc1wiOltdLFwibWV0YVwiOntcImNyZWF0aW9uVGltZVwiOjAsXCJ0dGxcIjoxNzI4MDAsXCJnYXNMaW1pdFwiOjAsXCJjaGFpbklkXCI6XCJcIixcImdhc1ByaWNlXCI6MCxcInNlbmRlclwiOlwiXCJ9LFwibm9uY2VcIjpcImdlbmVzaXMteGNoYWluXCJ9In0", unsafeFromText "eyJnYXMiOjAsInJlc3VsdCI6eyJzdGF0dXMiOiJzdWNjZXNzIiwiZGF0YSI6IkxvYWRlZCBpbnRlcmZhY2UgZnVuZ2libGUteGNoYWluLXYxLCBoYXNoIGg4OWljM2doejIzUmprMHBITkt0Rk93cnZTczdtYm11cWxvVlhPaGwyR0kifSwicmVxS2V5IjoieW5ucDFYVVNSTjJrMUYwYTZ2dXM3RFp0SDZjcHN6MVhmX0d3V0xnTFhTTSIsImxvZ3MiOiJSUDhnMUJrZnkyQjN1bHE0WWU4amF1VlRZcGpqRXlaLWtydGJ5SVg2STRnIiwibWV0YURhdGEiOm51bGwsImNvbnRpbnVhdGlvbiI6bnVsbCwidHhJZCI6MX0") + , (unsafeFromText "eyJoYXNoIjoiMDVCdGo3ZUJaQlc3by1TYUxvVmhBaWNNVVBaVUJiRzZRVDhfTEFrQ3hIcyIsInNpZ3MiOltdLCJjbWQiOiJ7XCJuZXR3b3JrSWRcIjpudWxsLFwicGF5bG9hZFwiOntcImV4ZWNcIjp7XCJkYXRhXCI6bnVsbCxcImNvZGVcIjpcIihpbnRlcmZhY2UgZnVuZ2libGUtdjJcXG5cXG4gIFxcXCIgU3RhbmRhcmQgZm9yIGZ1bmdpYmxlIGNvaW5zIGFuZCB0b2tlbnMgYXMgc3BlY2lmaWVkIGluIEtJUC0wMDAyLiBcXFwiXFxuXFxuICAgOyAtLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tXFxuICAgOyBTY2hlbWFcXG5cXG4gICAoZGVmc2NoZW1hIGFjY291bnQtZGV0YWlsc1xcbiAgICBAZG9jIFxcXCJTY2hlbWEgZm9yIHJlc3VsdHMgb2YgJ2FjY291bnQnIG9wZXJhdGlvbi5cXFwiXFxuICAgIEBtb2RlbCBbIChpbnZhcmlhbnQgKCE9IFxcXCJcXFwiIHNlbmRlcikpIF1cXG5cXG4gICAgYWNjb3VudDpzdHJpbmdcXG4gICAgYmFsYW5jZTpkZWNpbWFsXFxuICAgIGd1YXJkOmd1YXJkKVxcblxcblxcbiAgIDsgLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLVxcbiAgIDsgQ2Fwc1xcblxcbiAgIChkZWZjYXAgVFJBTlNGRVI6Ym9vbFxcbiAgICAgKCBzZW5kZXI6c3RyaW5nXFxuICAgICAgIHJlY2VpdmVyOnN0cmluZ1xcbiAgICAgICBhbW91bnQ6ZGVjaW1hbFxcbiAgICAgKVxcbiAgICAgQGRvYyBcXFwiIE1hbmFnZWQgY2FwYWJpbGl0eSBzZWFsaW5nIEFNT1VOVCBmb3IgdHJhbnNmZXIgZnJvbSBTRU5ERVIgdG8gXFxcXFxcbiAgICAgICAgICBcXFxcIFJFQ0VJVkVSLiBQZXJtaXRzIGFueSBudW1iZXIgb2YgdHJhbnNmZXJzIHVwIHRvIEFNT1VOVC5cXFwiXFxuICAgICBAbWFuYWdlZCBhbW91bnQgVFJBTlNGRVItbWdyXFxuICAgICApXFxuXFxuICAgKGRlZnVuIFRSQU5TRkVSLW1ncjpkZWNpbWFsXFxuICAgICAoIG1hbmFnZWQ6ZGVjaW1hbFxcbiAgICAgICByZXF1ZXN0ZWQ6ZGVjaW1hbFxcbiAgICAgKVxcbiAgICAgQGRvYyBcXFwiIE1hbmFnZXMgVFJBTlNGRVIgQU1PVU5UIGxpbmVhcmx5LCBcXFxcXFxuICAgICAgICAgIFxcXFwgc3VjaCB0aGF0IGEgcmVxdWVzdCBmb3IgMS4wIGFtb3VudCBvbiBhIDMuMCBcXFxcXFxuICAgICAgICAgIFxcXFwgbWFuYWdlZCBxdWFudGl0eSBlbWl0cyB1cGRhdGVkIGFtb3VudCAyLjAuXFxcIlxcbiAgICAgKVxcblxcbiAgIDsgLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLVxcbiAgIDsgRnVuY3Rpb25hbGl0eVxcblxcblxcbiAgKGRlZnVuIHRyYW5zZmVyOnN0cmluZ1xcbiAgICAoIHNlbmRlcjpzdHJpbmdcXG4gICAgICByZWNlaXZlcjpzdHJpbmdcXG4gICAgICBhbW91bnQ6ZGVjaW1hbFxcbiAgICApXFxuICAgIEBkb2MgXFxcIiBUcmFuc2ZlciBBTU9VTlQgYmV0d2VlbiBhY2NvdW50cyBTRU5ERVIgYW5kIFJFQ0VJVkVSLiBcXFxcXFxuICAgICAgICAgXFxcXCBGYWlscyBpZiBlaXRoZXIgU0VOREVSIG9yIFJFQ0VJVkVSIGRvZXMgbm90IGV4aXN0LlxcXCJcXG4gICAgQG1vZGVsIFsgKHByb3BlcnR5ICg-IGFtb3VudCAwLjApKVxcbiAgICAgICAgICAgICAocHJvcGVydHkgKCE9IHNlbmRlciBcXFwiXFxcIikpXFxuICAgICAgICAgICAgIChwcm9wZXJ0eSAoIT0gcmVjZWl2ZXIgXFxcIlxcXCIpKVxcbiAgICAgICAgICAgICAocHJvcGVydHkgKCE9IHNlbmRlciByZWNlaXZlcikpXFxuICAgICAgICAgICBdXFxuICAgIClcXG5cXG4gICAoZGVmdW4gdHJhbnNmZXItY3JlYXRlOnN0cmluZ1xcbiAgICAgKCBzZW5kZXI6c3RyaW5nXFxuICAgICAgIHJlY2VpdmVyOnN0cmluZ1xcbiAgICAgICByZWNlaXZlci1ndWFyZDpndWFyZFxcbiAgICAgICBhbW91bnQ6ZGVjaW1hbFxcbiAgICAgKVxcbiAgICAgQGRvYyBcXFwiIFRyYW5zZmVyIEFNT1VOVCBiZXR3ZWVuIGFjY291bnRzIFNFTkRFUiBhbmQgUkVDRUlWRVIuIFxcXFxcXG4gICAgICAgICAgXFxcXCBGYWlscyBpZiBTRU5ERVIgZG9lcyBub3QgZXhpc3QuIElmIFJFQ0VJVkVSIGV4aXN0cywgZ3VhcmQgXFxcXFxcbiAgICAgICAgICBcXFxcIG11c3QgbWF0Y2ggZXhpc3RpbmcgdmFsdWUuIElmIFJFQ0VJVkVSIGRvZXMgbm90IGV4aXN0LCBcXFxcXFxuICAgICAgICAgIFxcXFwgUkVDRUlWRVIgYWNjb3VudCBpcyBjcmVhdGVkIHVzaW5nIFJFQ0VJVkVSLUdVQVJELiBcXFxcXFxuICAgICAgICAgIFxcXFwgU3ViamVjdCB0byBtYW5hZ2VtZW50IGJ5IFRSQU5TRkVSIGNhcGFiaWxpdHkuXFxcIlxcbiAgICAgQG1vZGVsIFsgKHByb3BlcnR5ICg-IGFtb3VudCAwLjApKVxcbiAgICAgICAgICAgICAgKHByb3BlcnR5ICghPSBzZW5kZXIgXFxcIlxcXCIpKVxcbiAgICAgICAgICAgICAgKHByb3BlcnR5ICghPSByZWNlaXZlciBcXFwiXFxcIikpXFxuICAgICAgICAgICAgICAocHJvcGVydHkgKCE9IHNlbmRlciByZWNlaXZlcikpXFxuICAgICAgICAgICAgXVxcbiAgICAgKVxcblxcbiAgIChkZWZwYWN0IHRyYW5zZmVyLWNyb3NzY2hhaW46c3RyaW5nXFxuICAgICAoIHNlbmRlcjpzdHJpbmdcXG4gICAgICAgcmVjZWl2ZXI6c3RyaW5nXFxuICAgICAgIHJlY2VpdmVyLWd1YXJkOmd1YXJkXFxuICAgICAgIHRhcmdldC1jaGFpbjpzdHJpbmdcXG4gICAgICAgYW1vdW50OmRlY2ltYWxcXG4gICAgIClcXG4gICAgIEBkb2MgXFxcIiAyLXN0ZXAgcGFjdCB0byB0cmFuc2ZlciBBTU9VTlQgZnJvbSBTRU5ERVIgb24gY3VycmVudCBjaGFpbiBcXFxcXFxuICAgICAgICAgIFxcXFwgdG8gUkVDRUlWRVIgb24gVEFSR0VULUNIQUlOIHZpYSBTUFYgcHJvb2YuIFxcXFxcXG4gICAgICAgICAgXFxcXCBUQVJHRVQtQ0hBSU4gbXVzdCBiZSBkaWZmZXJlbnQgdGhhbiBjdXJyZW50IGNoYWluIGlkLiBcXFxcXFxuICAgICAgICAgIFxcXFwgRmlyc3Qgc3RlcCBkZWJpdHMgQU1PVU5UIGNvaW5zIGluIFNFTkRFUiBhY2NvdW50IGFuZCB5aWVsZHMgXFxcXFxcbiAgICAgICAgICBcXFxcIFJFQ0VJVkVSLCBSRUNFSVZFUl9HVUFSRCBhbmQgQU1PVU5UIHRvIFRBUkdFVC1DSEFJTi4gXFxcXFxcbiAgICAgICAgICBcXFxcIFNlY29uZCBzdGVwIGNvbnRpbnVhdGlvbiBpcyBzZW50IGludG8gVEFSR0VULUNIQUlOIHdpdGggcHJvb2YgXFxcXFxcbiAgICAgICAgICBcXFxcIG9idGFpbmVkIGZyb20gdGhlIHNwdiAnb3V0cHV0JyBlbmRwb2ludCBvZiBDaGFpbndlYi4gXFxcXFxcbiAgICAgICAgICBcXFxcIFByb29mIGlzIHZhbGlkYXRlZCBhbmQgUkVDRUlWRVIgaXMgY3JlZGl0ZWQgd2l0aCBBTU9VTlQgXFxcXFxcbiAgICAgICAgICBcXFxcIGNyZWF0aW5nIGFjY291bnQgd2l0aCBSRUNFSVZFUl9HVUFSRCBhcyBuZWNlc3NhcnkuXFxcIlxcbiAgICAgQG1vZGVsIFsgKHByb3BlcnR5ICg-IGFtb3VudCAwLjApKVxcbiAgICAgICAgICAgICAgKHByb3BlcnR5ICghPSBzZW5kZXIgXFxcIlxcXCIpKVxcbiAgICAgICAgICAgICAgKHByb3BlcnR5ICghPSByZWNlaXZlciBcXFwiXFxcIikpXFxuICAgICAgICAgICAgICAocHJvcGVydHkgKCE9IHNlbmRlciByZWNlaXZlcikpXFxuICAgICAgICAgICAgICAocHJvcGVydHkgKCE9IHRhcmdldC1jaGFpbiBcXFwiXFxcIikpXFxuICAgICAgICAgICAgXVxcbiAgICAgKVxcblxcbiAgIChkZWZ1biBnZXQtYmFsYW5jZTpkZWNpbWFsXFxuICAgICAoIGFjY291bnQ6c3RyaW5nIClcXG4gICAgIFxcXCIgR2V0IGJhbGFuY2UgZm9yIEFDQ09VTlQuIEZhaWxzIGlmIGFjY291bnQgZG9lcyBub3QgZXhpc3QuXFxcIlxcbiAgICAgKVxcblxcbiAgIChkZWZ1biBkZXRhaWxzOm9iamVjdHthY2NvdW50LWRldGFpbHN9XFxuICAgICAoIGFjY291bnQ6IHN0cmluZyApXFxuICAgICBcXFwiIEdldCBhbiBvYmplY3Qgd2l0aCBkZXRhaWxzIG9mIEFDQ09VTlQuIFxcXFxcXG4gICAgIFxcXFwgRmFpbHMgaWYgYWNjb3VudCBkb2VzIG5vdCBleGlzdC5cXFwiXFxuICAgICApXFxuXFxuICAgKGRlZnVuIHByZWNpc2lvbjppbnRlZ2VyXFxuICAgICAoKVxcbiAgICAgXFxcIlJldHVybiB0aGUgbWF4aW11bSBhbGxvd2VkIGRlY2ltYWwgcHJlY2lzaW9uLlxcXCJcXG4gICAgIClcXG5cXG4gICAoZGVmdW4gZW5mb3JjZS11bml0OmJvb2xcXG4gICAgICggYW1vdW50OmRlY2ltYWwgKVxcbiAgICAgXFxcIiBFbmZvcmNlIG1pbmltdW0gcHJlY2lzaW9uIGFsbG93ZWQgZm9yIHRyYW5zYWN0aW9ucy5cXFwiXFxuICAgICApXFxuXFxuICAgKGRlZnVuIGNyZWF0ZS1hY2NvdW50OnN0cmluZ1xcbiAgICAgKCBhY2NvdW50OnN0cmluZ1xcbiAgICAgICBndWFyZDpndWFyZFxcbiAgICAgKVxcbiAgICAgXFxcIiBDcmVhdGUgQUNDT1VOVCB3aXRoIDAuMCBiYWxhbmNlLCB3aXRoIEdVQVJEIGNvbnRyb2xsaW5nIGFjY2Vzcy5cXFwiXFxuICAgICApXFxuXFxuICAgKGRlZnVuIHJvdGF0ZTpzdHJpbmdcXG4gICAgICggYWNjb3VudDpzdHJpbmdcXG4gICAgICAgbmV3LWd1YXJkOmd1YXJkXFxuICAgICApXFxuICAgICBcXFwiIFJvdGF0ZSBndWFyZCBmb3IgQUNDT1VOVC4gVHJhbnNhY3Rpb24gaXMgdmFsaWRhdGVkIGFnYWluc3QgXFxcXFxcbiAgICAgXFxcXCBleGlzdGluZyBndWFyZCBiZWZvcmUgaW5zdGFsbGluZyBuZXcgZ3VhcmQuIFxcXCJcXG4gICAgIClcXG5cXG4pXFxuXCJ9fSxcInNpZ25lcnNcIjpbXSxcIm1ldGFcIjp7XCJjcmVhdGlvblRpbWVcIjowLFwidHRsXCI6MTcyODAwLFwiZ2FzTGltaXRcIjowLFwiY2hhaW5JZFwiOlwiXCIsXCJnYXNQcmljZVwiOjAsXCJzZW5kZXJcIjpcIlwifSxcIm5vbmNlXCI6XCJmdW5naWJsZS1hc3NldC12MlwifSJ9", unsafeFromText "eyJnYXMiOjAsInJlc3VsdCI6eyJzdGF0dXMiOiJzdWNjZXNzIiwiZGF0YSI6IkxvYWRlZCBpbnRlcmZhY2UgZnVuZ2libGUtdjIsIGhhc2ggWXhFLUtnQzZKbUttQ2NnS1RKbWxFbl9JNThJNEVYbWhmcnZ6WDdiZXJZayJ9LCJyZXFLZXkiOiIwNUJ0ajdlQlpCVzdvLVNhTG9WaEFpY01VUFpVQmJHNlFUOF9MQWtDeEhzIiwibG9ncyI6IjFTQmJBNHVzS0E5OFNlX09WRUdkcVk5WjJoSW1jVmcydWpISDJkM1ZmeEkiLCJtZXRhRGF0YSI6bnVsbCwiY29udGludWF0aW9uIjpudWxsLCJ0eElkIjoyfQ") + , (unsafeFromText "eyJoYXNoIjoiR1JJUXU0aEFLazBJRDlGOHpfLTB5WHlBS0ozM01QeVRZTVhPamxQSm1wSSIsInNpZ3MiOltdLCJjbWQiOiJ7XCJuZXR3b3JrSWRcIjpudWxsLFwicGF5bG9hZFwiOntcImV4ZWNcIjp7XCJkYXRhXCI6bnVsbCxcImNvZGVcIjpcIlxcbihtb2R1bGUgY29pbiBHT1ZFUk5BTkNFXFxuXFxuICBAZG9jIFxcXCInY29pbicgcmVwcmVzZW50cyB0aGUgS2FkZW5hIENvaW4gQ29udHJhY3QuIFRoaXMgY29udHJhY3QgcHJvdmlkZXMgYm90aCB0aGUgXFxcXFxcbiAgXFxcXGJ1eS9yZWRlZW0gZ2FzIHN1cHBvcnQgaW4gdGhlIGZvcm0gb2YgJ2Z1bmQtdHgnLCBhcyB3ZWxsIGFzIHRyYW5zZmVyLCAgICAgICBcXFxcXFxuICBcXFxcY3JlZGl0LCBkZWJpdCwgY29pbmJhc2UsIGFjY291bnQgY3JlYXRpb24gYW5kIHF1ZXJ5LCBhcyB3ZWxsIGFzIFNQViBidXJuICAgIFxcXFxcXG4gIFxcXFxjcmVhdGUuIFRvIGFjY2VzcyB0aGUgY29pbiBjb250cmFjdCwgeW91IG1heSB1c2UgaXRzIGZ1bGx5LXF1YWxpZmllZCBuYW1lLCAgXFxcXFxcbiAgXFxcXG9yIGlzc3VlIHRoZSAnKHVzZSBjb2luKScgY29tbWFuZCBpbiB0aGUgYm9keSBvZiBhIG1vZHVsZSBkZWNsYXJhdGlvbi5cXFwiXFxuXFxuICBAbW9kZWxcXG4gICAgWyAoZGVmcHJvcGVydHkgY29uc2VydmVzLW1hc3NcXG4gICAgICAgICg9IChjb2x1bW4tZGVsdGEgY29pbi10YWJsZSAnYmFsYW5jZSkgMC4wKSlcXG5cXG4gICAgICAoZGVmcHJvcGVydHkgdmFsaWQtYWNjb3VudCAoYWNjb3VudDpzdHJpbmcpXFxuICAgICAgICAoYW5kXFxuICAgICAgICAgICg-PSAobGVuZ3RoIGFjY291bnQpIDMpXFxuICAgICAgICAgICg8PSAobGVuZ3RoIGFjY291bnQpIDI1NikpKVxcbiAgICBdXFxuXFxuICAoaW1wbGVtZW50cyBmdW5naWJsZS12MilcXG4gIChpbXBsZW1lbnRzIGZ1bmdpYmxlLXhjaGFpbi12MSlcXG5cXG4gIDs7IGNvaW4tdjJcXG4gIChibGVzcyBcXFwidXRfSl9aTmtveWFQVUVKaGl3VmVXbmtTUW45SlQ5c1FDV0tkampWVnJXb1xcXCIpXFxuXFxuICA7OyBjb2luIHYzXFxuICAoYmxlc3MgXFxcIjFvc19zTEFVWXZCenNwbjVqamF3dFJwSldpSDFXUGZoeU5yYWVWdlNJd1VcXFwiKVxcblxcbiAgOzsgY29pbiB2NFxcbiAgKGJsZXNzIFxcXCJCalpXMFQyYWM2cUVfSTVYOEdFNGZhbDZ0VHFqaExUQzdteTB5dFFTeExVXFxcIilcXG5cXG4gIDs7IGNvaW4gdjVcXG4gIChibGVzcyBcXFwickU3RFU4amxRTDl4X01QWXVuaVpKZjVJQ0JUQUVIQUlGUUNCNGJsb2ZQNFxcXCIpXFxuXFxuICA7IC0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tXFxuICA7IFNjaGVtYXMgYW5kIFRhYmxlc1xcblxcbiAgKGRlZnNjaGVtYSBjb2luLXNjaGVtYVxcbiAgICBAZG9jIFxcXCJUaGUgY29pbiBjb250cmFjdCB0b2tlbiBzY2hlbWFcXFwiXFxuICAgIEBtb2RlbCBbIChpbnZhcmlhbnQgKD49IGJhbGFuY2UgMC4wKSkgXVxcblxcbiAgICBiYWxhbmNlOmRlY2ltYWxcXG4gICAgZ3VhcmQ6Z3VhcmQpXFxuXFxuICAoZGVmdGFibGUgY29pbi10YWJsZTp7Y29pbi1zY2hlbWF9KVxcblxcbiAgOyAtLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLVxcbiAgOyBDYXBhYmlsaXRpZXNcXG5cXG4gIChkZWZjYXAgR09WRVJOQU5DRSAoKVxcbiAgICAoZW5mb3JjZSBmYWxzZSBcXFwiRW5mb3JjZSBub24tdXBncmFkZWFiaWxpdHlcXFwiKSlcXG5cXG4gIChkZWZjYXAgR0FTICgpXFxuICAgIFxcXCJNYWdpYyBjYXBhYmlsaXR5IHRvIHByb3RlY3QgZ2FzIGJ1eSBhbmQgcmVkZWVtXFxcIlxcbiAgICB0cnVlKVxcblxcbiAgKGRlZmNhcCBDT0lOQkFTRSAoKVxcbiAgICBcXFwiTWFnaWMgY2FwYWJpbGl0eSB0byBwcm90ZWN0IG1pbmVyIHJld2FyZFxcXCJcXG4gICAgdHJ1ZSlcXG5cXG4gIChkZWZjYXAgR0VORVNJUyAoKVxcbiAgICBcXFwiTWFnaWMgY2FwYWJpbGl0eSBjb25zdHJhaW5pbmcgZ2VuZXNpcyB0cmFuc2FjdGlvbnNcXFwiXFxuICAgIHRydWUpXFxuXFxuICAoZGVmY2FwIFJFTUVESUFURSAoKVxcbiAgICBcXFwiTWFnaWMgY2FwYWJpbGl0eSBmb3IgcmVtZWRpYXRpb24gdHJhbnNhY3Rpb25zXFxcIlxcbiAgICB0cnVlKVxcblxcbiAgKGRlZmNhcCBERUJJVCAoc2VuZGVyOnN0cmluZylcXG4gICAgXFxcIkNhcGFiaWxpdHkgZm9yIG1hbmFnaW5nIGRlYml0aW5nIG9wZXJhdGlvbnNcXFwiXFxuICAgIChlbmZvcmNlLWd1YXJkIChhdCAnZ3VhcmQgKHJlYWQgY29pbi10YWJsZSBzZW5kZXIpKSlcXG4gICAgKGVuZm9yY2UgKCE9IHNlbmRlciBcXFwiXFxcIikgXFxcInZhbGlkIHNlbmRlclxcXCIpKVxcblxcbiAgKGRlZmNhcCBDUkVESVQgKHJlY2VpdmVyOnN0cmluZylcXG4gICAgXFxcIkNhcGFiaWxpdHkgZm9yIG1hbmFnaW5nIGNyZWRpdGluZyBvcGVyYXRpb25zXFxcIlxcbiAgICAoZW5mb3JjZSAoIT0gcmVjZWl2ZXIgXFxcIlxcXCIpIFxcXCJ2YWxpZCByZWNlaXZlclxcXCIpKVxcblxcbiAgKGRlZmNhcCBST1RBVEUgKGFjY291bnQ6c3RyaW5nKVxcbiAgICBAZG9jIFxcXCJBdXRvbm9tb3VzbHkgbWFuYWdlZCBjYXBhYmlsaXR5IGZvciBndWFyZCByb3RhdGlvblxcXCJcXG4gICAgQG1hbmFnZWRcXG4gICAgdHJ1ZSlcXG5cXG4gIChkZWZjYXAgVFJBTlNGRVI6Ym9vbFxcbiAgICAoIHNlbmRlcjpzdHJpbmdcXG4gICAgICByZWNlaXZlcjpzdHJpbmdcXG4gICAgICBhbW91bnQ6ZGVjaW1hbFxcbiAgICApXFxuICAgIEBtYW5hZ2VkIGFtb3VudCBUUkFOU0ZFUi1tZ3JcXG4gICAgKGVuZm9yY2UgKCE9IHNlbmRlciByZWNlaXZlcikgXFxcInNhbWUgc2VuZGVyIGFuZCByZWNlaXZlclxcXCIpXFxuICAgIChlbmZvcmNlLXVuaXQgYW1vdW50KVxcbiAgICAoZW5mb3JjZSAoPiBhbW91bnQgMC4wKSBcXFwiUG9zaXRpdmUgYW1vdW50XFxcIilcXG4gICAgKGNvbXBvc2UtY2FwYWJpbGl0eSAoREVCSVQgc2VuZGVyKSlcXG4gICAgKGNvbXBvc2UtY2FwYWJpbGl0eSAoQ1JFRElUIHJlY2VpdmVyKSlcXG4gIClcXG5cXG4gIChkZWZ1biBUUkFOU0ZFUi1tZ3I6ZGVjaW1hbFxcbiAgICAoIG1hbmFnZWQ6ZGVjaW1hbFxcbiAgICAgIHJlcXVlc3RlZDpkZWNpbWFsXFxuICAgIClcXG5cXG4gICAgKGxldCAoKG5ld2JhbCAoLSBtYW5hZ2VkIHJlcXVlc3RlZCkpKVxcbiAgICAgIChlbmZvcmNlICg-PSBuZXdiYWwgMC4wKVxcbiAgICAgICAgKGZvcm1hdCBcXFwiVFJBTlNGRVIgZXhjZWVkZWQgZm9yIGJhbGFuY2Uge31cXFwiIFttYW5hZ2VkXSkpXFxuICAgICAgbmV3YmFsKVxcbiAgKVxcblxcbiAgKGRlZmNhcCBUUkFOU0ZFUl9YQ0hBSU46Ym9vbFxcbiAgICAoIHNlbmRlcjpzdHJpbmdcXG4gICAgICByZWNlaXZlcjpzdHJpbmdcXG4gICAgICBhbW91bnQ6ZGVjaW1hbFxcbiAgICAgIHRhcmdldC1jaGFpbjpzdHJpbmdcXG4gICAgKVxcblxcbiAgICBAbWFuYWdlZCBhbW91bnQgVFJBTlNGRVJfWENIQUlOLW1nclxcbiAgICAoZW5mb3JjZS11bml0IGFtb3VudClcXG4gICAgKGVuZm9yY2UgKD4gYW1vdW50IDAuMCkgXFxcIkNyb3NzLWNoYWluIHRyYW5zZmVycyByZXF1aXJlIGEgcG9zaXRpdmUgYW1vdW50XFxcIilcXG4gICAgKGNvbXBvc2UtY2FwYWJpbGl0eSAoREVCSVQgc2VuZGVyKSlcXG4gIClcXG5cXG4gIChkZWZ1biBUUkFOU0ZFUl9YQ0hBSU4tbWdyOmRlY2ltYWxcXG4gICAgKCBtYW5hZ2VkOmRlY2ltYWxcXG4gICAgICByZXF1ZXN0ZWQ6ZGVjaW1hbFxcbiAgICApXFxuXFxuICAgIChlbmZvcmNlICg-PSBtYW5hZ2VkIHJlcXVlc3RlZClcXG4gICAgICAoZm9ybWF0IFxcXCJUUkFOU0ZFUl9YQ0hBSU4gZXhjZWVkZWQgZm9yIGJhbGFuY2Uge31cXFwiIFttYW5hZ2VkXSkpXFxuICAgIDAuMFxcbiAgKVxcblxcbiAgKGRlZmNhcCBUUkFOU0ZFUl9YQ0hBSU5fUkVDRDpib29sXFxuICAgICggc2VuZGVyOnN0cmluZ1xcbiAgICAgIHJlY2VpdmVyOnN0cmluZ1xcbiAgICAgIGFtb3VudDpkZWNpbWFsXFxuICAgICAgc291cmNlLWNoYWluOnN0cmluZ1xcbiAgICApXFxuICAgIEBldmVudCB0cnVlXFxuICApXFxuXFxuICA7IHYzIGNhcGFiaWxpdGllc1xcbiAgKGRlZmNhcCBSRUxFQVNFX0FMTE9DQVRJT05cXG4gICAgKCBhY2NvdW50OnN0cmluZ1xcbiAgICAgIGFtb3VudDpkZWNpbWFsXFxuICAgIClcXG4gICAgQGRvYyBcXFwiRXZlbnQgZm9yIGFsbG9jYXRpb24gcmVsZWFzZSwgY2FuIGJlIHVzZWQgZm9yIHNpZyBzY29waW5nLlxcXCJcXG4gICAgQGV2ZW50IHRydWVcXG4gIClcXG5cXG4gIDsgLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS1cXG4gIDsgQ29uc3RhbnRzXFxuXFxuICAoZGVmY29uc3QgQ09JTl9DSEFSU0VUIENIQVJTRVRfTEFUSU4xXFxuICAgIFxcXCJUaGUgZGVmYXVsdCBjb2luIGNvbnRyYWN0IGNoYXJhY3RlciBzZXRcXFwiKVxcblxcbiAgKGRlZmNvbnN0IE1JTklNVU1fUFJFQ0lTSU9OIDEyXFxuICAgIFxcXCJNaW5pbXVtIGFsbG93ZWQgcHJlY2lzaW9uIGZvciBjb2luIHRyYW5zYWN0aW9uc1xcXCIpXFxuXFxuICAoZGVmY29uc3QgTUlOSU1VTV9BQ0NPVU5UX0xFTkdUSCAzXFxuICAgIFxcXCJNaW5pbXVtIGFjY291bnQgbGVuZ3RoIGFkbWlzc2libGUgZm9yIGNvaW4gYWNjb3VudHNcXFwiKVxcblxcbiAgKGRlZmNvbnN0IE1BWElNVU1fQUNDT1VOVF9MRU5HVEggMjU2XFxuICAgIFxcXCJNYXhpbXVtIGFjY291bnQgbmFtZSBsZW5ndGggYWRtaXNzaWJsZSBmb3IgY29pbiBhY2NvdW50c1xcXCIpXFxuXFxuICAoZGVmY29uc3QgVkFMSURfQ0hBSU5fSURTIChtYXAgKGludC10by1zdHIgMTApIChlbnVtZXJhdGUgMCAxOSkpXFxuICAgIFxcXCJMaXN0IG9mIGFsbCB2YWxpZCBDaGFpbndlYiBjaGFpbiBpZHNcXFwiKVxcblxcbiAgOyAtLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLVxcbiAgOyBVdGlsaXRpZXNcXG5cXG4gIChkZWZ1biBlbmZvcmNlLXVuaXQ6Ym9vbCAoYW1vdW50OmRlY2ltYWwpXFxuICAgIEBkb2MgXFxcIkVuZm9yY2UgbWluaW11bSBwcmVjaXNpb24gYWxsb3dlZCBmb3IgY29pbiB0cmFuc2FjdGlvbnNcXFwiXFxuXFxuICAgIChlbmZvcmNlXFxuICAgICAgKD0gKGZsb29yIGFtb3VudCBNSU5JTVVNX1BSRUNJU0lPTilcXG4gICAgICAgICBhbW91bnQpXFxuICAgICAgKGZvcm1hdCBcXFwiQW1vdW50IHZpb2xhdGVzIG1pbmltdW0gcHJlY2lzaW9uOiB7fVxcXCIgW2Ftb3VudF0pKVxcbiAgICApXFxuXFxuICAoZGVmdW4gdmFsaWRhdGUtYWNjb3VudCAoYWNjb3VudDpzdHJpbmcpXFxuICAgIEBkb2MgXFxcIkVuZm9yY2UgdGhhdCBhbiBhY2NvdW50IG5hbWUgY29uZm9ybXMgdG8gdGhlIGNvaW4gY29udHJhY3QgXFxcXFxcbiAgICAgICAgIFxcXFxtaW5pbXVtIGFuZCBtYXhpbXVtIGxlbmd0aCByZXF1aXJlbWVudHMsIGFzIHdlbGwgYXMgdGhlICAgIFxcXFxcXG4gICAgICAgICBcXFxcbGF0aW4tMSBjaGFyYWN0ZXIgc2V0LlxcXCJcXG5cXG4gICAgKGVuZm9yY2VcXG4gICAgICAoaXMtY2hhcnNldCBDT0lOX0NIQVJTRVQgYWNjb3VudClcXG4gICAgICAoZm9ybWF0XFxuICAgICAgICBcXFwiQWNjb3VudCBkb2VzIG5vdCBjb25mb3JtIHRvIHRoZSBjb2luIGNvbnRyYWN0IGNoYXJzZXQ6IHt9XFxcIlxcbiAgICAgICAgW2FjY291bnRdKSlcXG5cXG4gICAgKGxldCAoKGFjY291bnQtbGVuZ3RoIChsZW5ndGggYWNjb3VudCkpKVxcblxcbiAgICAgIChlbmZvcmNlXFxuICAgICAgICAoPj0gYWNjb3VudC1sZW5ndGggTUlOSU1VTV9BQ0NPVU5UX0xFTkdUSClcXG4gICAgICAgIChmb3JtYXRcXG4gICAgICAgICAgXFxcIkFjY291bnQgbmFtZSBkb2VzIG5vdCBjb25mb3JtIHRvIHRoZSBtaW4gbGVuZ3RoIHJlcXVpcmVtZW50OiB7fVxcXCJcXG4gICAgICAgICAgW2FjY291bnRdKSlcXG5cXG4gICAgICAoZW5mb3JjZVxcbiAgICAgICAgKDw9IGFjY291bnQtbGVuZ3RoIE1BWElNVU1fQUNDT1VOVF9MRU5HVEgpXFxuICAgICAgICAoZm9ybWF0XFxuICAgICAgICAgIFxcXCJBY2NvdW50IG5hbWUgZG9lcyBub3QgY29uZm9ybSB0byB0aGUgbWF4IGxlbmd0aCByZXF1aXJlbWVudDoge31cXFwiXFxuICAgICAgICAgIFthY2NvdW50XSkpXFxuICAgICAgKVxcbiAgKVxcblxcbiAgOyAtLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLVxcbiAgOyBDb2luIENvbnRyYWN0XFxuXFxuICAoZGVmdW4gZ2FzLW9ubHkgKClcXG4gICAgXFxcIlByZWRpY2F0ZSBmb3IgZ2FzLW9ubHkgdXNlciBndWFyZHMuXFxcIlxcbiAgICAocmVxdWlyZS1jYXBhYmlsaXR5IChHQVMpKSlcXG5cXG4gIChkZWZ1biBnYXMtZ3VhcmQgKGd1YXJkOmd1YXJkKVxcbiAgICBcXFwiUHJlZGljYXRlIGZvciBnYXMgKyBzaW5nbGUga2V5IHVzZXIgZ3VhcmRzXFxcIlxcbiAgICAoZW5mb3JjZS1vbmVcXG4gICAgICBcXFwiRW5mb3JjZSBlaXRoZXIgdGhlIHByZXNlbmNlIG9mIGEgR0FTIGNhcCBvciBrZXlzZXRcXFwiXFxuICAgICAgWyAoZ2FzLW9ubHkpXFxuICAgICAgICAoZW5mb3JjZS1ndWFyZCBndWFyZClcXG4gICAgICBdKSlcXG5cXG4gIChkZWZ1biBidXktZ2FzOnN0cmluZyAoc2VuZGVyOnN0cmluZyB0b3RhbDpkZWNpbWFsKVxcbiAgICBAZG9jIFxcXCJUaGlzIGZ1bmN0aW9uIGRlc2NyaWJlcyB0aGUgbWFpbiAnZ2FzIGJ1eScgb3BlcmF0aW9uLiBBdCB0aGlzIHBvaW50IFxcXFxcXG4gICAgXFxcXE1JTkVSIGhhcyBiZWVuIGNob3NlbiBmcm9tIHRoZSBwb29sLCBhbmQgd2lsbCBiZSB2YWxpZGF0ZWQuIFRoZSBTRU5ERVIgICBcXFxcXFxuICAgIFxcXFxvZiB0aGlzIHRyYW5zYWN0aW9uIGhhcyBzcGVjaWZpZWQgYSBnYXMgbGltaXQgTElNSVQgKG1heGltdW0gZ2FzKSBmb3IgICAgXFxcXFxcbiAgICBcXFxcdGhlIHRyYW5zYWN0aW9uLCBhbmQgdGhlIHByaWNlIGlzIHRoZSBzcG90IHByaWNlIG9mIGdhcyBhdCB0aGF0IHRpbWUuICAgIFxcXFxcXG4gICAgXFxcXFRoZSBnYXMgYnV5IHdpbGwgYmUgZXhlY3V0ZWQgcHJpb3IgdG8gZXhlY3V0aW5nIFNFTkRFUidzIGNvZGUuXFxcIlxcblxcbiAgICBAbW9kZWwgWyAocHJvcGVydHkgKD4gdG90YWwgMC4wKSlcXG4gICAgICAgICAgICAgKHByb3BlcnR5ICh2YWxpZC1hY2NvdW50IHNlbmRlcikpXFxuICAgICAgICAgICBdXFxuXFxuICAgICh2YWxpZGF0ZS1hY2NvdW50IHNlbmRlcilcXG5cXG4gICAgKGVuZm9yY2UtdW5pdCB0b3RhbClcXG4gICAgKGVuZm9yY2UgKD4gdG90YWwgMC4wKSBcXFwiZ2FzIHN1cHBseSBtdXN0IGJlIGEgcG9zaXRpdmUgcXVhbnRpdHlcXFwiKVxcblxcbiAgICAocmVxdWlyZS1jYXBhYmlsaXR5IChHQVMpKVxcbiAgICAod2l0aC1jYXBhYmlsaXR5IChERUJJVCBzZW5kZXIpXFxuICAgICAgKGRlYml0IHNlbmRlciB0b3RhbCkpXFxuICAgIClcXG5cXG4gIChkZWZ1biByZWRlZW0tZ2FzOnN0cmluZyAobWluZXI6c3RyaW5nIG1pbmVyLWd1YXJkOmd1YXJkIHNlbmRlcjpzdHJpbmcgdG90YWw6ZGVjaW1hbClcXG4gICAgQGRvYyBcXFwiVGhpcyBmdW5jdGlvbiBkZXNjcmliZXMgdGhlIG1haW4gJ3JlZGVlbSBnYXMnIG9wZXJhdGlvbi4gQXQgdGhpcyAgICBcXFxcXFxuICAgIFxcXFxwb2ludCwgdGhlIFNFTkRFUidzIHRyYW5zYWN0aW9uIGhhcyBiZWVuIGV4ZWN1dGVkLCBhbmQgdGhlIGdhcyB0aGF0ICAgICAgXFxcXFxcbiAgICBcXFxcd2FzIGNoYXJnZWQgaGFzIGJlZW4gY2FsY3VsYXRlZC4gTUlORVIgd2lsbCBiZSBjcmVkaXRlZCB0aGUgZ2FzIGNvc3QsICAgIFxcXFxcXG4gICAgXFxcXGFuZCBTRU5ERVIgd2lsbCByZWNlaXZlIHRoZSByZW1haW5kZXIgdXAgdG8gdGhlIGxpbWl0XFxcIlxcblxcbiAgICBAbW9kZWwgWyAocHJvcGVydHkgKD4gdG90YWwgMC4wKSlcXG4gICAgICAgICAgICAgKHByb3BlcnR5ICh2YWxpZC1hY2NvdW50IHNlbmRlcikpXFxuICAgICAgICAgICAgIChwcm9wZXJ0eSAodmFsaWQtYWNjb3VudCBtaW5lcikpXFxuICAgICAgICAgICBdXFxuXFxuICAgICh2YWxpZGF0ZS1hY2NvdW50IHNlbmRlcilcXG4gICAgKHZhbGlkYXRlLWFjY291bnQgbWluZXIpXFxuICAgIChlbmZvcmNlLXVuaXQgdG90YWwpXFxuXFxuICAgIChyZXF1aXJlLWNhcGFiaWxpdHkgKEdBUykpXFxuICAgIChsZXQqXFxuICAgICAgKChmZWUgKHJlYWQtZGVjaW1hbCBcXFwiZmVlXFxcIikpXFxuICAgICAgIChyZWZ1bmQgKC0gdG90YWwgZmVlKSkpXFxuXFxuICAgICAgKGVuZm9yY2UtdW5pdCBmZWUpXFxuICAgICAgKGVuZm9yY2UgKD49IGZlZSAwLjApXFxuICAgICAgICBcXFwiZmVlIG11c3QgYmUgYSBub24tbmVnYXRpdmUgcXVhbnRpdHlcXFwiKVxcblxcbiAgICAgIChlbmZvcmNlICg-PSByZWZ1bmQgMC4wKVxcbiAgICAgICAgXFxcInJlZnVuZCBtdXN0IGJlIGEgbm9uLW5lZ2F0aXZlIHF1YW50aXR5XFxcIilcXG5cXG4gICAgICAoZW1pdC1ldmVudCAoVFJBTlNGRVIgc2VuZGVyIG1pbmVyIGZlZSkpIDt2M1xcblxcbiAgICAgICAgOyBkaXJlY3RseSB1cGRhdGUgaW5zdGVhZCBvZiBjcmVkaXRcXG4gICAgICAod2l0aC1jYXBhYmlsaXR5IChDUkVESVQgc2VuZGVyKVxcbiAgICAgICAgKGlmICg-IHJlZnVuZCAwLjApXFxuICAgICAgICAgICh3aXRoLXJlYWQgY29pbi10YWJsZSBzZW5kZXJcXG4gICAgICAgICAgICB7IFxcXCJiYWxhbmNlXFxcIiA6PSBiYWxhbmNlIH1cXG4gICAgICAgICAgICAodXBkYXRlIGNvaW4tdGFibGUgc2VuZGVyXFxuICAgICAgICAgICAgICB7IFxcXCJiYWxhbmNlXFxcIjogKCsgYmFsYW5jZSByZWZ1bmQpIH0pKVxcblxcbiAgICAgICAgICBcXFwibm9vcFxcXCIpKVxcblxcbiAgICAgICh3aXRoLWNhcGFiaWxpdHkgKENSRURJVCBtaW5lcilcXG4gICAgICAgIChpZiAoPiBmZWUgMC4wKVxcbiAgICAgICAgICAoY3JlZGl0IG1pbmVyIG1pbmVyLWd1YXJkIGZlZSlcXG4gICAgICAgICAgXFxcIm5vb3BcXFwiKSlcXG4gICAgICApXFxuXFxuICAgIClcXG5cXG4gIChkZWZ1biBjcmVhdGUtYWNjb3VudDpzdHJpbmcgKGFjY291bnQ6c3RyaW5nIGd1YXJkOmd1YXJkKVxcbiAgICBAbW9kZWwgWyAocHJvcGVydHkgKHZhbGlkLWFjY291bnQgYWNjb3VudCkpIF1cXG5cXG4gICAgKHZhbGlkYXRlLWFjY291bnQgYWNjb3VudClcXG4gICAgKGVuZm9yY2UtcmVzZXJ2ZWQgYWNjb3VudCBndWFyZClcXG5cXG4gICAgKGluc2VydCBjb2luLXRhYmxlIGFjY291bnRcXG4gICAgICB7IFxcXCJiYWxhbmNlXFxcIiA6IDAuMFxcbiAgICAgICwgXFxcImd1YXJkXFxcIiAgIDogZ3VhcmRcXG4gICAgICB9KVxcbiAgICApXFxuXFxuICAoZGVmdW4gZ2V0LWJhbGFuY2U6ZGVjaW1hbCAoYWNjb3VudDpzdHJpbmcpXFxuICAgICh3aXRoLXJlYWQgY29pbi10YWJsZSBhY2NvdW50XFxuICAgICAgeyBcXFwiYmFsYW5jZVxcXCIgOj0gYmFsYW5jZSB9XFxuICAgICAgYmFsYW5jZVxcbiAgICAgIClcXG4gICAgKVxcblxcbiAgKGRlZnVuIGRldGFpbHM6b2JqZWN0e2Z1bmdpYmxlLXYyLmFjY291bnQtZGV0YWlsc31cXG4gICAgKCBhY2NvdW50OnN0cmluZyApXFxuICAgICh3aXRoLXJlYWQgY29pbi10YWJsZSBhY2NvdW50XFxuICAgICAgeyBcXFwiYmFsYW5jZVxcXCIgOj0gYmFsXFxuICAgICAgLCBcXFwiZ3VhcmRcXFwiIDo9IGcgfVxcbiAgICAgIHsgXFxcImFjY291bnRcXFwiIDogYWNjb3VudFxcbiAgICAgICwgXFxcImJhbGFuY2VcXFwiIDogYmFsXFxuICAgICAgLCBcXFwiZ3VhcmRcXFwiOiBnIH0pXFxuICAgIClcXG5cXG4gIChkZWZ1biByb3RhdGU6c3RyaW5nIChhY2NvdW50OnN0cmluZyBuZXctZ3VhcmQ6Z3VhcmQpXFxuICAgICh3aXRoLWNhcGFiaWxpdHkgKFJPVEFURSBhY2NvdW50KVxcblxcbiAgICAgIDsgQWxsb3cgcm90YXRpb24gb25seSBmb3IgdmFuaXR5IGFjY291bnRzLCBvclxcbiAgICAgIDsgcmUtcm90YXRpbmcgYSBwcmluY2lwYWwgYWNjb3VudCBiYWNrIHRvIGl0cyBwcm9wZXIgZ3VhcmRcXG4gICAgICAoZW5mb3JjZSAob3IgKG5vdCAoaXMtcHJpbmNpcGFsIGFjY291bnQpKVxcbiAgICAgICAgICAgICAgICAgICh2YWxpZGF0ZS1wcmluY2lwYWwgbmV3LWd1YXJkIGFjY291bnQpKVxcbiAgICAgICAgXFxcIkl0IGlzIHVuc2FmZSBmb3IgcHJpbmNpcGFsIGFjY291bnRzIHRvIHJvdGF0ZSB0aGVpciBndWFyZFxcXCIpXFxuXFxuICAgICAgKHdpdGgtcmVhZCBjb2luLXRhYmxlIGFjY291bnRcXG4gICAgICAgIHsgXFxcImd1YXJkXFxcIiA6PSBvbGQtZ3VhcmQgfVxcbiAgICAgICAgKGVuZm9yY2UtZ3VhcmQgb2xkLWd1YXJkKVxcbiAgICAgICAgKHVwZGF0ZSBjb2luLXRhYmxlIGFjY291bnRcXG4gICAgICAgICAgeyBcXFwiZ3VhcmRcXFwiIDogbmV3LWd1YXJkIH1cXG4gICAgICAgICAgKSkpXFxuICAgIClcXG5cXG5cXG4gIChkZWZ1biBwcmVjaXNpb246aW50ZWdlclxcbiAgICAoKVxcbiAgICBNSU5JTVVNX1BSRUNJU0lPTilcXG5cXG4gIChkZWZ1biB0cmFuc2ZlcjpzdHJpbmcgKHNlbmRlcjpzdHJpbmcgcmVjZWl2ZXI6c3RyaW5nIGFtb3VudDpkZWNpbWFsKVxcbiAgICBAbW9kZWwgWyAocHJvcGVydHkgY29uc2VydmVzLW1hc3MpXFxuICAgICAgICAgICAgIChwcm9wZXJ0eSAoPiBhbW91bnQgMC4wKSlcXG4gICAgICAgICAgICAgKHByb3BlcnR5ICh2YWxpZC1hY2NvdW50IHNlbmRlcikpXFxuICAgICAgICAgICAgIChwcm9wZXJ0eSAodmFsaWQtYWNjb3VudCByZWNlaXZlcikpXFxuICAgICAgICAgICAgIChwcm9wZXJ0eSAoIT0gc2VuZGVyIHJlY2VpdmVyKSkgXVxcblxcbiAgICAoZW5mb3JjZSAoIT0gc2VuZGVyIHJlY2VpdmVyKVxcbiAgICAgIFxcXCJzZW5kZXIgY2Fubm90IGJlIHRoZSByZWNlaXZlciBvZiBhIHRyYW5zZmVyXFxcIilcXG5cXG4gICAgKHZhbGlkYXRlLWFjY291bnQgc2VuZGVyKVxcbiAgICAodmFsaWRhdGUtYWNjb3VudCByZWNlaXZlcilcXG5cXG4gICAgKGVuZm9yY2UgKD4gYW1vdW50IDAuMClcXG4gICAgICBcXFwidHJhbnNmZXIgYW1vdW50IG11c3QgYmUgcG9zaXRpdmVcXFwiKVxcblxcbiAgICAoZW5mb3JjZS11bml0IGFtb3VudClcXG5cXG4gICAgKHdpdGgtY2FwYWJpbGl0eSAoVFJBTlNGRVIgc2VuZGVyIHJlY2VpdmVyIGFtb3VudClcXG4gICAgICAoZGViaXQgc2VuZGVyIGFtb3VudClcXG4gICAgICAod2l0aC1yZWFkIGNvaW4tdGFibGUgcmVjZWl2ZXJcXG4gICAgICAgIHsgXFxcImd1YXJkXFxcIiA6PSBnIH1cXG5cXG4gICAgICAgIChjcmVkaXQgcmVjZWl2ZXIgZyBhbW91bnQpKVxcbiAgICAgIClcXG4gICAgKVxcblxcbiAgKGRlZnVuIHRyYW5zZmVyLWNyZWF0ZTpzdHJpbmdcXG4gICAgKCBzZW5kZXI6c3RyaW5nXFxuICAgICAgcmVjZWl2ZXI6c3RyaW5nXFxuICAgICAgcmVjZWl2ZXItZ3VhcmQ6Z3VhcmRcXG4gICAgICBhbW91bnQ6ZGVjaW1hbCApXFxuXFxuICAgIEBtb2RlbCBbIChwcm9wZXJ0eSBjb25zZXJ2ZXMtbWFzcykgXVxcblxcbiAgICAoZW5mb3JjZSAoIT0gc2VuZGVyIHJlY2VpdmVyKVxcbiAgICAgIFxcXCJzZW5kZXIgY2Fubm90IGJlIHRoZSByZWNlaXZlciBvZiBhIHRyYW5zZmVyXFxcIilcXG5cXG4gICAgKHZhbGlkYXRlLWFjY291bnQgc2VuZGVyKVxcbiAgICAodmFsaWRhdGUtYWNjb3VudCByZWNlaXZlcilcXG5cXG4gICAgKGVuZm9yY2UgKD4gYW1vdW50IDAuMClcXG4gICAgICBcXFwidHJhbnNmZXIgYW1vdW50IG11c3QgYmUgcG9zaXRpdmVcXFwiKVxcblxcbiAgICAoZW5mb3JjZS11bml0IGFtb3VudClcXG5cXG4gICAgKHdpdGgtY2FwYWJpbGl0eSAoVFJBTlNGRVIgc2VuZGVyIHJlY2VpdmVyIGFtb3VudClcXG4gICAgICAoZGViaXQgc2VuZGVyIGFtb3VudClcXG4gICAgICAoY3JlZGl0IHJlY2VpdmVyIHJlY2VpdmVyLWd1YXJkIGFtb3VudCkpXFxuICAgIClcXG5cXG4gIChkZWZ1biBjb2luYmFzZTpzdHJpbmcgKGFjY291bnQ6c3RyaW5nIGFjY291bnQtZ3VhcmQ6Z3VhcmQgYW1vdW50OmRlY2ltYWwpXFxuICAgIEBkb2MgXFxcIkludGVybmFsIGZ1bmN0aW9uIGZvciB0aGUgaW5pdGlhbCBjcmVhdGlvbiBvZiBjb2lucy4gIFRoaXMgZnVuY3Rpb24gXFxcXFxcbiAgICBcXFxcY2Fubm90IGJlIHVzZWQgb3V0c2lkZSBvZiB0aGUgY29pbiBjb250cmFjdC5cXFwiXFxuXFxuICAgIEBtb2RlbCBbIChwcm9wZXJ0eSAodmFsaWQtYWNjb3VudCBhY2NvdW50KSlcXG4gICAgICAgICAgICAgKHByb3BlcnR5ICg-IGFtb3VudCAwLjApKVxcbiAgICAgICAgICAgXVxcblxcbiAgICAodmFsaWRhdGUtYWNjb3VudCBhY2NvdW50KVxcbiAgICAoZW5mb3JjZS11bml0IGFtb3VudClcXG5cXG4gICAgKHJlcXVpcmUtY2FwYWJpbGl0eSAoQ09JTkJBU0UpKVxcbiAgICAoZW1pdC1ldmVudCAoVFJBTlNGRVIgXFxcIlxcXCIgYWNjb3VudCBhbW91bnQpKSA7djNcXG4gICAgKHdpdGgtY2FwYWJpbGl0eSAoQ1JFRElUIGFjY291bnQpXFxuICAgICAgKGNyZWRpdCBhY2NvdW50IGFjY291bnQtZ3VhcmQgYW1vdW50KSlcXG4gICAgKVxcblxcbiAgKGRlZnVuIHJlbWVkaWF0ZTpzdHJpbmcgKGFjY291bnQ6c3RyaW5nIGFtb3VudDpkZWNpbWFsKVxcbiAgICBAZG9jIFxcXCJBbGxvd3MgZm9yIHJlbWVkaWF0aW9uIHRyYW5zYWN0aW9ucy4gVGhpcyBmdW5jdGlvbiBcXFxcXFxuICAgICAgICAgXFxcXGlzIHByb3RlY3RlZCBieSB0aGUgUkVNRURJQVRFIGNhcGFiaWxpdHlcXFwiXFxuICAgIEBtb2RlbCBbIChwcm9wZXJ0eSAodmFsaWQtYWNjb3VudCBhY2NvdW50KSlcXG4gICAgICAgICAgICAgKHByb3BlcnR5ICg-IGFtb3VudCAwLjApKVxcbiAgICAgICAgICAgXVxcblxcbiAgICAodmFsaWRhdGUtYWNjb3VudCBhY2NvdW50KVxcblxcbiAgICAoZW5mb3JjZSAoPiBhbW91bnQgMC4wKVxcbiAgICAgIFxcXCJSZW1lZGlhdGlvbiBhbW91bnQgbXVzdCBiZSBwb3NpdGl2ZVxcXCIpXFxuXFxuICAgIChlbmZvcmNlLXVuaXQgYW1vdW50KVxcblxcbiAgICAocmVxdWlyZS1jYXBhYmlsaXR5IChSRU1FRElBVEUpKVxcbiAgICAoZW1pdC1ldmVudCAoVFJBTlNGRVIgXFxcIlxcXCIgYWNjb3VudCBhbW91bnQpKSA7djNcXG4gICAgKHdpdGgtcmVhZCBjb2luLXRhYmxlIGFjY291bnRcXG4gICAgICB7IFxcXCJiYWxhbmNlXFxcIiA6PSBiYWxhbmNlIH1cXG5cXG4gICAgICAoZW5mb3JjZSAoPD0gYW1vdW50IGJhbGFuY2UpIFxcXCJJbnN1ZmZpY2llbnQgZnVuZHNcXFwiKVxcblxcbiAgICAgICh1cGRhdGUgY29pbi10YWJsZSBhY2NvdW50XFxuICAgICAgICB7IFxcXCJiYWxhbmNlXFxcIiA6ICgtIGJhbGFuY2UgYW1vdW50KSB9XFxuICAgICAgICApKVxcbiAgICApXFxuXFxuICAoZGVmcGFjdCBmdW5kLXR4IChzZW5kZXI6c3RyaW5nIG1pbmVyOnN0cmluZyBtaW5lci1ndWFyZDpndWFyZCB0b3RhbDpkZWNpbWFsKVxcbiAgICBAZG9jIFxcXCInZnVuZC10eCcgaXMgYSBzcGVjaWFsIHBhY3QgdG8gZnVuZCBhIHRyYW5zYWN0aW9uIGluIHR3byBzdGVwcywgICAgIFxcXFxcXG4gICAgXFxcXHdpdGggdGhlIGFjdHVhbCB0cmFuc2FjdGlvbiB0cmFuc3BpcmluZyBpbiB0aGUgbWlkZGxlOiAgICAgICAgICAgICAgICAgICBcXFxcXFxuICAgIFxcXFwgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgXFxcXFxcbiAgICBcXFxcICAxKSBBIGJ1eWluZyBwaGFzZSwgZGViaXRpbmcgdGhlIHNlbmRlciBmb3IgdG90YWwgZ2FzIGFuZCBmZWUsIHlpZWxkaW5nIFxcXFxcXG4gICAgXFxcXCAgICAgVFhfTUFYX0NIQVJHRS4gICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICBcXFxcXFxuICAgIFxcXFwgIDIpIEEgc2V0dGxlbWVudCBwaGFzZSwgcmVzdW1pbmcgVFhfTUFYX0NIQVJHRSwgYW5kIGFsbG9jYXRpbmcgdG8gdGhlICAgXFxcXFxcbiAgICBcXFxcICAgICBjb2luYmFzZSBhY2NvdW50IGZvciB1c2VkIGdhcyBhbmQgZmVlLCBhbmQgc2VuZGVyIGFjY291bnQgZm9yIGJhbC0gIFxcXFxcXG4gICAgXFxcXCAgICAgYW5jZSAodW51c2VkIGdhcywgaWYgYW55KS5cXFwiXFxuXFxuICAgIEBtb2RlbCBbIChwcm9wZXJ0eSAoPiB0b3RhbCAwLjApKVxcbiAgICAgICAgICAgICAocHJvcGVydHkgKHZhbGlkLWFjY291bnQgc2VuZGVyKSlcXG4gICAgICAgICAgICAgKHByb3BlcnR5ICh2YWxpZC1hY2NvdW50IG1pbmVyKSlcXG4gICAgICAgICAgICAgOyhwcm9wZXJ0eSBjb25zZXJ2ZXMtbWFzcykgbm90IHN1cHBvcnRlZCB5ZXRcXG4gICAgICAgICAgIF1cXG5cXG4gICAgKHN0ZXAgKGJ1eS1nYXMgc2VuZGVyIHRvdGFsKSlcXG4gICAgKHN0ZXAgKHJlZGVlbS1nYXMgbWluZXIgbWluZXItZ3VhcmQgc2VuZGVyIHRvdGFsKSlcXG4gICAgKVxcblxcbiAgKGRlZnVuIGRlYml0OnN0cmluZyAoYWNjb3VudDpzdHJpbmcgYW1vdW50OmRlY2ltYWwpXFxuICAgIEBkb2MgXFxcIkRlYml0IEFNT1VOVCBmcm9tIEFDQ09VTlQgYmFsYW5jZVxcXCJcXG5cXG4gICAgQG1vZGVsIFsgKHByb3BlcnR5ICg-IGFtb3VudCAwLjApKVxcbiAgICAgICAgICAgICAocHJvcGVydHkgKHZhbGlkLWFjY291bnQgYWNjb3VudCkpXFxuICAgICAgICAgICBdXFxuXFxuICAgICh2YWxpZGF0ZS1hY2NvdW50IGFjY291bnQpXFxuXFxuICAgIChlbmZvcmNlICg-IGFtb3VudCAwLjApXFxuICAgICAgXFxcImRlYml0IGFtb3VudCBtdXN0IGJlIHBvc2l0aXZlXFxcIilcXG5cXG4gICAgKGVuZm9yY2UtdW5pdCBhbW91bnQpXFxuXFxuICAgIChyZXF1aXJlLWNhcGFiaWxpdHkgKERFQklUIGFjY291bnQpKVxcbiAgICAod2l0aC1yZWFkIGNvaW4tdGFibGUgYWNjb3VudFxcbiAgICAgIHsgXFxcImJhbGFuY2VcXFwiIDo9IGJhbGFuY2UgfVxcblxcbiAgICAgIChlbmZvcmNlICg8PSBhbW91bnQgYmFsYW5jZSkgXFxcIkluc3VmZmljaWVudCBmdW5kc1xcXCIpXFxuXFxuICAgICAgKHVwZGF0ZSBjb2luLXRhYmxlIGFjY291bnRcXG4gICAgICAgIHsgXFxcImJhbGFuY2VcXFwiIDogKC0gYmFsYW5jZSBhbW91bnQpIH1cXG4gICAgICAgICkpXFxuICAgIClcXG5cXG5cXG4gIChkZWZ1biBjcmVkaXQ6c3RyaW5nIChhY2NvdW50OnN0cmluZyBndWFyZDpndWFyZCBhbW91bnQ6ZGVjaW1hbClcXG4gICAgQGRvYyBcXFwiQ3JlZGl0IEFNT1VOVCB0byBBQ0NPVU5UIGJhbGFuY2VcXFwiXFxuXFxuICAgIEBtb2RlbCBbIChwcm9wZXJ0eSAoPiBhbW91bnQgMC4wKSlcXG4gICAgICAgICAgICAgKHByb3BlcnR5ICh2YWxpZC1hY2NvdW50IGFjY291bnQpKVxcbiAgICAgICAgICAgXVxcblxcbiAgICAodmFsaWRhdGUtYWNjb3VudCBhY2NvdW50KVxcblxcbiAgICAoZW5mb3JjZSAoPiBhbW91bnQgMC4wKSBcXFwiY3JlZGl0IGFtb3VudCBtdXN0IGJlIHBvc2l0aXZlXFxcIilcXG4gICAgKGVuZm9yY2UtdW5pdCBhbW91bnQpXFxuXFxuICAgIChyZXF1aXJlLWNhcGFiaWxpdHkgKENSRURJVCBhY2NvdW50KSlcXG4gICAgKHdpdGgtZGVmYXVsdC1yZWFkIGNvaW4tdGFibGUgYWNjb3VudFxcbiAgICAgIHsgXFxcImJhbGFuY2VcXFwiIDogLTEuMCwgXFxcImd1YXJkXFxcIiA6IGd1YXJkIH1cXG4gICAgICB7IFxcXCJiYWxhbmNlXFxcIiA6PSBiYWxhbmNlLCBcXFwiZ3VhcmRcXFwiIDo9IHJldGcgfVxcbiAgICAgIDsgd2UgZG9uJ3Qgd2FudCB0byBvdmVyd3JpdGUgYW4gZXhpc3RpbmcgZ3VhcmQgd2l0aCB0aGUgdXNlci1zdXBwbGllZCBvbmVcXG4gICAgICAoZW5mb3JjZSAoPSByZXRnIGd1YXJkKVxcbiAgICAgICAgXFxcImFjY291bnQgZ3VhcmRzIGRvIG5vdCBtYXRjaFxcXCIpXFxuXFxuICAgICAgKGxldCAoKGlzLW5ld1xcbiAgICAgICAgICAgICAoaWYgKD0gYmFsYW5jZSAtMS4wKVxcbiAgICAgICAgICAgICAgICAgKGVuZm9yY2UtcmVzZXJ2ZWQgYWNjb3VudCBndWFyZClcXG4gICAgICAgICAgICAgICBmYWxzZSkpKVxcblxcbiAgICAgICAgKHdyaXRlIGNvaW4tdGFibGUgYWNjb3VudFxcbiAgICAgICAgICB7IFxcXCJiYWxhbmNlXFxcIiA6IChpZiBpcy1uZXcgYW1vdW50ICgrIGJhbGFuY2UgYW1vdW50KSlcXG4gICAgICAgICAgLCBcXFwiZ3VhcmRcXFwiICAgOiByZXRnXFxuICAgICAgICAgIH0pKVxcbiAgICAgICkpXFxuXFxuICAoZGVmdW4gY2hlY2stcmVzZXJ2ZWQ6c3RyaW5nIChhY2NvdW50OnN0cmluZylcXG4gICAgXFxcIiBDaGVja3MgQUNDT1VOVCBmb3IgcmVzZXJ2ZWQgbmFtZSBhbmQgcmV0dXJucyB0eXBlIGlmIFxcXFxcXG4gICAgXFxcXCBmb3VuZCBvciBlbXB0eSBzdHJpbmcuIFJlc2VydmVkIG5hbWVzIHN0YXJ0IHdpdGggYSBcXFxcXFxuICAgIFxcXFwgc2luZ2xlIGNoYXIgYW5kIGNvbG9uLCBlLmcuICdjOmZvbycsIHdoaWNoIHdvdWxkIHJldHVybiAnYycgYXMgdHlwZS5cXFwiXFxuICAgIChsZXQgKChwZnggKHRha2UgMiBhY2NvdW50KSkpXFxuICAgICAgKGlmICg9IFxcXCI6XFxcIiAodGFrZSAtMSBwZngpKSAodGFrZSAxIHBmeCkgXFxcIlxcXCIpKSlcXG5cXG4gIChkZWZ1biBlbmZvcmNlLXJlc2VydmVkOmJvb2wgKGFjY291bnQ6c3RyaW5nIGd1YXJkOmd1YXJkKVxcbiAgICBAZG9jIFxcXCJFbmZvcmNlIHJlc2VydmVkIGFjY291bnQgbmFtZSBwcm90b2NvbHMuXFxcIlxcbiAgICAoaWYgKHZhbGlkYXRlLXByaW5jaXBhbCBndWFyZCBhY2NvdW50KVxcbiAgICAgIHRydWVcXG4gICAgICAobGV0ICgociAoY2hlY2stcmVzZXJ2ZWQgYWNjb3VudCkpKVxcbiAgICAgICAgKGlmICg9IHIgXFxcIlxcXCIpXFxuICAgICAgICAgIHRydWVcXG4gICAgICAgICAgKGlmICg9IHIgXFxcImtcXFwiKVxcbiAgICAgICAgICAgIChlbmZvcmNlIGZhbHNlIFxcXCJTaW5nbGUta2V5IGFjY291bnQgcHJvdG9jb2wgdmlvbGF0aW9uXFxcIilcXG4gICAgICAgICAgICAoZW5mb3JjZSBmYWxzZVxcbiAgICAgICAgICAgICAgKGZvcm1hdCBcXFwiUmVzZXJ2ZWQgcHJvdG9jb2wgZ3VhcmQgdmlvbGF0aW9uOiB7fVxcXCIgW3JdKSlcXG4gICAgICAgICAgICApKSkpKVxcblxcblxcbiAgKGRlZnNjaGVtYSBjcm9zc2NoYWluLXNjaGVtYVxcbiAgICBAZG9jIFxcXCJTY2hlbWEgZm9yIHlpZWxkZWQgdmFsdWUgaW4gY3Jvc3MtY2hhaW4gdHJhbnNmZXJzXFxcIlxcbiAgICByZWNlaXZlcjpzdHJpbmdcXG4gICAgcmVjZWl2ZXItZ3VhcmQ6Z3VhcmRcXG4gICAgYW1vdW50OmRlY2ltYWxcXG4gICAgc291cmNlLWNoYWluOnN0cmluZylcXG5cXG4gIChkZWZwYWN0IHRyYW5zZmVyLWNyb3NzY2hhaW46c3RyaW5nXFxuICAgICggc2VuZGVyOnN0cmluZ1xcbiAgICAgIHJlY2VpdmVyOnN0cmluZ1xcbiAgICAgIHJlY2VpdmVyLWd1YXJkOmd1YXJkXFxuICAgICAgdGFyZ2V0LWNoYWluOnN0cmluZ1xcbiAgICAgIGFtb3VudDpkZWNpbWFsIClcXG5cXG4gICAgQG1vZGVsIFsgKHByb3BlcnR5ICg-IGFtb3VudCAwLjApKVxcbiAgICAgICAgICAgICAocHJvcGVydHkgKHZhbGlkLWFjY291bnQgc2VuZGVyKSlcXG4gICAgICAgICAgICAgKHByb3BlcnR5ICh2YWxpZC1hY2NvdW50IHJlY2VpdmVyKSlcXG4gICAgICAgICAgIF1cXG5cXG4gICAgKHN0ZXBcXG4gICAgICAod2l0aC1jYXBhYmlsaXR5XFxuICAgICAgICAoVFJBTlNGRVJfWENIQUlOIHNlbmRlciByZWNlaXZlciBhbW91bnQgdGFyZ2V0LWNoYWluKVxcblxcbiAgICAgICAgKHZhbGlkYXRlLWFjY291bnQgc2VuZGVyKVxcbiAgICAgICAgKHZhbGlkYXRlLWFjY291bnQgcmVjZWl2ZXIpXFxuXFxuICAgICAgICAoZW5mb3JjZSAoIT0gXFxcIlxcXCIgdGFyZ2V0LWNoYWluKSBcXFwiZW1wdHkgdGFyZ2V0LWNoYWluXFxcIilcXG4gICAgICAgIChlbmZvcmNlICghPSAoYXQgJ2NoYWluLWlkIChjaGFpbi1kYXRhKSkgdGFyZ2V0LWNoYWluKVxcbiAgICAgICAgICBcXFwiY2Fubm90IHJ1biBjcm9zcy1jaGFpbiB0cmFuc2ZlcnMgdG8gdGhlIHNhbWUgY2hhaW5cXFwiKVxcblxcbiAgICAgICAgKGVuZm9yY2UgKD4gYW1vdW50IDAuMClcXG4gICAgICAgICAgXFxcInRyYW5zZmVyIHF1YW50aXR5IG11c3QgYmUgcG9zaXRpdmVcXFwiKVxcblxcbiAgICAgICAgKGVuZm9yY2UtdW5pdCBhbW91bnQpXFxuXFxuICAgICAgICAoZW5mb3JjZSAoY29udGFpbnMgdGFyZ2V0LWNoYWluIFZBTElEX0NIQUlOX0lEUylcXG4gICAgICAgICAgXFxcInRhcmdldCBjaGFpbiBpcyBub3QgYSB2YWxpZCBjaGFpbndlYiBjaGFpbiBpZFxcXCIpXFxuXFxuICAgICAgICA7OyBzdGVwIDEgLSBkZWJpdCBkZWxldGUtYWNjb3VudCBvbiBjdXJyZW50IGNoYWluXFxuICAgICAgICAoZGViaXQgc2VuZGVyIGFtb3VudClcXG4gICAgICAgIChlbWl0LWV2ZW50IChUUkFOU0ZFUiBzZW5kZXIgXFxcIlxcXCIgYW1vdW50KSlcXG5cXG4gICAgICAgIChsZXRcXG4gICAgICAgICAgKChjcm9zc2NoYWluLWRldGFpbHM6b2JqZWN0e2Nyb3NzY2hhaW4tc2NoZW1hfVxcbiAgICAgICAgICAgIHsgXFxcInJlY2VpdmVyXFxcIiA6IHJlY2VpdmVyXFxuICAgICAgICAgICAgLCBcXFwicmVjZWl2ZXItZ3VhcmRcXFwiIDogcmVjZWl2ZXItZ3VhcmRcXG4gICAgICAgICAgICAsIFxcXCJhbW91bnRcXFwiIDogYW1vdW50XFxuICAgICAgICAgICAgLCBcXFwic291cmNlLWNoYWluXFxcIiA6IChhdCAnY2hhaW4taWQgKGNoYWluLWRhdGEpKVxcbiAgICAgICAgICAgIH0pKVxcbiAgICAgICAgICAoeWllbGQgY3Jvc3NjaGFpbi1kZXRhaWxzIHRhcmdldC1jaGFpbilcXG4gICAgICAgICAgKSkpXFxuXFxuICAgIChzdGVwXFxuICAgICAgKHJlc3VtZVxcbiAgICAgICAgeyBcXFwicmVjZWl2ZXJcXFwiIDo9IHJlY2VpdmVyXFxuICAgICAgICAsIFxcXCJyZWNlaXZlci1ndWFyZFxcXCIgOj0gcmVjZWl2ZXItZ3VhcmRcXG4gICAgICAgICwgXFxcImFtb3VudFxcXCIgOj0gYW1vdW50XFxuICAgICAgICAsIFxcXCJzb3VyY2UtY2hhaW5cXFwiIDo9IHNvdXJjZS1jaGFpblxcbiAgICAgICAgfVxcblxcbiAgICAgICAgKGVtaXQtZXZlbnQgKFRSQU5TRkVSIFxcXCJcXFwiIHJlY2VpdmVyIGFtb3VudCkpXFxuICAgICAgICAoZW1pdC1ldmVudCAoVFJBTlNGRVJfWENIQUlOX1JFQ0QgXFxcIlxcXCIgcmVjZWl2ZXIgYW1vdW50IHNvdXJjZS1jaGFpbikpXFxuXFxuICAgICAgICA7OyBzdGVwIDIgLSBjcmVkaXQgY3JlYXRlIGFjY291bnQgb24gdGFyZ2V0IGNoYWluXFxuICAgICAgICAod2l0aC1jYXBhYmlsaXR5IChDUkVESVQgcmVjZWl2ZXIpXFxuICAgICAgICAgIChjcmVkaXQgcmVjZWl2ZXIgcmVjZWl2ZXItZ3VhcmQgYW1vdW50KSlcXG4gICAgICAgICkpXFxuICAgIClcXG5cXG5cXG4gIDsgLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS1cXG4gIDsgQ29pbiBhbGxvY2F0aW9uc1xcblxcbiAgKGRlZnNjaGVtYSBhbGxvY2F0aW9uLXNjaGVtYVxcbiAgICBAZG9jIFxcXCJHZW5lc2lzIGFsbG9jYXRpb24gcmVnaXN0cnlcXFwiXFxuICAgIDtAbW9kZWwgWyAoaW52YXJpYW50ICg-PSBiYWxhbmNlIDAuMCkpIF1cXG5cXG4gICAgYmFsYW5jZTpkZWNpbWFsXFxuICAgIGRhdGU6dGltZVxcbiAgICBndWFyZDpndWFyZFxcbiAgICByZWRlZW1lZDpib29sKVxcblxcbiAgKGRlZnRhYmxlIGFsbG9jYXRpb24tdGFibGU6e2FsbG9jYXRpb24tc2NoZW1hfSlcXG5cXG4gIChkZWZ1biBjcmVhdGUtYWxsb2NhdGlvbi1hY2NvdW50XFxuICAgICggYWNjb3VudDpzdHJpbmdcXG4gICAgICBkYXRlOnRpbWVcXG4gICAgICBrZXlzZXQtcmVmOnN0cmluZ1xcbiAgICAgIGFtb3VudDpkZWNpbWFsXFxuICAgIClcXG5cXG4gICAgQGRvYyBcXFwiQWRkIGFuIGVudHJ5IHRvIHRoZSBjb2luIGFsbG9jYXRpb24gdGFibGUuIFRoaXMgZnVuY3Rpb24gXFxcXFxcbiAgICAgICAgIFxcXFxhbHNvIGNyZWF0ZXMgYSBjb3JyZXNwb25kaW5nIGVtcHR5IGNvaW4gY29udHJhY3QgYWNjb3VudCBcXFxcXFxuICAgICAgICAgXFxcXG9mIHRoZSBzYW1lIG5hbWUgYW5kIGd1YXJkLiBSZXF1aXJlcyBHRU5FU0lTIGNhcGFiaWxpdHkuIFxcXCJcXG5cXG4gICAgQG1vZGVsIFsgKHByb3BlcnR5ICh2YWxpZC1hY2NvdW50IGFjY291bnQpKSBdXFxuXFxuICAgIChyZXF1aXJlLWNhcGFiaWxpdHkgKEdFTkVTSVMpKVxcblxcbiAgICAodmFsaWRhdGUtYWNjb3VudCBhY2NvdW50KVxcbiAgICAoZW5mb3JjZSAoPj0gYW1vdW50IDAuMClcXG4gICAgICBcXFwiYWxsb2NhdGlvbiBhbW91bnQgbXVzdCBiZSBub24tbmVnYXRpdmVcXFwiKVxcblxcbiAgICAoZW5mb3JjZS11bml0IGFtb3VudClcXG5cXG4gICAgKGxldFxcbiAgICAgICgoZ3VhcmQ6Z3VhcmQgKGtleXNldC1yZWYtZ3VhcmQga2V5c2V0LXJlZikpKVxcblxcbiAgICAgIChjcmVhdGUtYWNjb3VudCBhY2NvdW50IGd1YXJkKVxcblxcbiAgICAgIChpbnNlcnQgYWxsb2NhdGlvbi10YWJsZSBhY2NvdW50XFxuICAgICAgICB7IFxcXCJiYWxhbmNlXFxcIiA6IGFtb3VudFxcbiAgICAgICAgLCBcXFwiZGF0ZVxcXCIgOiBkYXRlXFxuICAgICAgICAsIFxcXCJndWFyZFxcXCIgOiBndWFyZFxcbiAgICAgICAgLCBcXFwicmVkZWVtZWRcXFwiIDogZmFsc2VcXG4gICAgICAgIH0pKSlcXG5cXG4gIChkZWZ1biByZWxlYXNlLWFsbG9jYXRpb25cXG4gICAgKCBhY2NvdW50OnN0cmluZyApXFxuXFxuICAgIEBkb2MgXFxcIlJlbGVhc2UgZnVuZHMgYXNzb2NpYXRlZCB3aXRoIGFsbG9jYXRpb24gQUNDT1VOVCBpbnRvIG1haW4gbGVkZ2VyLiAgIFxcXFxcXG4gICAgICAgICBcXFxcQUNDT1VOVCBtdXN0IGFscmVhZHkgZXhpc3QgaW4gbWFpbiBsZWRnZXIuIEFsbG9jYXRpb24gaXMgZGVhY3RpdmF0ZWQgXFxcXFxcbiAgICAgICAgIFxcXFxhZnRlciByZWxlYXNlLlxcXCJcXG4gICAgQG1vZGVsIFsgKHByb3BlcnR5ICh2YWxpZC1hY2NvdW50IGFjY291bnQpKSBdXFxuXFxuICAgICh2YWxpZGF0ZS1hY2NvdW50IGFjY291bnQpXFxuXFxuICAgICh3aXRoLXJlYWQgYWxsb2NhdGlvbi10YWJsZSBhY2NvdW50XFxuICAgICAgeyBcXFwiYmFsYW5jZVxcXCIgOj0gYmFsYW5jZVxcbiAgICAgICwgXFxcImRhdGVcXFwiIDo9IHJlbGVhc2UtdGltZVxcbiAgICAgICwgXFxcInJlZGVlbWVkXFxcIiA6PSByZWRlZW1lZFxcbiAgICAgICwgXFxcImd1YXJkXFxcIiA6PSBndWFyZFxcbiAgICAgIH1cXG5cXG4gICAgICAobGV0ICgoY3Vyci10aW1lOnRpbWUgKGF0ICdibG9jay10aW1lIChjaGFpbi1kYXRhKSkpKVxcblxcbiAgICAgICAgKGVuZm9yY2UgKG5vdCByZWRlZW1lZClcXG4gICAgICAgICAgXFxcImFsbG9jYXRpb24gZnVuZHMgaGF2ZSBhbHJlYWR5IGJlZW4gcmVkZWVtZWRcXFwiKVxcblxcbiAgICAgICAgKGVuZm9yY2VcXG4gICAgICAgICAgKD49IGN1cnItdGltZSByZWxlYXNlLXRpbWUpXFxuICAgICAgICAgIChmb3JtYXQgXFxcImZ1bmRzIGxvY2tlZCB1bnRpbCB7fS4gY3VycmVudCB0aW1lOiB7fVxcXCIgW3JlbGVhc2UtdGltZSBjdXJyLXRpbWVdKSlcXG5cXG4gICAgICAgICh3aXRoLWNhcGFiaWxpdHkgKFJFTEVBU0VfQUxMT0NBVElPTiBhY2NvdW50IGJhbGFuY2UpXFxuXFxuICAgICAgICAoZW5mb3JjZS1ndWFyZCBndWFyZClcXG5cXG4gICAgICAgICh3aXRoLWNhcGFiaWxpdHkgKENSRURJVCBhY2NvdW50KVxcbiAgICAgICAgICAoZW1pdC1ldmVudCAoVFJBTlNGRVIgXFxcIlxcXCIgYWNjb3VudCBiYWxhbmNlKSlcXG4gICAgICAgICAgKGNyZWRpdCBhY2NvdW50IGd1YXJkIGJhbGFuY2UpXFxuXFxuICAgICAgICAgICh1cGRhdGUgYWxsb2NhdGlvbi10YWJsZSBhY2NvdW50XFxuICAgICAgICAgICAgeyBcXFwicmVkZWVtZWRcXFwiIDogdHJ1ZVxcbiAgICAgICAgICAgICwgXFxcImJhbGFuY2VcXFwiIDogMC4wXFxuICAgICAgICAgICAgfSlcXG5cXG4gICAgICAgICAgXFxcIkFsbG9jYXRpb24gc3VjY2Vzc2Z1bGx5IHJlbGVhc2VkIHRvIG1haW4gbGVkZ2VyXFxcIikpXFxuICAgICkpKVxcblxcbilcXG5cXG4oY3JlYXRlLXRhYmxlIGNvaW4tdGFibGUpXFxuKGNyZWF0ZS10YWJsZSBhbGxvY2F0aW9uLXRhYmxlKVxcblwifX0sXCJzaWduZXJzXCI6W10sXCJtZXRhXCI6e1wiY3JlYXRpb25UaW1lXCI6MCxcInR0bFwiOjE3MjgwMCxcImdhc0xpbWl0XCI6MCxcImNoYWluSWRcIjpcIlwiLFwiZ2FzUHJpY2VcIjowLFwic2VuZGVyXCI6XCJcIn0sXCJub25jZVwiOlwiY29pbi1jb250cmFjdC12Ni1pbnN0YWxsXCJ9In0", unsafeFromText "eyJnYXMiOjAsInJlc3VsdCI6eyJzdGF0dXMiOiJzdWNjZXNzIiwiZGF0YSI6IlRhYmxlQ3JlYXRlZCJ9LCJyZXFLZXkiOiJHUklRdTRoQUtrMElEOUY4el8tMHlYeUFLSjMzTVB5VFlNWE9qbFBKbXBJIiwibG9ncyI6IkxKWlA1V2ZFN1VfNGZINWltQm56dE94ZndyWWN0enQtdmNoSkRvUXN2T1EiLCJtZXRhRGF0YSI6bnVsbCwiY29udGludWF0aW9uIjpudWxsLCJ0eElkIjozfQ") + , (unsafeFromText "eyJoYXNoIjoiU0IzVzVFTGl6azl4elNWWk9MX3dsem5VNjh5aUhPQzlwWUhreHBVXzBnbyIsInNpZ3MiOltdLCJjbWQiOiJ7XCJuZXR3b3JrSWRcIjpudWxsLFwicGF5bG9hZFwiOntcImV4ZWNcIjp7XCJkYXRhXCI6bnVsbCxcImNvZGVcIjpcIihpbnRlcmZhY2UgZ2FzLXBheWVyLXYxXFxuXFxuICAoZGVmY2FwIEdBU19QQVlFUjpib29sXFxuICAgICggdXNlcjpzdHJpbmdcXG4gICAgICBsaW1pdDppbnRlZ2VyXFxuICAgICAgcHJpY2U6ZGVjaW1hbFxcbiAgICApXFxuICAgIEBkb2NcXG4gICAgXFxcIiBQcm92aWRlIGEgY2FwYWJpbGl0eSBpbmRpY2F0aW5nIHRoYXQgZGVjbGFyaW5nIG1vZHVsZSBzdXBwb3J0cyBcXFxcXFxuICAgIFxcXFwgZ2FzIHBheW1lbnQgZm9yIFVTRVIgZm9yIGdhcyBMSU1JVCBhbmQgUFJJQ0UuIEZ1bmN0aW9uYWxpdHkgXFxcXFxcbiAgICBcXFxcIHNob3VsZCByZXF1aXJlIGNhcGFiaWxpdHkgKGNvaW4uRlVORF9UWCksIGFuZCBzaG91bGQgdmFsaWRhdGUgXFxcXFxcbiAgICBcXFxcIHRoZSBzcGVuZCBvZiAobGltaXQgKiBwcmljZSksIHBvc3NpYmx5IHVwZGF0aW5nIHNvbWUgZGF0YWJhc2UgXFxcXFxcbiAgICBcXFxcIGVudHJ5LiBcXFxcXFxuICAgIFxcXFwgU2hvdWxkIGNvbXBvc2UgY2FwYWJpbGl0eSByZXF1aXJlZCBmb3IgJ2NyZWF0ZS1nYXMtcGF5ZXItZ3VhcmQnLlxcXCJcXG4gICAgQG1vZGVsXFxuICAgIFsgKHByb3BlcnR5ICh1c2VyICE9IFxcXCJcXFwiKSlcXG4gICAgICAocHJvcGVydHkgKGxpbWl0ID4gMCkpXFxuICAgICAgKHByb3BlcnR5IChwcmljZSA-IDAuMCkpXFxuICAgIF1cXG4gIClcXG5cXG4gIChkZWZ1biBjcmVhdGUtZ2FzLXBheWVyLWd1YXJkOmd1YXJkICgpXFxuICAgIEBkb2NcXG4gICAgXFxcIiBQcm92aWRlIGEgZ3VhcmQgc3VpdGFibGUgZm9yIGNvbnRyb2xsaW5nIGEgY29pbiBhY2NvdW50IHRoYXQgY2FuIFxcXFxcXG4gICAgXFxcXCBwYXkgZ2FzIHZpYSBHQVNfUEFZRVIgbWVjaGFuaWNzLiBHZW5lcmFsbHkgdGhpcyBpcyBhY2NvbXBsaXNoZWQgXFxcXFxcbiAgICBcXFxcIGJ5IGhhdmluZyBHQVNfUEFZRVIgY29tcG9zZSBhbiB1bnBhcmFtZXRlcml6ZWQsIHVubWFuYWdlZCBjYXBhYmlsaXR5IFxcXFxcXG4gICAgXFxcXCB0aGF0IGlzIHJlcXVpcmVkIGluIHRoaXMgZ3VhcmQuIFRodXMsIGlmIGNvaW4gY29udHJhY3QgaXMgYWJsZSB0byBcXFxcXFxuICAgIFxcXFwgc3VjY2Vzc2Z1bGx5IGFjcXVpcmUgR0FTX1BBWUVSLCB0aGUgY29tcG9zZWQgJ2Fub255bW91cycgY2FwIHJlcXVpcmVkIFxcXFxcXG4gICAgXFxcXCBoZXJlIHdpbGwgYmUgaW4gc2NvcGUsIGFuZCBnYXMgYnV5IHdpbGwgc3VjY2VlZC5cXFwiXFxuICApXFxuXFxuKVxcblwifX0sXCJzaWduZXJzXCI6W10sXCJtZXRhXCI6e1wiY3JlYXRpb25UaW1lXCI6MCxcInR0bFwiOjE3MjgwMCxcImdhc0xpbWl0XCI6MCxcImNoYWluSWRcIjpcIlwiLFwiZ2FzUHJpY2VcIjowLFwic2VuZGVyXCI6XCJcIn0sXCJub25jZVwiOlwiZ2VuZXNpcy0wMVwifSJ9", unsafeFromText "eyJnYXMiOjAsInJlc3VsdCI6eyJzdGF0dXMiOiJzdWNjZXNzIiwiZGF0YSI6IkxvYWRlZCBpbnRlcmZhY2UgZ2FzLXBheWVyLXYxLCBoYXNoIGlJV0FQMW9lbl9rcFhqRmJuUU04N0FKUlpJZ3RzZlpjQXdZckV5MjFSV1EifSwicmVxS2V5IjoiU0IzVzVFTGl6azl4elNWWk9MX3dsem5VNjh5aUhPQzlwWUhreHBVXzBnbyIsImxvZ3MiOiJ3TXdXV3hkSFVuU1VOWXJ1RXlISEtTTzUyeGtkVXU0TXBmbE1FcHYyT05FIiwibWV0YURhdGEiOm51bGwsImNvbnRpbnVhdGlvbiI6bnVsbCwidHhJZCI6NH0") + , (unsafeFromText "eyJoYXNoIjoiQ1pteWxXZmllUk1CTXU1dzJFT21wRndLLXQ3YmNPVHM0bUsyYVQzM3VSNCIsInNpZ3MiOltdLCJjbWQiOiJ7XCJuZXR3b3JrSWRcIjpudWxsLFwicGF5bG9hZFwiOntcImV4ZWNcIjp7XCJkYXRhXCI6e1wibnMtYWRtaW4ta2V5c2V0XCI6W1wiMzY4ODIwZjgwYzMyNGJiYzdjMmIwNjEwNjg4YTdkYTQzZTM5ZjkxZDExODczMjY3MWNkOWM3NTAwZmY0M2NjYVwiXSxcIm5zLW9wZXJhdGUta2V5c2V0XCI6W1wiMzY4ODIwZjgwYzMyNGJiYzdjMmIwNjEwNjg4YTdkYTQzZTM5ZjkxZDExODczMjY3MWNkOWM3NTAwZmY0M2NjYVwiXSxcIm5zLWdlbmVzaXMta2V5c2V0XCI6e1wicHJlZFwiOlwiPVwiLFwia2V5c1wiOltdfX0sXCJjb2RlXCI6XCIoZGVmaW5lLWtleXNldCAnbnMtYWRtaW4ta2V5c2V0IChyZWFkLWtleXNldCAnbnMtYWRtaW4ta2V5c2V0KSlcXG4oZGVmaW5lLWtleXNldCAnbnMtb3BlcmF0ZS1rZXlzZXQgKHJlYWQta2V5c2V0ICducy1nZW5lc2lzLWtleXNldCkpXFxuXFxuKG1vZHVsZSBucyBHT1ZFUk5BTkNFXFxuICBcXFwiQWRtaW5pc3RlcnMgZGVmaW5pdGlvbiBvZiBuZXcgbmFtZXNwYWNlcyBpbiBDaGFpbndlYi5cXFwiXFxuXFxuICAoZGVmc2NoZW1hIHJlZy1lbnRyeVxcbiAgICBhZG1pbi1ndWFyZDpndWFyZFxcbiAgICBhY3RpdmU6Ym9vbClcXG5cXG4gIChkZWZ0YWJsZSByZWdpc3RyeTp7cmVnLWVudHJ5fSlcXG5cXG4gIChkZWZjYXAgR09WRVJOQU5DRSAoKVxcbiAgICAoZW5mb3JjZS1rZXlzZXQgJ25zLWFkbWluLWtleXNldCkpXFxuXFxuICAoZGVmY2FwIE9QRVJBVEUgKClcXG4gICAgKGVuZm9yY2Uta2V5c2V0ICducy1vcGVyYXRlLWtleXNldCkpXFxuXFxuICAoZGVmY29uc3QgR1VBUkRfU1VDQ0VTUyAoY3JlYXRlLXVzZXItZ3VhcmQgKHN1Y2Nlc3MpKSlcXG4gIChkZWZjb25zdCBHVUFSRF9GQUlMVVJFIChjcmVhdGUtdXNlci1ndWFyZCAoZmFpbHVyZSkpKVxcblxcbiAgKGRlZnVuIHN1Y2Nlc3MgKClcXG4gICAgdHJ1ZSlcXG4gIChkZWZ1biBmYWlsdXJlICgpXFxuICAgIChlbmZvcmNlIGZhbHNlIFxcXCJEaXNhYmxlZFxcXCIpKVxcblxcbiAgKGRlZnVuIHZhbGlkYXRlLW5hbWUgKG5hbWUpXFxuICAgIChlbmZvcmNlICghPSBcXFwiXFxcIiBuYW1lKSBcXFwiRW1wdHkgbmFtZSBub3QgYWxsb3dlZFxcXCIpXFxuICAgIChlbmZvcmNlICg8IChsZW5ndGggbmFtZSkgNjQpIFxcXCJOYW1lIG11c3QgYmUgbGVzcyB0aGFuIDY0IGNoYXJhY3RlcnMgbG9uZ1xcXCIpXFxuICAgIChlbmZvcmNlIChpcy1jaGFyc2V0IENIQVJTRVRfTEFUSU4xIG5hbWUpXFxuICAgICAgICAgICAgIFxcXCJOYW1lIG11c3QgYmUgaW4gbGF0aW4xIGNoYXJzZXRcXFwiKSlcXG5cXG4gIChkZWZ1biBjcmVhdGUtcHJpbmNpcGFsLW5hbWVzcGFjZTpzdHJpbmdcXG4gICAgICAoIGc6Z3VhcmRcXG4gICAgICAgIClcXG4gICAgXFxcIiBGb3JtYXQgcHJpbmNpcGFsIG5hbWVzcGFjZSBhcyBQYWN0IGhhc2ggKEJMQUtFMmIyNTYpIG9mIHByaW5jaXBhbCBcXFxcXFxuICAgIFxcXFwgaW4gaGV4IHRydW5jYXRlZCB0byAxNjAgYml0cyAoNDAgY2hhcmFjdGVycyksIHByZXBlbmRlZCB3aXRoICduXycuXFxcXFxcbiAgICBcXFxcIE9ubHkgdzogYW5kIGs6IGFjY291bnQgcHJvdG9jb2xzIGFyZSBzdXBwb3J0ZWQuIFxcXCJcXG5cXG4gICAgKGxldFxcbiAgICAgICgodHkgKHR5cGVvZi1wcmluY2lwYWwgKGNyZWF0ZS1wcmluY2lwYWwgZykpKSlcXG5cXG4gICAgICA7OyBvbmx5IHc6IGFuZCBrOiBjdXJyZW50bHkgc3VwcG9ydGVkXFxuICAgICAgKGlmIChvciAoPSB0eSBcXFwiazpcXFwiKSAoPSB0eSBcXFwidzpcXFwiKSlcXG4gICAgICAgICgrIFxcXCJuX1xcXCIgKHRha2UgNDAgKGludC10by1zdHIgMTYgKHN0ci10by1pbnQgNjQgKGhhc2ggZykpKSkpXFxuICAgICAgICAoZW5mb3JjZSBmYWxzZVxcbiAgICAgICAgICAoZm9ybWF0IFxcXCJVbnN1cHBvcnRlZCBndWFyZCBwcm90b2NvbDoge31cXFwiIFt0eV0pKVxcbiAgICAgICAgKSlcXG4gIClcXG5cXG4gIChkZWZ1biB2YWxpZGF0ZTpib29sXFxuICAgICAgKCBucy1uYW1lOnN0cmluZ1xcbiAgICAgICAgbnMtYWRtaW46Z3VhcmRcXG4gICAgICAgIClcXG4gICAgXFxcIiBNYW5hZ2VzIG5hbWVzcGFjZSBpbnN0YWxsIGZvciBDaGFpbndlYi4gXFxcXFxcbiAgICBcXFxcIEFsbG93cyBwcmluY2lwYWwgbmFtZXNwYWNlcy4gXFxcXFxcbiAgICBcXFxcIE5vbi1wcmluY2lwYWwgbmFtZXNwYWNlcyByZXF1aXJlIGFjdGl2ZSByb3cgaW4gcmVnaXN0cnkgXFxcXFxcbiAgICBcXFxcIGZvciBOUy1OQU1FIHdpdGggZ3VhcmQgbWF0Y2hpbmcgTlMtQURNSU4uXFxcIlxcblxcbiAgICAoaWYgKD0gKGNyZWF0ZS1wcmluY2lwYWwtbmFtZXNwYWNlIG5zLWFkbWluKSBucy1uYW1lKVxcblxcbiAgICAgIHRydWUgOzsgYWxsb3cgcHJpbmNpcGFsIG5hbWVzcGFjZXNcXG5cXG4gICAgICAod2l0aC1kZWZhdWx0LXJlYWQgcmVnaXN0cnkgbnMtbmFtZSAgICAgICA7OyBvdGhlcndpc2UgZW5mb3JjZSByZWdpc3RyeVxcbiAgICAgICAgeyAnYWRtaW4tZ3VhcmQgOiBucy1hZG1pblxcbiAgICAgICAgLCAnYWN0aXZlIDogZmFsc2UgfVxcbiAgICAgICAgeyAnYWRtaW4tZ3VhcmQgOj0gYWdcXG4gICAgICAgICwgJ2FjdGl2ZSA6PSBpcy1hY3RpdmUgfVxcblxcbiAgICAgICAgKGVuZm9yY2UgaXMtYWN0aXZlIFxcXCJJbmFjdGl2ZSBvciB1bnJlZ2lzdGVyZWQgbmFtZXNwYWNlXFxcIilcXG4gICAgICAgIChlbmZvcmNlICg9IG5zLWFkbWluIGFnKSBcXFwiQWRtaW4gZ3VhcmQgbXVzdCBtYXRjaCBndWFyZCBpbiByZWdpc3RyeVxcXCIpXFxuXFxuICAgICAgICB0cnVlKVxcbiAgICAgICkpXFxuXFxuICAoZGVmdW4gd3JpdGUtcmVnaXN0cnk6c3RyaW5nXFxuICAgICAgKCBucy1uYW1lOnN0cmluZ1xcbiAgICAgICAgZ3VhcmQ6Z3VhcmRcXG4gICAgICAgIGFjdGl2ZTpib29sXFxuICAgICAgICApXFxuICAgIFxcXCIgV3JpdGUgZW50cnkgd2l0aCBHVUFSRCBhbmQgQUNUSVZFIGludG8gcmVnaXN0cnkgZm9yIE5BTUUuIFxcXFxcXG4gICAgXFxcXCBHdWFyZGVkIGJ5IG9wZXJhdGUga2V5c2V0LiBcXFwiXFxuXFxuICAgICh3aXRoLWNhcGFiaWxpdHkgKE9QRVJBVEUpXFxuXFxuICAgICAgKHZhbGlkYXRlLW5hbWUgbnMtbmFtZSlcXG5cXG4gICAgICAod3JpdGUgcmVnaXN0cnkgbnMtbmFtZVxcbiAgICAgICAgeyAnYWRtaW4tZ3VhcmQ6IGd1YXJkXFxuICAgICAgICAsICdhY3RpdmU6IGFjdGl2ZSB9KVxcblxcbiAgICAgIFxcXCJSZWdpc3RlciBlbnRyeSB3cml0dGVuXFxcIikpXFxuXFxuICAoZGVmdW4gcXVlcnk6b2JqZWN0e3JlZy1lbnRyeX1cXG4gICAgICAoIG5zLW5hbWU6c3RyaW5nIClcXG4gICAgKHJlYWQgcmVnaXN0cnkgbnMtbmFtZSkpXFxuXFxuKVxcblxcbihjcmVhdGUtdGFibGUgcmVnaXN0cnkpXFxuXFxuKHdyaXRlLXJlZ2lzdHJ5IFxcXCJrYWRlbmFcXFwiXFxuICAoa2V5c2V0LXJlZi1ndWFyZCAnbnMtb3BlcmF0ZS1rZXlzZXQpIHRydWUpXFxuKHdyaXRlLXJlZ2lzdHJ5IFxcXCJ1c2VyXFxcIiBHVUFSRF9GQUlMVVJFIHRydWUpXFxuKHdyaXRlLXJlZ2lzdHJ5IFxcXCJmcmVlXFxcIiBHVUFSRF9GQUlMVVJFIHRydWUpXFxuXFxuKGRlZmluZS1uYW1lc3BhY2UgXFxcImthZGVuYVxcXCJcXG4gIChrZXlzZXQtcmVmLWd1YXJkICducy1vcGVyYXRlLWtleXNldClcXG4gIChrZXlzZXQtcmVmLWd1YXJkICducy1vcGVyYXRlLWtleXNldCkpXFxuXFxuKGRlZmluZS1uYW1lc3BhY2UgXFxcInVzZXJcXFwiIEdVQVJEX1NVQ0NFU1MgR1VBUkRfRkFJTFVSRSlcXG4oZGVmaW5lLW5hbWVzcGFjZSBcXFwiZnJlZVxcXCIgR1VBUkRfU1VDQ0VTUyBHVUFSRF9GQUlMVVJFKVxcbjs7cm90YXRlIHRvIHJlYWwgb3BlcmF0ZSBrZXlzZXRcXG4oZGVmaW5lLWtleXNldCAnbnMtb3BlcmF0ZS1rZXlzZXQgKHJlYWQta2V5c2V0ICducy1vcGVyYXRlLWtleXNldCkpXFxuXCJ9fSxcInNpZ25lcnNcIjpbXSxcIm1ldGFcIjp7XCJjcmVhdGlvblRpbWVcIjowLFwidHRsXCI6MTcyODAwLFwiZ2FzTGltaXRcIjowLFwiY2hhaW5JZFwiOlwiXCIsXCJnYXNQcmljZVwiOjAsXCJzZW5kZXJcIjpcIlwifSxcIm5vbmNlXCI6XCJsb2FkLW5zLWRldm5ldC1zZW5kZXIwMFwifSJ9", unsafeFromText "eyJnYXMiOjAsInJlc3VsdCI6eyJzdGF0dXMiOiJzdWNjZXNzIiwiZGF0YSI6IktleXNldCB3cml0ZSBzdWNjZXNzIn0sInJlcUtleSI6IkNabXlsV2ZpZVJNQk11NXcyRU9tcEZ3Sy10N2JjT1RzNG1LMmFUMzN1UjQiLCJsb2dzIjoidDdzQzg1Y1hlWFdSdG90M1lEb2pSejZibWtncEN6enJQQ0Z6QThzTkg3OCIsIm1ldGFEYXRhIjpudWxsLCJjb250aW51YXRpb24iOm51bGwsInR4SWQiOjV9") + , (unsafeFromText "eyJoYXNoIjoiWE5BNmxPSjFXLTdYWXY1WWI0QXFsNzRveFlJN09KcWpPUVQ1b1k0OHEtZyIsInNpZ3MiOltdLCJjbWQiOiJ7XCJuZXR3b3JrSWRcIjpudWxsLFwicGF5bG9hZFwiOntcImV4ZWNcIjp7XCJkYXRhXCI6e1wiYWxsb2NhdGlvbi10ZXN0MDFcIjpbXCI3MDExYzM3OTE0MGZmODk5ZjdlNjEzYWMwYTk3ODRhN2MwYTUxNWQzMGZlMGFiMmIwYzA3ZTVhYTE3NjM1ZTNlXCJdLFwiYWxsb2NhdGlvbjAyXCI6W1wiZTllNGU3MWJkMDYzZGNmN2UwNmJkNWIxYTE2Njg4ODk3ZDE1Y2E4YmQyZTUwOWM0NTNjNjE2MjE5YzE4NmNjNVwiXSxcImFsbG9jYXRpb24wMFwiOltcImQ4MmQwZGNkZTk4MjU1MDVkODZhZmI2ZGNjMTA0MTFkNmI2N2E0MjlhNzllMjFiZGE0YmIxMTliZjI4YWI4NzFcIl0sXCJhbGxvY2F0aW9uLXRlc3QwMlwiOltcIjA2NTQ0ZTIyYmZlZjIzMGQ2ZDIyZjk0ODZhYzZjYjc2YmYyNThlYmZiZjAxMzdlZTU4ZjY1NzQzZTFhNWI4YzRcIl0sXCJhbGxvY2F0aW9uMDFcIjpbXCJiNGM4YTNlYTkxZDMxNDZiMDU2MDk5NDc0MGYwZTNlZWQ5MWM1OWQyZWVjYTFkYzk5ZjBjMjg3Mjg0NWMyOTRkXCJdfSxcImNvZGVcIjpcIihkZWZpbmUta2V5c2V0IFxcXCJhbGxvY2F0aW9uMDBcXFwiIChyZWFkLWtleXNldCBcXFwiYWxsb2NhdGlvbjAwXFxcIikpXFxuKGRlZmluZS1rZXlzZXQgXFxcImFsbG9jYXRpb24wMVxcXCIgKHJlYWQta2V5c2V0IFxcXCJhbGxvY2F0aW9uMDFcXFwiKSlcXG4oZGVmaW5lLWtleXNldCBcXFwiYWxsb2NhdGlvbjAyXFxcIiAocmVhZC1rZXlzZXQgXFxcImFsbG9jYXRpb24wMlxcXCIpKVxcbihkZWZpbmUta2V5c2V0IFxcXCJhbGxvY2F0aW9uLXRlc3QwMVxcXCIgKHJlYWQta2V5c2V0IFxcXCJhbGxvY2F0aW9uLXRlc3QwMVxcXCIpKVxcbihkZWZpbmUta2V5c2V0IFxcXCJhbGxvY2F0aW9uLXRlc3QwMlxcXCIgKHJlYWQta2V5c2V0IFxcXCJhbGxvY2F0aW9uLXRlc3QwMlxcXCIpKVwifX0sXCJzaWduZXJzXCI6W10sXCJtZXRhXCI6e1wiY3JlYXRpb25UaW1lXCI6MCxcInR0bFwiOjE3MjgwMCxcImdhc0xpbWl0XCI6MCxcImNoYWluSWRcIjpcIlwiLFwiZ2FzUHJpY2VcIjowLFwic2VuZGVyXCI6XCJcIn0sXCJub25jZVwiOlwiZGV2bmV0LWtleXNldHNcIn0ifQ", unsafeFromText "eyJnYXMiOjAsInJlc3VsdCI6eyJzdGF0dXMiOiJzdWNjZXNzIiwiZGF0YSI6IktleXNldCB3cml0ZSBzdWNjZXNzIn0sInJlcUtleSI6IlhOQTZsT0oxVy03WFl2NVliNEFxbDc0b3hZSTdPSnFqT1FUNW9ZNDhxLWciLCJsb2dzIjoiYXJRSWpQVGRrcXhoQTNjWl9WaVE3OXM3Uk5XRTlGV2Rha0xWdXl4Nlc0YyIsIm1ldGFEYXRhIjpudWxsLCJjb250aW51YXRpb24iOm51bGwsInR4SWQiOjZ9") + , (unsafeFromText "eyJoYXNoIjoiNWtxZ0tzWWtwbjZCcS1KUnhNYnA1VG9jUWhRWGRJVVNiM1NGQm1Ba3VWcyIsInNpZ3MiOltdLCJjbWQiOiJ7XCJuZXR3b3JrSWRcIjpudWxsLFwicGF5bG9hZFwiOntcImV4ZWNcIjp7XCJkYXRhXCI6bnVsbCxcImNvZGVcIjpcIihjb2luLmNyZWF0ZS1hbGxvY2F0aW9uLWFjY291bnQgXFxcImFsbG9jYXRpb24wMFxcXCIgKHRpbWUgXFxcIjE5MDAtMTAtMTVUMTg6MDA6MDBaXFxcIikgXFxcImFsbG9jYXRpb24wMFxcXCIgMTAwMDAwMC4wKVxcbihjb2luLmNyZWF0ZS1hbGxvY2F0aW9uLWFjY291bnQgXFxcImFsbG9jYXRpb24wMVxcXCIgKHRpbWUgXFxcIjIxMDAtMTAtMzFUMTg6MDA6MDBaXFxcIikgXFxcImFsbG9jYXRpb24wMVxcXCIgMTAwMDAwMC4wKVxcbihjb2luLmNyZWF0ZS1hbGxvY2F0aW9uLWFjY291bnQgXFxcImFsbG9jYXRpb24wMlxcXCIgKHRpbWUgXFxcIjE5MDAtMTAtMzFUMTg6MDA6MDBaXFxcIikgXFxcImFsbG9jYXRpb24wMlxcXCIgMTAwMDAwMC4wKVxcbihjb2luLmNyZWF0ZS1hbGxvY2F0aW9uLWFjY291bnQgXFxcImFsbG9jYXRpb24tdGVzdDAxXFxcIiAodGltZSBcXFwiMTkwMC0xMC0zMVQxODowMDowMFpcXFwiKSBcXFwiYWxsb2NhdGlvbi10ZXN0MDFcXFwiIDEwMDAwMDAuMClcXG4oY29pbi5jcmVhdGUtYWxsb2NhdGlvbi1hY2NvdW50IFxcXCJhbGxvY2F0aW9uLXRlc3QwMlxcXCIgKHRpbWUgXFxcIjE5MDAtMTAtMzFUMTg6MDA6MDBaXFxcIikgXFxcImFsbG9jYXRpb24tdGVzdDAyXFxcIiAyMDAwMDAwLjApXCJ9fSxcInNpZ25lcnNcIjpbXSxcIm1ldGFcIjp7XCJjcmVhdGlvblRpbWVcIjowLFwidHRsXCI6MTcyODAwLFwiZ2FzTGltaXRcIjowLFwiY2hhaW5JZFwiOlwiXCIsXCJnYXNQcmljZVwiOjAsXCJzZW5kZXJcIjpcIlwifSxcIm5vbmNlXCI6XCJkZXZuZXQtYWxsb2NhdGlvbnNcIn0ifQ", unsafeFromText "eyJnYXMiOjAsInJlc3VsdCI6eyJzdGF0dXMiOiJzdWNjZXNzIiwiZGF0YSI6IldyaXRlIHN1Y2NlZWRlZCJ9LCJyZXFLZXkiOiI1a3FnS3NZa3BuNkJxLUpSeE1icDVUb2NRaFFYZElVU2IzU0ZCbUFrdVZzIiwibG9ncyI6IkhpX3ZfVEhFT2s2aEJFRU0yWmV2Vzh3eVJsQWpUZzNjVUQydXBlVkx0b1UiLCJtZXRhRGF0YSI6bnVsbCwiY29udGludWF0aW9uIjpudWxsLCJ0eElkIjo3fQ") + , (unsafeFromText "eyJoYXNoIjoiejJtR1ZxektqeHp5bUdHLWNpWjBCSEpGM1EzeGtvOFYyNEE4ejBxcEl4ayIsInNpZ3MiOltdLCJjbWQiOiJ7XCJuZXR3b3JrSWRcIjpudWxsLFwicGF5bG9hZFwiOntcImV4ZWNcIjp7XCJkYXRhXCI6e1wic2VuZGVyMDdcIjpbXCI0YzMxZGM5ZWU3ZjI0MTc3Zjc4YjZmNTE4MDEyYTIwODMyNmUyYWYxZjM3YmIwYTI0MDViNTA1NmQwY2FkNjI4XCJdLFwic2VuZGVyMDFcIjpbXCI2YmUyZjQ4NWE3YWY3NWZlZGI0YjdmMTUzYTkwM2Y3ZTYwMDBjYTRhYTUwMTE3OWM5MWEyNDUwYjc3N2JkMmE3XCJdLFwic2VuZGVyMDZcIjpbXCI1ZmZjMWY3ZmVmN2E0NDczODYyNTc2MmY3NWE0MjI5NDU0OTUxZTAzZjJhZmM2ZjgxMzA5YzBjMWJkZjllZTZmXCJdLFwic2VuZGVyMDBcIjpbXCIzNjg4MjBmODBjMzI0YmJjN2MyYjA2MTA2ODhhN2RhNDNlMzlmOTFkMTE4NzMyNjcxY2Q5Yzc1MDBmZjQzY2NhXCJdLFwiZTdmN1wiOltcImU3Zjc2MzRlOTI1NTQxZjM2OGI4MjdhZDVjNzI0MjE5MDUxMDBmNjIwNTI4NWE3OGMxOWQ3YjRhMzg3MTE4MDVcIl0sXCJzZW5kZXIwNVwiOltcImYwOWQ4ZjYzOTRhZWE0MjVmZTY3ODNkODhjZDgxMzYzZDgwMTdmMTZhZmQzNzExYzU3NWJlMGY1Y2Q1YzliYjlcIl0sXCJzZW5kZXIwNFwiOltcIjJkNzBhYTRmNjk3YzNhM2I4ZGQ2ZDk3NzQ1YWMwNzRlZGNmZDBlYjY1YzM3Nzc0Y2RlMjUxMzU0ODNiZWE3MWVcIl0sXCJtdWx0aS0wMi0wMy0wNC1hbnlcIjp7XCJwcmVkXCI6XCJrZXlzLWFueVwiLFwia2V5c1wiOltcIjJkNzBhYTRmNjk3YzNhM2I4ZGQ2ZDk3NzQ1YWMwNzRlZGNmZDBlYjY1YzM3Nzc0Y2RlMjUxMzU0ODNiZWE3MWVcIixcIjNhOWRkNTMyZDczZGFjZTE5NWRiYjY0ZDFkYmE2NTcyZmI3ODNkMGZkZDMyNDY4NWUzMmZiZGEyZjg5Zjk5YTZcIixcIjQzZjJhZGIxZGUxOTIwMDBjYjM3NzdiYWNjN2Y5ODNiNjYxNGZkOWMxNzE1Y2Q0NGNkNDg0YjZkM2EwZDM0YzhcIl19LFwic2VuZGVyMDlcIjpbXCJjNTlkOTg0MGIwYjY2MDkwODM2NTQ2YjdlYjRhNzM2MDYyNTc1MjdlYzhjMmI0ODIzMDBmZDIyOTI2NGIwN2U2XCJdLFwic2VuZGVyMDNcIjpbXCI0M2YyYWRiMWRlMTkyMDAwY2IzNzc3YmFjYzdmOTgzYjY2MTRmZDljMTcxNWNkNDRjZDQ4NGI2ZDNhMGQzNGM4XCJdLFwibXVsdGktMDAtMDFcIjpbXCIzNjg4MjBmODBjMzI0YmJjN2MyYjA2MTA2ODhhN2RhNDNlMzlmOTFkMTE4NzMyNjcxY2Q5Yzc1MDBmZjQzY2NhXCIsXCI2YmUyZjQ4NWE3YWY3NWZlZGI0YjdmMTUzYTkwM2Y3ZTYwMDBjYTRhYTUwMTE3OWM5MWEyNDUwYjc3N2JkMmE3XCJdLFwic2VuZGVyMDhcIjpbXCI2M2IyZWJhNGVkNzBkNDYxMmQzZTdiYzkwZGIyZmJmNGM3NmY3YjA3NDM2M2U4NmQ3M2YwYmM2MTdmOGU4YjgxXCJdLFwic2VuZGVyMDJcIjpbXCIzYTlkZDUzMmQ3M2RhY2UxOTVkYmI2NGQxZGJhNjU3MmZiNzgzZDBmZGQzMjQ2ODVlMzJmYmRhMmY4OWY5OWE2XCJdfSxcImNvZGVcIjpcIihjb2luLmNvaW5iYXNlIFxcXCJzZW5kZXIwMFxcXCIgKHJlYWQta2V5c2V0IFxcXCJzZW5kZXIwMFxcXCIpIDEwMDAwMDAwMC4wKVxcbihjb2luLmNvaW5iYXNlIFxcXCJzZW5kZXIwMVxcXCIgKHJlYWQta2V5c2V0IFxcXCJzZW5kZXIwMVxcXCIpIDExMDAwMDAwMC4wKVxcbihjb2luLmNvaW5iYXNlIFxcXCJzZW5kZXIwMlxcXCIgKHJlYWQta2V5c2V0IFxcXCJzZW5kZXIwMlxcXCIpIDEyMDAwMDAwMC4wKVxcbihjb2luLmNvaW5iYXNlIFxcXCJzZW5kZXIwM1xcXCIgKHJlYWQta2V5c2V0IFxcXCJzZW5kZXIwM1xcXCIpIDEzMDAwMDAwMC4wKVxcbihjb2luLmNvaW5iYXNlIFxcXCJzZW5kZXIwNFxcXCIgKHJlYWQta2V5c2V0IFxcXCJzZW5kZXIwNFxcXCIpIDE0MDAwMDAwMC4wKVxcbihjb2luLmNvaW5iYXNlIFxcXCJzZW5kZXIwNVxcXCIgKHJlYWQta2V5c2V0IFxcXCJzZW5kZXIwNVxcXCIpIDE1MDAwMDAwMC4wKVxcbihjb2luLmNvaW5iYXNlIFxcXCJzZW5kZXIwNlxcXCIgKHJlYWQta2V5c2V0IFxcXCJzZW5kZXIwNlxcXCIpIDE2MDAwMDAwMC4wKVxcbihjb2luLmNvaW5iYXNlIFxcXCJzZW5kZXIwN1xcXCIgKHJlYWQta2V5c2V0IFxcXCJzZW5kZXIwN1xcXCIpIDE3MDAwMDAwMC4wKVxcbihjb2luLmNvaW5iYXNlIFxcXCJzZW5kZXIwOFxcXCIgKHJlYWQta2V5c2V0IFxcXCJzZW5kZXIwOFxcXCIpIDE4MDAwMDAwMC4wKVxcbihjb2luLmNvaW5iYXNlIFxcXCJzZW5kZXIwOVxcXCIgKHJlYWQta2V5c2V0IFxcXCJzZW5kZXIwOVxcXCIpIDE5MDAwMDAwMC4wKVxcbihjb2luLmNvaW5iYXNlIFxcXCJtdWx0aS0wMC0wMVxcXCIgKHJlYWQta2V5c2V0IFxcXCJtdWx0aS0wMC0wMVxcXCIpIDEwMTAwMDAwMC4wKVxcbihjb2luLmNvaW5iYXNlIFxcXCJtdWx0aS0wMi0wMy0wNC1hbnlcXFwiIChyZWFkLWtleXNldCBcXFwibXVsdGktMDItMDMtMDQtYW55XFxcIikgMTIzNDAwMDAwLjApXFxuXFxuKGNvaW4uY29pbmJhc2UgXFxcImU3Zjc2MzRlOTI1NTQxZjM2OGI4MjdhZDVjNzI0MjE5MDUxMDBmNjIwNTI4NWE3OGMxOWQ3YjRhMzg3MTE4MDVcXFwiIChyZWFkLWtleXNldCBcXFwiZTdmN1xcXCIpIDE1MC4wKVxcblxcbjsgZW5vdWdoIHRvIGNvdmVyIHRoZSBnYXMgY29zdHMgZm9yIGFsbG9jYXRpb24gcmVsZWFzZVxcbihjb2luLmNvaW5iYXNlIFxcXCJhbGxvY2F0aW9uMDBcXFwiIChrZXlzZXQtcmVmLWd1YXJkIFxcXCJhbGxvY2F0aW9uMDBcXFwiKSAxMDAwMDAuMClcXG4oY29pbi5jb2luYmFzZSBcXFwiYWxsb2NhdGlvbjAxXFxcIiAoa2V5c2V0LXJlZi1ndWFyZCBcXFwiYWxsb2NhdGlvbjAxXFxcIikgMTAwMDAwLjApXFxuKGNvaW4uY29pbmJhc2UgXFxcImFsbG9jYXRpb24wMlxcXCIgKGtleXNldC1yZWYtZ3VhcmQgXFxcImFsbG9jYXRpb24wMlxcXCIpIDEwMDAwMC4wKVwifX0sXCJzaWduZXJzXCI6W10sXCJtZXRhXCI6e1wiY3JlYXRpb25UaW1lXCI6MCxcInR0bFwiOjE3MjgwMCxcImdhc0xpbWl0XCI6MCxcImNoYWluSWRcIjpcIlwiLFwiZ2FzUHJpY2VcIjowLFwic2VuZGVyXCI6XCJcIn0sXCJub25jZVwiOlwiZGV2bmV0LWdyYW50czBcIn0ifQ", unsafeFromText "eyJnYXMiOjAsInJlc3VsdCI6eyJzdGF0dXMiOiJzdWNjZXNzIiwiZGF0YSI6IldyaXRlIHN1Y2NlZWRlZCJ9LCJyZXFLZXkiOiJ6Mm1HVnF6S2p4enltR0ctY2laMEJISkYzUTN4a284VjI0QTh6MHFwSXhrIiwibG9ncyI6ImFCUXM2aDJGVUN1a00tM0pjQmdLZGFvRU1Ta3p2OTJkM0VmT2t5MXNrMmciLCJldmVudHMiOlt7InBhcmFtcyI6WyIiLCJzZW5kZXIwMCIsMTAwMDAwMDAwXSwibmFtZSI6IlRSQU5TRkVSIiwibW9kdWxlIjp7Im5hbWVzcGFjZSI6bnVsbCwibmFtZSI6ImNvaW4ifSwibW9kdWxlSGFzaCI6IjNpSUJRZEpuc3Q0NFoyWmdYb0hQa0FhdXliSjBoODVsX2VuX1NHSE5pYkUifSx7InBhcmFtcyI6WyIiLCJzZW5kZXIwMSIsMTEwMDAwMDAwXSwibmFtZSI6IlRSQU5TRkVSIiwibW9kdWxlIjp7Im5hbWVzcGFjZSI6bnVsbCwibmFtZSI6ImNvaW4ifSwibW9kdWxlSGFzaCI6IjNpSUJRZEpuc3Q0NFoyWmdYb0hQa0FhdXliSjBoODVsX2VuX1NHSE5pYkUifSx7InBhcmFtcyI6WyIiLCJzZW5kZXIwMiIsMTIwMDAwMDAwXSwibmFtZSI6IlRSQU5TRkVSIiwibW9kdWxlIjp7Im5hbWVzcGFjZSI6bnVsbCwibmFtZSI6ImNvaW4ifSwibW9kdWxlSGFzaCI6IjNpSUJRZEpuc3Q0NFoyWmdYb0hQa0FhdXliSjBoODVsX2VuX1NHSE5pYkUifSx7InBhcmFtcyI6WyIiLCJzZW5kZXIwMyIsMTMwMDAwMDAwXSwibmFtZSI6IlRSQU5TRkVSIiwibW9kdWxlIjp7Im5hbWVzcGFjZSI6bnVsbCwibmFtZSI6ImNvaW4ifSwibW9kdWxlSGFzaCI6IjNpSUJRZEpuc3Q0NFoyWmdYb0hQa0FhdXliSjBoODVsX2VuX1NHSE5pYkUifSx7InBhcmFtcyI6WyIiLCJzZW5kZXIwNCIsMTQwMDAwMDAwXSwibmFtZSI6IlRSQU5TRkVSIiwibW9kdWxlIjp7Im5hbWVzcGFjZSI6bnVsbCwibmFtZSI6ImNvaW4ifSwibW9kdWxlSGFzaCI6IjNpSUJRZEpuc3Q0NFoyWmdYb0hQa0FhdXliSjBoODVsX2VuX1NHSE5pYkUifSx7InBhcmFtcyI6WyIiLCJzZW5kZXIwNSIsMTUwMDAwMDAwXSwibmFtZSI6IlRSQU5TRkVSIiwibW9kdWxlIjp7Im5hbWVzcGFjZSI6bnVsbCwibmFtZSI6ImNvaW4ifSwibW9kdWxlSGFzaCI6IjNpSUJRZEpuc3Q0NFoyWmdYb0hQa0FhdXliSjBoODVsX2VuX1NHSE5pYkUifSx7InBhcmFtcyI6WyIiLCJzZW5kZXIwNiIsMTYwMDAwMDAwXSwibmFtZSI6IlRSQU5TRkVSIiwibW9kdWxlIjp7Im5hbWVzcGFjZSI6bnVsbCwibmFtZSI6ImNvaW4ifSwibW9kdWxlSGFzaCI6IjNpSUJRZEpuc3Q0NFoyWmdYb0hQa0FhdXliSjBoODVsX2VuX1NHSE5pYkUifSx7InBhcmFtcyI6WyIiLCJzZW5kZXIwNyIsMTcwMDAwMDAwXSwibmFtZSI6IlRSQU5TRkVSIiwibW9kdWxlIjp7Im5hbWVzcGFjZSI6bnVsbCwibmFtZSI6ImNvaW4ifSwibW9kdWxlSGFzaCI6IjNpSUJRZEpuc3Q0NFoyWmdYb0hQa0FhdXliSjBoODVsX2VuX1NHSE5pYkUifSx7InBhcmFtcyI6WyIiLCJzZW5kZXIwOCIsMTgwMDAwMDAwXSwibmFtZSI6IlRSQU5TRkVSIiwibW9kdWxlIjp7Im5hbWVzcGFjZSI6bnVsbCwibmFtZSI6ImNvaW4ifSwibW9kdWxlSGFzaCI6IjNpSUJRZEpuc3Q0NFoyWmdYb0hQa0FhdXliSjBoODVsX2VuX1NHSE5pYkUifSx7InBhcmFtcyI6WyIiLCJzZW5kZXIwOSIsMTkwMDAwMDAwXSwibmFtZSI6IlRSQU5TRkVSIiwibW9kdWxlIjp7Im5hbWVzcGFjZSI6bnVsbCwibmFtZSI6ImNvaW4ifSwibW9kdWxlSGFzaCI6IjNpSUJRZEpuc3Q0NFoyWmdYb0hQa0FhdXliSjBoODVsX2VuX1NHSE5pYkUifSx7InBhcmFtcyI6WyIiLCJtdWx0aS0wMC0wMSIsMTAxMDAwMDAwXSwibmFtZSI6IlRSQU5TRkVSIiwibW9kdWxlIjp7Im5hbWVzcGFjZSI6bnVsbCwibmFtZSI6ImNvaW4ifSwibW9kdWxlSGFzaCI6IjNpSUJRZEpuc3Q0NFoyWmdYb0hQa0FhdXliSjBoODVsX2VuX1NHSE5pYkUifSx7InBhcmFtcyI6WyIiLCJtdWx0aS0wMi0wMy0wNC1hbnkiLDEyMzQwMDAwMF0sIm5hbWUiOiJUUkFOU0ZFUiIsIm1vZHVsZSI6eyJuYW1lc3BhY2UiOm51bGwsIm5hbWUiOiJjb2luIn0sIm1vZHVsZUhhc2giOiIzaUlCUWRKbnN0NDRaMlpnWG9IUGtBYXV5YkowaDg1bF9lbl9TR0hOaWJFIn0seyJwYXJhbXMiOlsiIiwiZTdmNzYzNGU5MjU1NDFmMzY4YjgyN2FkNWM3MjQyMTkwNTEwMGY2MjA1Mjg1YTc4YzE5ZDdiNGEzODcxMTgwNSIsMTUwXSwibmFtZSI6IlRSQU5TRkVSIiwibW9kdWxlIjp7Im5hbWVzcGFjZSI6bnVsbCwibmFtZSI6ImNvaW4ifSwibW9kdWxlSGFzaCI6IjNpSUJRZEpuc3Q0NFoyWmdYb0hQa0FhdXliSjBoODVsX2VuX1NHSE5pYkUifSx7InBhcmFtcyI6WyIiLCJhbGxvY2F0aW9uMDAiLDEwMDAwMF0sIm5hbWUiOiJUUkFOU0ZFUiIsIm1vZHVsZSI6eyJuYW1lc3BhY2UiOm51bGwsIm5hbWUiOiJjb2luIn0sIm1vZHVsZUhhc2giOiIzaUlCUWRKbnN0NDRaMlpnWG9IUGtBYXV5YkowaDg1bF9lbl9TR0hOaWJFIn0seyJwYXJhbXMiOlsiIiwiYWxsb2NhdGlvbjAxIiwxMDAwMDBdLCJuYW1lIjoiVFJBTlNGRVIiLCJtb2R1bGUiOnsibmFtZXNwYWNlIjpudWxsLCJuYW1lIjoiY29pbiJ9LCJtb2R1bGVIYXNoIjoiM2lJQlFkSm5zdDQ0WjJaZ1hvSFBrQWF1eWJKMGg4NWxfZW5fU0dITmliRSJ9LHsicGFyYW1zIjpbIiIsImFsbG9jYXRpb24wMiIsMTAwMDAwXSwibmFtZSI6IlRSQU5TRkVSIiwibW9kdWxlIjp7Im5hbWVzcGFjZSI6bnVsbCwibmFtZSI6ImNvaW4ifSwibW9kdWxlSGFzaCI6IjNpSUJRZEpuc3Q0NFoyWmdYb0hQa0FhdXliSjBoODVsX2VuX1NHSE5pYkUifV0sIm1ldGFEYXRhIjpudWxsLCJjb250aW51YXRpb24iOm51bGwsInR4SWQiOjh9") + ] diff --git a/src/Chainweb/BlockHeader/Genesis/QuirkedGasInstantTimedCPM1to9Payload.hs b/src/Chainweb/BlockHeader/Genesis/QuirkedGasInstantTimedCPM1to9Payload.hs new file mode 100644 index 0000000000..4169118b38 --- /dev/null +++ b/src/Chainweb/BlockHeader/Genesis/QuirkedGasInstantTimedCPM1to9Payload.hs @@ -0,0 +1,39 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- This module is auto-generated. DO NOT EDIT IT MANUALLY. + +module Chainweb.BlockHeader.Genesis.QuirkedGasInstantTimedCPM1to9Payload ( payloadBlock ) where + +import qualified Data.Text as T +import qualified Data.Vector as V +import GHC.Stack + +import Chainweb.Pact.Payload +import Chainweb.Utils (unsafeFromText, toText) + +payloadBlock :: HasCallStack => PayloadWithOutputs +payloadBlock + | actualHash == expectedHash = payload + | otherwise = error + $ "inconsistent genesis payload detected. THIS IS A BUG in chainweb-node" + <> ". Expected: " <> T.unpack (toText expectedHash) + <> ", actual: " <> T.unpack (toText actualHash) + where + actualHash, expectedHash :: BlockPayloadHash + actualHash = _payloadWithOutputsPayloadHash payload + expectedHash = unsafeFromText "jrfVQ_AVbtnWRVXeUhyNurrz1XXl37sofUfEBh7EBG0" + + payload = newPayloadWithOutputs minerData coinbase txs + minerData = unsafeFromText "eyJhY2NvdW50IjoiTm9NaW5lciIsInByZWRpY2F0ZSI6IjwiLCJwdWJsaWMta2V5cyI6W119" + coinbase = unsafeFromText "eyJnYXMiOjAsInJlc3VsdCI6eyJzdGF0dXMiOiJzdWNjZXNzIiwiZGF0YSI6Ik5PX0NPSU5CQVNFIn0sInJlcUtleSI6IkRsZFJ3Q2JsUTdMb3F5NndZSm5hb2RIbDMwZDNqM2VILXF0RnpmRXY0NmciLCJsb2dzIjpudWxsLCJtZXRhRGF0YSI6bnVsbCwiY29udGludWF0aW9uIjpudWxsLCJ0eElkIjpudWxsfQ" + txs = V.fromList + [ (unsafeFromText "eyJoYXNoIjoiNDhUMExqQW5TRnBGV3h2dmFQVi1fNkUtQ2pEQVBoV1lVRldidnlmMmxGcyIsInNpZ3MiOltdLCJjbWQiOiJ7XCJuZXR3b3JrSWRcIjpudWxsLFwicGF5bG9hZFwiOntcImV4ZWNcIjp7XCJkYXRhXCI6bnVsbCxcImNvZGVcIjpcIihpbnRlcmZhY2UgZnVuZ2libGUtdjFcXG5cXG4gIFxcXCIgU3RhbmRhcmQgZm9yIGZ1bmdpYmxlIGNvaW5zIGFuZCB0b2tlbnMgYXMgc3BlY2lmaWVkIGluIEtJUC0wMDAyLiBcXFwiXFxuXFxuICAgOyAtLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tXFxuICAgOyBTY2hlbWFcXG5cXG4gICAoZGVmc2NoZW1hIGFjY291bnQtZGV0YWlsc1xcbiAgICBAZG9jIFxcXCJTY2hlbWEgZm9yIHJlc3VsdHMgb2YgJ2FjY291bnQnIG9wZXJhdGlvbi5cXFwiXFxuICAgIEBtb2RlbCBbIChpbnZhcmlhbnQgKCE9IFxcXCJcXFwiIHNlbmRlcikpIF1cXG5cXG4gICAgYWNjb3VudDpzdHJpbmdcXG4gICAgYmFsYW5jZTpkZWNpbWFsXFxuICAgIGd1YXJkOmd1YXJkKVxcblxcblxcbiAgIDsgLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLVxcbiAgIDsgQ2Fwc1xcblxcbiAgIChkZWZjYXAgVFJBTlNGRVI6Ym9vbFxcbiAgICAgKCBzZW5kZXI6c3RyaW5nXFxuICAgICAgIHJlY2VpdmVyOnN0cmluZ1xcbiAgICAgICBhbW91bnQ6ZGVjaW1hbFxcbiAgICAgKVxcbiAgICAgQGRvYyBcXFwiIE1hbmFnZWQgY2FwYWJpbGl0eSBzZWFsaW5nIEFNT1VOVCBmb3IgdHJhbnNmZXIgZnJvbSBTRU5ERVIgdG8gXFxcXFxcbiAgICAgICAgICBcXFxcIFJFQ0VJVkVSLiBQZXJtaXRzIGFueSBudW1iZXIgb2YgdHJhbnNmZXJzIHVwIHRvIEFNT1VOVC5cXFwiXFxuICAgICBAbWFuYWdlZCBhbW91bnQgVFJBTlNGRVItbWdyXFxuICAgICApXFxuXFxuICAgKGRlZnVuIFRSQU5TRkVSLW1ncjpkZWNpbWFsXFxuICAgICAoIG1hbmFnZWQ6ZGVjaW1hbFxcbiAgICAgICByZXF1ZXN0ZWQ6ZGVjaW1hbFxcbiAgICAgKVxcbiAgICAgQGRvYyBcXFwiIE1hbmFnZXMgVFJBTlNGRVIgQU1PVU5UIGxpbmVhcmx5LCBcXFxcXFxuICAgICAgICAgIFxcXFwgc3VjaCB0aGF0IGEgcmVxdWVzdCBmb3IgMS4wIGFtb3VudCBvbiBhIDMuMCBcXFxcXFxuICAgICAgICAgIFxcXFwgbWFuYWdlZCBxdWFudGl0eSBlbWl0cyB1cGRhdGVkIGFtb3VudCAyLjAuXFxcIlxcbiAgICAgKVxcblxcbiAgIDsgLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLVxcbiAgIDsgRnVuY3Rpb25hbGl0eVxcblxcbiAgIChkZWZ1biB0cmFuc2Zlci1jcmVhdGU6c3RyaW5nXFxuICAgICAoIHNlbmRlcjpzdHJpbmdcXG4gICAgICAgcmVjZWl2ZXI6c3RyaW5nXFxuICAgICAgIHJlY2VpdmVyLWd1YXJkOmd1YXJkXFxuICAgICAgIGFtb3VudDpkZWNpbWFsXFxuICAgICApXFxuICAgICBAZG9jIFxcXCIgVHJhbnNmZXIgQU1PVU5UIGJldHdlZW4gYWNjb3VudHMgU0VOREVSIGFuZCBSRUNFSVZFUi4gXFxcXFxcbiAgICAgICAgICBcXFxcIEZhaWxzIGlmIFNFTkRFUiBkb2VzIG5vdCBleGlzdC4gSWYgUkVDRUlWRVIgZXhpc3RzLCBndWFyZCBcXFxcXFxuICAgICAgICAgIFxcXFwgbXVzdCBtYXRjaCBleGlzdGluZyB2YWx1ZS4gSWYgUkVDRUlWRVIgZG9lcyBub3QgZXhpc3QsIFxcXFxcXG4gICAgICAgICAgXFxcXCBSRUNFSVZFUiBhY2NvdW50IGlzIGNyZWF0ZWQgdXNpbmcgUkVDRUlWRVItR1VBUkQuIFxcXFxcXG4gICAgICAgICAgXFxcXCBTdWJqZWN0IHRvIG1hbmFnZW1lbnQgYnkgVFJBTlNGRVIgY2FwYWJpbGl0eS5cXFwiXFxuICAgICBAbW9kZWwgWyAocHJvcGVydHkgKD4gYW1vdW50IDAuMCkpXFxuICAgICAgICAgICAgICAocHJvcGVydHkgKCE9IHNlbmRlciBcXFwiXFxcIikpXFxuICAgICAgICAgICAgICAocHJvcGVydHkgKCE9IHJlY2VpdmVyIFxcXCJcXFwiKSlcXG4gICAgICAgICAgICAgIChwcm9wZXJ0eSAoIT0gc2VuZGVyIHJlY2VpdmVyKSlcXG4gICAgICAgICAgICBdXFxuICAgICApXFxuXFxuICAgKGRlZnBhY3QgdHJhbnNmZXItY3Jvc3NjaGFpbjpzdHJpbmdcXG4gICAgICggc2VuZGVyOnN0cmluZ1xcbiAgICAgICByZWNlaXZlcjpzdHJpbmdcXG4gICAgICAgcmVjZWl2ZXItZ3VhcmQ6Z3VhcmRcXG4gICAgICAgdGFyZ2V0LWNoYWluOnN0cmluZ1xcbiAgICAgICBhbW91bnQ6ZGVjaW1hbFxcbiAgICAgKVxcbiAgICAgQGRvYyBcXFwiIDItc3RlcCBwYWN0IHRvIHRyYW5zZmVyIEFNT1VOVCBmcm9tIFNFTkRFUiBvbiBjdXJyZW50IGNoYWluIFxcXFxcXG4gICAgICAgICAgXFxcXCB0byBSRUNFSVZFUiBvbiBUQVJHRVQtQ0hBSU4gdmlhIFNQViBwcm9vZi4gXFxcXFxcbiAgICAgICAgICBcXFxcIFRBUkdFVC1DSEFJTiBtdXN0IGJlIGRpZmZlcmVudCB0aGFuIGN1cnJlbnQgY2hhaW4gaWQuIFxcXFxcXG4gICAgICAgICAgXFxcXCBGaXJzdCBzdGVwIGRlYml0cyBBTU9VTlQgY29pbnMgaW4gU0VOREVSIGFjY291bnQgYW5kIHlpZWxkcyBcXFxcXFxuICAgICAgICAgIFxcXFwgUkVDRUlWRVIsIFJFQ0VJVkVSX0dVQVJEIGFuZCBBTU9VTlQgdG8gVEFSR0VULUNIQUlOLiBcXFxcXFxuICAgICAgICAgIFxcXFwgU2Vjb25kIHN0ZXAgY29udGludWF0aW9uIGlzIHNlbnQgaW50byBUQVJHRVQtQ0hBSU4gd2l0aCBwcm9vZiBcXFxcXFxuICAgICAgICAgIFxcXFwgb2J0YWluZWQgZnJvbSB0aGUgc3B2ICdvdXRwdXQnIGVuZHBvaW50IG9mIENoYWlud2ViLiBcXFxcXFxuICAgICAgICAgIFxcXFwgUHJvb2YgaXMgdmFsaWRhdGVkIGFuZCBSRUNFSVZFUiBpcyBjcmVkaXRlZCB3aXRoIEFNT1VOVCBcXFxcXFxuICAgICAgICAgIFxcXFwgY3JlYXRpbmcgYWNjb3VudCB3aXRoIFJFQ0VJVkVSX0dVQVJEIGFzIG5lY2Vzc2FyeS5cXFwiXFxuICAgICBAbW9kZWwgWyAocHJvcGVydHkgKD4gYW1vdW50IDAuMCkpXFxuICAgICAgICAgICAgICAocHJvcGVydHkgKCE9IHNlbmRlciBcXFwiXFxcIikpXFxuICAgICAgICAgICAgICAocHJvcGVydHkgKCE9IHJlY2VpdmVyIFxcXCJcXFwiKSlcXG4gICAgICAgICAgICAgIChwcm9wZXJ0eSAoIT0gc2VuZGVyIHJlY2VpdmVyKSlcXG4gICAgICAgICAgICAgIChwcm9wZXJ0eSAoIT0gdGFyZ2V0LWNoYWluIFxcXCJcXFwiKSlcXG4gICAgICAgICAgICBdXFxuICAgICApXFxuXFxuICAgKGRlZnVuIGdldC1iYWxhbmNlOmRlY2ltYWxcXG4gICAgICggYWNjb3VudDpzdHJpbmcgKVxcbiAgICAgXFxcIiBHZXQgYmFsYW5jZSBmb3IgQUNDT1VOVC4gRmFpbHMgaWYgYWNjb3VudCBkb2VzIG5vdCBleGlzdC5cXFwiXFxuICAgICApXFxuXFxuICAgKGRlZnVuIGRldGFpbHM6b2JqZWN0e2FjY291bnQtZGV0YWlsc31cXG4gICAgICggYWNjb3VudDogc3RyaW5nIClcXG4gICAgIFxcXCIgR2V0IGFuIG9iamVjdCB3aXRoIGRldGFpbHMgb2YgQUNDT1VOVC4gXFxcXFxcbiAgICAgXFxcXCBGYWlscyBpZiBhY2NvdW50IGRvZXMgbm90IGV4aXN0LlxcXCJcXG4gICAgIClcXG5cXG4gICAoZGVmdW4gcHJlY2lzaW9uOmludGVnZXJcXG4gICAgICgpXFxuICAgICBcXFwiUmV0dXJuIHRoZSBtYXhpbXVtIGFsbG93ZWQgZGVjaW1hbCBwcmVjaXNpb24uXFxcIlxcbiAgICAgKVxcblxcbiAgIChkZWZ1biBlbmZvcmNlLXVuaXQ6Ym9vbFxcbiAgICAgKCBhbW91bnQ6ZGVjaW1hbCApXFxuICAgICBcXFwiIEVuZm9yY2UgbWluaW11bSBwcmVjaXNpb24gYWxsb3dlZCBmb3IgdHJhbnNhY3Rpb25zLlxcXCJcXG4gICAgIClcXG5cXG4gICAoZGVmdW4gY3JlYXRlLWFjY291bnQ6c3RyaW5nXFxuICAgICAoIGFjY291bnQ6c3RyaW5nXFxuICAgICAgIGd1YXJkOmd1YXJkXFxuICAgICApXFxuICAgICBcXFwiIENyZWF0ZSBBQ0NPVU5UIHdpdGggMC4wIGJhbGFuY2UsIHdpdGggR1VBUkQgY29udHJvbGxpbmcgYWNjZXNzLlxcXCJcXG4gICAgIClcXG5cXG4gICAoZGVmdW4gcm90YXRlOnN0cmluZ1xcbiAgICAgKCBhY2NvdW50OnN0cmluZ1xcbiAgICAgICBuZXctZ3VhcmQ6Z3VhcmRcXG4gICAgIClcXG4gICAgIFxcXCIgUm90YXRlIGd1YXJkIGZvciBBQ0NPVU5ULiBUcmFuc2FjdGlvbiBpcyB2YWxpZGF0ZWQgYWdhaW5zdCBcXFxcXFxuICAgICBcXFxcIGV4aXN0aW5nIGd1YXJkIGJlZm9yZSBpbnN0YWxsaW5nIG5ldyBndWFyZC4gXFxcIlxcbiAgICAgKVxcblxcbilcXG5cIn19LFwic2lnbmVyc1wiOltdLFwibWV0YVwiOntcImNyZWF0aW9uVGltZVwiOjAsXCJ0dGxcIjoxNzI4MDAsXCJnYXNMaW1pdFwiOjAsXCJjaGFpbklkXCI6XCJcIixcImdhc1ByaWNlXCI6MCxcInNlbmRlclwiOlwiXCJ9LFwibm9uY2VcIjpcImdlbmVzaXMtMDFcIn0ifQ", unsafeFromText "eyJnYXMiOjAsInJlc3VsdCI6eyJzdGF0dXMiOiJzdWNjZXNzIiwiZGF0YSI6IkxvYWRlZCBpbnRlcmZhY2UgZnVuZ2libGUtdjEsIGhhc2ggTm1kUnRzekN3YWNqSEd5eUU5Tl9mbFFNUlJCaGNIVkZQNE9qaGlQZWoxRSJ9LCJyZXFLZXkiOiI0OFQwTGpBblNGcEZXeHZ2YVBWLV82RS1DakRBUGhXWVVGV2J2eWYybEZzIiwibG9ncyI6IlB3eDlycG9kS2prSGNPUlh2WFVRSUpjRVZRZDhPSXRNM0FlakNFRExMVXMiLCJtZXRhRGF0YSI6bnVsbCwiY29udGludWF0aW9uIjpudWxsLCJ0eElkIjowfQ") + , (unsafeFromText "eyJoYXNoIjoieW5ucDFYVVNSTjJrMUYwYTZ2dXM3RFp0SDZjcHN6MVhmX0d3V0xnTFhTTSIsInNpZ3MiOltdLCJjbWQiOiJ7XCJuZXR3b3JrSWRcIjpudWxsLFwicGF5bG9hZFwiOntcImV4ZWNcIjp7XCJkYXRhXCI6bnVsbCxcImNvZGVcIjpcIihpbnRlcmZhY2UgZnVuZ2libGUteGNoYWluLXYxXFxuXFxuICBcXFwiIFRoaXMgaW50ZXJmYWNlIG9mZmVycyBhIHN0YW5kYXJkIGNhcGFiaWxpdHkgZm9yIGNyb3NzLWNoYWluIFxcXFxcXG4gIFxcXFwgdHJhbnNmZXJzIGFuZCBhc3NvY2lhdGVkIGV2ZW50cy4gXFxcIlxcblxcbiAgKGRlZmNhcCBUUkFOU0ZFUl9YQ0hBSU46Ym9vbFxcbiAgICAoIHNlbmRlcjpzdHJpbmdcXG4gICAgICByZWNlaXZlcjpzdHJpbmdcXG4gICAgICBhbW91bnQ6ZGVjaW1hbFxcbiAgICAgIHRhcmdldC1jaGFpbjpzdHJpbmdcXG4gICAgKVxcbiAgICBAZG9jIFxcXCIgTWFuYWdlZCBjYXBhYmlsaXR5IHNlYWxpbmcgQU1PVU5UIGZvciB0cmFuc2ZlciBcXFxcXFxuICAgICAgICAgXFxcXCBmcm9tIFNFTkRFUiB0byBSRUNFSVZFUiBvbiBUQVJHRVQtQ0hBSU4uIFBlcm1pdHMgXFxcXFxcbiAgICAgICAgIFxcXFwgYW55IG51bWJlciBvZiBjcm9zcy1jaGFpbiB0cmFuc2ZlcnMgdXAgdG8gQU1PVU5ULlxcXCJcXG5cXG4gICAgQG1hbmFnZWQgYW1vdW50IFRSQU5TRkVSX1hDSEFJTi1tZ3JcXG4gICAgKVxcblxcbiAgKGRlZnVuIFRSQU5TRkVSX1hDSEFJTi1tZ3I6ZGVjaW1hbFxcbiAgICAoIG1hbmFnZWQ6ZGVjaW1hbFxcbiAgICAgIHJlcXVlc3RlZDpkZWNpbWFsXFxuICAgIClcXG4gICAgQGRvYyBcXFwiIEFsbG93cyBUUkFOU0ZFUi1YQ0hBSU4gQU1PVU5UIHRvIGJlIGxlc3MgdGhhbiBvciBcXFxcXFxuICAgICAgICAgXFxcXCBlcXVhbCBtYW5hZ2VkIHF1YW50aXR5IGFzIGEgb25lLXNob3QsIHJldHVybmluZyAwLjAuXFxcIlxcbiAgKVxcblxcbiAgKGRlZmNhcCBUUkFOU0ZFUl9YQ0hBSU5fUkVDRDpib29sXFxuICAgICggc2VuZGVyOnN0cmluZ1xcbiAgICAgIHJlY2VpdmVyOnN0cmluZ1xcbiAgICAgIGFtb3VudDpkZWNpbWFsXFxuICAgICAgc291cmNlLWNoYWluOnN0cmluZ1xcbiAgICApXFxuICAgIEBkb2MgXFxcIkV2ZW50IGVtaXR0ZWQgb24gcmVjZWlwdCBvZiBjcm9zcy1jaGFpbiB0cmFuc2Zlci5cXFwiXFxuICAgIEBldmVudFxcbiAgKVxcbilcXG5cIn19LFwic2lnbmVyc1wiOltdLFwibWV0YVwiOntcImNyZWF0aW9uVGltZVwiOjAsXCJ0dGxcIjoxNzI4MDAsXCJnYXNMaW1pdFwiOjAsXCJjaGFpbklkXCI6XCJcIixcImdhc1ByaWNlXCI6MCxcInNlbmRlclwiOlwiXCJ9LFwibm9uY2VcIjpcImdlbmVzaXMteGNoYWluXCJ9In0", unsafeFromText "eyJnYXMiOjAsInJlc3VsdCI6eyJzdGF0dXMiOiJzdWNjZXNzIiwiZGF0YSI6IkxvYWRlZCBpbnRlcmZhY2UgZnVuZ2libGUteGNoYWluLXYxLCBoYXNoIGg4OWljM2doejIzUmprMHBITkt0Rk93cnZTczdtYm11cWxvVlhPaGwyR0kifSwicmVxS2V5IjoieW5ucDFYVVNSTjJrMUYwYTZ2dXM3RFp0SDZjcHN6MVhmX0d3V0xnTFhTTSIsImxvZ3MiOiJSUDhnMUJrZnkyQjN1bHE0WWU4amF1VlRZcGpqRXlaLWtydGJ5SVg2STRnIiwibWV0YURhdGEiOm51bGwsImNvbnRpbnVhdGlvbiI6bnVsbCwidHhJZCI6MX0") + , (unsafeFromText "eyJoYXNoIjoiMDVCdGo3ZUJaQlc3by1TYUxvVmhBaWNNVVBaVUJiRzZRVDhfTEFrQ3hIcyIsInNpZ3MiOltdLCJjbWQiOiJ7XCJuZXR3b3JrSWRcIjpudWxsLFwicGF5bG9hZFwiOntcImV4ZWNcIjp7XCJkYXRhXCI6bnVsbCxcImNvZGVcIjpcIihpbnRlcmZhY2UgZnVuZ2libGUtdjJcXG5cXG4gIFxcXCIgU3RhbmRhcmQgZm9yIGZ1bmdpYmxlIGNvaW5zIGFuZCB0b2tlbnMgYXMgc3BlY2lmaWVkIGluIEtJUC0wMDAyLiBcXFwiXFxuXFxuICAgOyAtLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tXFxuICAgOyBTY2hlbWFcXG5cXG4gICAoZGVmc2NoZW1hIGFjY291bnQtZGV0YWlsc1xcbiAgICBAZG9jIFxcXCJTY2hlbWEgZm9yIHJlc3VsdHMgb2YgJ2FjY291bnQnIG9wZXJhdGlvbi5cXFwiXFxuICAgIEBtb2RlbCBbIChpbnZhcmlhbnQgKCE9IFxcXCJcXFwiIHNlbmRlcikpIF1cXG5cXG4gICAgYWNjb3VudDpzdHJpbmdcXG4gICAgYmFsYW5jZTpkZWNpbWFsXFxuICAgIGd1YXJkOmd1YXJkKVxcblxcblxcbiAgIDsgLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLVxcbiAgIDsgQ2Fwc1xcblxcbiAgIChkZWZjYXAgVFJBTlNGRVI6Ym9vbFxcbiAgICAgKCBzZW5kZXI6c3RyaW5nXFxuICAgICAgIHJlY2VpdmVyOnN0cmluZ1xcbiAgICAgICBhbW91bnQ6ZGVjaW1hbFxcbiAgICAgKVxcbiAgICAgQGRvYyBcXFwiIE1hbmFnZWQgY2FwYWJpbGl0eSBzZWFsaW5nIEFNT1VOVCBmb3IgdHJhbnNmZXIgZnJvbSBTRU5ERVIgdG8gXFxcXFxcbiAgICAgICAgICBcXFxcIFJFQ0VJVkVSLiBQZXJtaXRzIGFueSBudW1iZXIgb2YgdHJhbnNmZXJzIHVwIHRvIEFNT1VOVC5cXFwiXFxuICAgICBAbWFuYWdlZCBhbW91bnQgVFJBTlNGRVItbWdyXFxuICAgICApXFxuXFxuICAgKGRlZnVuIFRSQU5TRkVSLW1ncjpkZWNpbWFsXFxuICAgICAoIG1hbmFnZWQ6ZGVjaW1hbFxcbiAgICAgICByZXF1ZXN0ZWQ6ZGVjaW1hbFxcbiAgICAgKVxcbiAgICAgQGRvYyBcXFwiIE1hbmFnZXMgVFJBTlNGRVIgQU1PVU5UIGxpbmVhcmx5LCBcXFxcXFxuICAgICAgICAgIFxcXFwgc3VjaCB0aGF0IGEgcmVxdWVzdCBmb3IgMS4wIGFtb3VudCBvbiBhIDMuMCBcXFxcXFxuICAgICAgICAgIFxcXFwgbWFuYWdlZCBxdWFudGl0eSBlbWl0cyB1cGRhdGVkIGFtb3VudCAyLjAuXFxcIlxcbiAgICAgKVxcblxcbiAgIDsgLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLVxcbiAgIDsgRnVuY3Rpb25hbGl0eVxcblxcblxcbiAgKGRlZnVuIHRyYW5zZmVyOnN0cmluZ1xcbiAgICAoIHNlbmRlcjpzdHJpbmdcXG4gICAgICByZWNlaXZlcjpzdHJpbmdcXG4gICAgICBhbW91bnQ6ZGVjaW1hbFxcbiAgICApXFxuICAgIEBkb2MgXFxcIiBUcmFuc2ZlciBBTU9VTlQgYmV0d2VlbiBhY2NvdW50cyBTRU5ERVIgYW5kIFJFQ0VJVkVSLiBcXFxcXFxuICAgICAgICAgXFxcXCBGYWlscyBpZiBlaXRoZXIgU0VOREVSIG9yIFJFQ0VJVkVSIGRvZXMgbm90IGV4aXN0LlxcXCJcXG4gICAgQG1vZGVsIFsgKHByb3BlcnR5ICg-IGFtb3VudCAwLjApKVxcbiAgICAgICAgICAgICAocHJvcGVydHkgKCE9IHNlbmRlciBcXFwiXFxcIikpXFxuICAgICAgICAgICAgIChwcm9wZXJ0eSAoIT0gcmVjZWl2ZXIgXFxcIlxcXCIpKVxcbiAgICAgICAgICAgICAocHJvcGVydHkgKCE9IHNlbmRlciByZWNlaXZlcikpXFxuICAgICAgICAgICBdXFxuICAgIClcXG5cXG4gICAoZGVmdW4gdHJhbnNmZXItY3JlYXRlOnN0cmluZ1xcbiAgICAgKCBzZW5kZXI6c3RyaW5nXFxuICAgICAgIHJlY2VpdmVyOnN0cmluZ1xcbiAgICAgICByZWNlaXZlci1ndWFyZDpndWFyZFxcbiAgICAgICBhbW91bnQ6ZGVjaW1hbFxcbiAgICAgKVxcbiAgICAgQGRvYyBcXFwiIFRyYW5zZmVyIEFNT1VOVCBiZXR3ZWVuIGFjY291bnRzIFNFTkRFUiBhbmQgUkVDRUlWRVIuIFxcXFxcXG4gICAgICAgICAgXFxcXCBGYWlscyBpZiBTRU5ERVIgZG9lcyBub3QgZXhpc3QuIElmIFJFQ0VJVkVSIGV4aXN0cywgZ3VhcmQgXFxcXFxcbiAgICAgICAgICBcXFxcIG11c3QgbWF0Y2ggZXhpc3RpbmcgdmFsdWUuIElmIFJFQ0VJVkVSIGRvZXMgbm90IGV4aXN0LCBcXFxcXFxuICAgICAgICAgIFxcXFwgUkVDRUlWRVIgYWNjb3VudCBpcyBjcmVhdGVkIHVzaW5nIFJFQ0VJVkVSLUdVQVJELiBcXFxcXFxuICAgICAgICAgIFxcXFwgU3ViamVjdCB0byBtYW5hZ2VtZW50IGJ5IFRSQU5TRkVSIGNhcGFiaWxpdHkuXFxcIlxcbiAgICAgQG1vZGVsIFsgKHByb3BlcnR5ICg-IGFtb3VudCAwLjApKVxcbiAgICAgICAgICAgICAgKHByb3BlcnR5ICghPSBzZW5kZXIgXFxcIlxcXCIpKVxcbiAgICAgICAgICAgICAgKHByb3BlcnR5ICghPSByZWNlaXZlciBcXFwiXFxcIikpXFxuICAgICAgICAgICAgICAocHJvcGVydHkgKCE9IHNlbmRlciByZWNlaXZlcikpXFxuICAgICAgICAgICAgXVxcbiAgICAgKVxcblxcbiAgIChkZWZwYWN0IHRyYW5zZmVyLWNyb3NzY2hhaW46c3RyaW5nXFxuICAgICAoIHNlbmRlcjpzdHJpbmdcXG4gICAgICAgcmVjZWl2ZXI6c3RyaW5nXFxuICAgICAgIHJlY2VpdmVyLWd1YXJkOmd1YXJkXFxuICAgICAgIHRhcmdldC1jaGFpbjpzdHJpbmdcXG4gICAgICAgYW1vdW50OmRlY2ltYWxcXG4gICAgIClcXG4gICAgIEBkb2MgXFxcIiAyLXN0ZXAgcGFjdCB0byB0cmFuc2ZlciBBTU9VTlQgZnJvbSBTRU5ERVIgb24gY3VycmVudCBjaGFpbiBcXFxcXFxuICAgICAgICAgIFxcXFwgdG8gUkVDRUlWRVIgb24gVEFSR0VULUNIQUlOIHZpYSBTUFYgcHJvb2YuIFxcXFxcXG4gICAgICAgICAgXFxcXCBUQVJHRVQtQ0hBSU4gbXVzdCBiZSBkaWZmZXJlbnQgdGhhbiBjdXJyZW50IGNoYWluIGlkLiBcXFxcXFxuICAgICAgICAgIFxcXFwgRmlyc3Qgc3RlcCBkZWJpdHMgQU1PVU5UIGNvaW5zIGluIFNFTkRFUiBhY2NvdW50IGFuZCB5aWVsZHMgXFxcXFxcbiAgICAgICAgICBcXFxcIFJFQ0VJVkVSLCBSRUNFSVZFUl9HVUFSRCBhbmQgQU1PVU5UIHRvIFRBUkdFVC1DSEFJTi4gXFxcXFxcbiAgICAgICAgICBcXFxcIFNlY29uZCBzdGVwIGNvbnRpbnVhdGlvbiBpcyBzZW50IGludG8gVEFSR0VULUNIQUlOIHdpdGggcHJvb2YgXFxcXFxcbiAgICAgICAgICBcXFxcIG9idGFpbmVkIGZyb20gdGhlIHNwdiAnb3V0cHV0JyBlbmRwb2ludCBvZiBDaGFpbndlYi4gXFxcXFxcbiAgICAgICAgICBcXFxcIFByb29mIGlzIHZhbGlkYXRlZCBhbmQgUkVDRUlWRVIgaXMgY3JlZGl0ZWQgd2l0aCBBTU9VTlQgXFxcXFxcbiAgICAgICAgICBcXFxcIGNyZWF0aW5nIGFjY291bnQgd2l0aCBSRUNFSVZFUl9HVUFSRCBhcyBuZWNlc3NhcnkuXFxcIlxcbiAgICAgQG1vZGVsIFsgKHByb3BlcnR5ICg-IGFtb3VudCAwLjApKVxcbiAgICAgICAgICAgICAgKHByb3BlcnR5ICghPSBzZW5kZXIgXFxcIlxcXCIpKVxcbiAgICAgICAgICAgICAgKHByb3BlcnR5ICghPSByZWNlaXZlciBcXFwiXFxcIikpXFxuICAgICAgICAgICAgICAocHJvcGVydHkgKCE9IHNlbmRlciByZWNlaXZlcikpXFxuICAgICAgICAgICAgICAocHJvcGVydHkgKCE9IHRhcmdldC1jaGFpbiBcXFwiXFxcIikpXFxuICAgICAgICAgICAgXVxcbiAgICAgKVxcblxcbiAgIChkZWZ1biBnZXQtYmFsYW5jZTpkZWNpbWFsXFxuICAgICAoIGFjY291bnQ6c3RyaW5nIClcXG4gICAgIFxcXCIgR2V0IGJhbGFuY2UgZm9yIEFDQ09VTlQuIEZhaWxzIGlmIGFjY291bnQgZG9lcyBub3QgZXhpc3QuXFxcIlxcbiAgICAgKVxcblxcbiAgIChkZWZ1biBkZXRhaWxzOm9iamVjdHthY2NvdW50LWRldGFpbHN9XFxuICAgICAoIGFjY291bnQ6IHN0cmluZyApXFxuICAgICBcXFwiIEdldCBhbiBvYmplY3Qgd2l0aCBkZXRhaWxzIG9mIEFDQ09VTlQuIFxcXFxcXG4gICAgIFxcXFwgRmFpbHMgaWYgYWNjb3VudCBkb2VzIG5vdCBleGlzdC5cXFwiXFxuICAgICApXFxuXFxuICAgKGRlZnVuIHByZWNpc2lvbjppbnRlZ2VyXFxuICAgICAoKVxcbiAgICAgXFxcIlJldHVybiB0aGUgbWF4aW11bSBhbGxvd2VkIGRlY2ltYWwgcHJlY2lzaW9uLlxcXCJcXG4gICAgIClcXG5cXG4gICAoZGVmdW4gZW5mb3JjZS11bml0OmJvb2xcXG4gICAgICggYW1vdW50OmRlY2ltYWwgKVxcbiAgICAgXFxcIiBFbmZvcmNlIG1pbmltdW0gcHJlY2lzaW9uIGFsbG93ZWQgZm9yIHRyYW5zYWN0aW9ucy5cXFwiXFxuICAgICApXFxuXFxuICAgKGRlZnVuIGNyZWF0ZS1hY2NvdW50OnN0cmluZ1xcbiAgICAgKCBhY2NvdW50OnN0cmluZ1xcbiAgICAgICBndWFyZDpndWFyZFxcbiAgICAgKVxcbiAgICAgXFxcIiBDcmVhdGUgQUNDT1VOVCB3aXRoIDAuMCBiYWxhbmNlLCB3aXRoIEdVQVJEIGNvbnRyb2xsaW5nIGFjY2Vzcy5cXFwiXFxuICAgICApXFxuXFxuICAgKGRlZnVuIHJvdGF0ZTpzdHJpbmdcXG4gICAgICggYWNjb3VudDpzdHJpbmdcXG4gICAgICAgbmV3LWd1YXJkOmd1YXJkXFxuICAgICApXFxuICAgICBcXFwiIFJvdGF0ZSBndWFyZCBmb3IgQUNDT1VOVC4gVHJhbnNhY3Rpb24gaXMgdmFsaWRhdGVkIGFnYWluc3QgXFxcXFxcbiAgICAgXFxcXCBleGlzdGluZyBndWFyZCBiZWZvcmUgaW5zdGFsbGluZyBuZXcgZ3VhcmQuIFxcXCJcXG4gICAgIClcXG5cXG4pXFxuXCJ9fSxcInNpZ25lcnNcIjpbXSxcIm1ldGFcIjp7XCJjcmVhdGlvblRpbWVcIjowLFwidHRsXCI6MTcyODAwLFwiZ2FzTGltaXRcIjowLFwiY2hhaW5JZFwiOlwiXCIsXCJnYXNQcmljZVwiOjAsXCJzZW5kZXJcIjpcIlwifSxcIm5vbmNlXCI6XCJmdW5naWJsZS1hc3NldC12MlwifSJ9", unsafeFromText "eyJnYXMiOjAsInJlc3VsdCI6eyJzdGF0dXMiOiJzdWNjZXNzIiwiZGF0YSI6IkxvYWRlZCBpbnRlcmZhY2UgZnVuZ2libGUtdjIsIGhhc2ggWXhFLUtnQzZKbUttQ2NnS1RKbWxFbl9JNThJNEVYbWhmcnZ6WDdiZXJZayJ9LCJyZXFLZXkiOiIwNUJ0ajdlQlpCVzdvLVNhTG9WaEFpY01VUFpVQmJHNlFUOF9MQWtDeEhzIiwibG9ncyI6IjFTQmJBNHVzS0E5OFNlX09WRUdkcVk5WjJoSW1jVmcydWpISDJkM1ZmeEkiLCJtZXRhRGF0YSI6bnVsbCwiY29udGludWF0aW9uIjpudWxsLCJ0eElkIjoyfQ") + , (unsafeFromText "eyJoYXNoIjoiR1JJUXU0aEFLazBJRDlGOHpfLTB5WHlBS0ozM01QeVRZTVhPamxQSm1wSSIsInNpZ3MiOltdLCJjbWQiOiJ7XCJuZXR3b3JrSWRcIjpudWxsLFwicGF5bG9hZFwiOntcImV4ZWNcIjp7XCJkYXRhXCI6bnVsbCxcImNvZGVcIjpcIlxcbihtb2R1bGUgY29pbiBHT1ZFUk5BTkNFXFxuXFxuICBAZG9jIFxcXCInY29pbicgcmVwcmVzZW50cyB0aGUgS2FkZW5hIENvaW4gQ29udHJhY3QuIFRoaXMgY29udHJhY3QgcHJvdmlkZXMgYm90aCB0aGUgXFxcXFxcbiAgXFxcXGJ1eS9yZWRlZW0gZ2FzIHN1cHBvcnQgaW4gdGhlIGZvcm0gb2YgJ2Z1bmQtdHgnLCBhcyB3ZWxsIGFzIHRyYW5zZmVyLCAgICAgICBcXFxcXFxuICBcXFxcY3JlZGl0LCBkZWJpdCwgY29pbmJhc2UsIGFjY291bnQgY3JlYXRpb24gYW5kIHF1ZXJ5LCBhcyB3ZWxsIGFzIFNQViBidXJuICAgIFxcXFxcXG4gIFxcXFxjcmVhdGUuIFRvIGFjY2VzcyB0aGUgY29pbiBjb250cmFjdCwgeW91IG1heSB1c2UgaXRzIGZ1bGx5LXF1YWxpZmllZCBuYW1lLCAgXFxcXFxcbiAgXFxcXG9yIGlzc3VlIHRoZSAnKHVzZSBjb2luKScgY29tbWFuZCBpbiB0aGUgYm9keSBvZiBhIG1vZHVsZSBkZWNsYXJhdGlvbi5cXFwiXFxuXFxuICBAbW9kZWxcXG4gICAgWyAoZGVmcHJvcGVydHkgY29uc2VydmVzLW1hc3NcXG4gICAgICAgICg9IChjb2x1bW4tZGVsdGEgY29pbi10YWJsZSAnYmFsYW5jZSkgMC4wKSlcXG5cXG4gICAgICAoZGVmcHJvcGVydHkgdmFsaWQtYWNjb3VudCAoYWNjb3VudDpzdHJpbmcpXFxuICAgICAgICAoYW5kXFxuICAgICAgICAgICg-PSAobGVuZ3RoIGFjY291bnQpIDMpXFxuICAgICAgICAgICg8PSAobGVuZ3RoIGFjY291bnQpIDI1NikpKVxcbiAgICBdXFxuXFxuICAoaW1wbGVtZW50cyBmdW5naWJsZS12MilcXG4gIChpbXBsZW1lbnRzIGZ1bmdpYmxlLXhjaGFpbi12MSlcXG5cXG4gIDs7IGNvaW4tdjJcXG4gIChibGVzcyBcXFwidXRfSl9aTmtveWFQVUVKaGl3VmVXbmtTUW45SlQ5c1FDV0tkampWVnJXb1xcXCIpXFxuXFxuICA7OyBjb2luIHYzXFxuICAoYmxlc3MgXFxcIjFvc19zTEFVWXZCenNwbjVqamF3dFJwSldpSDFXUGZoeU5yYWVWdlNJd1VcXFwiKVxcblxcbiAgOzsgY29pbiB2NFxcbiAgKGJsZXNzIFxcXCJCalpXMFQyYWM2cUVfSTVYOEdFNGZhbDZ0VHFqaExUQzdteTB5dFFTeExVXFxcIilcXG5cXG4gIDs7IGNvaW4gdjVcXG4gIChibGVzcyBcXFwickU3RFU4amxRTDl4X01QWXVuaVpKZjVJQ0JUQUVIQUlGUUNCNGJsb2ZQNFxcXCIpXFxuXFxuICA7IC0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tXFxuICA7IFNjaGVtYXMgYW5kIFRhYmxlc1xcblxcbiAgKGRlZnNjaGVtYSBjb2luLXNjaGVtYVxcbiAgICBAZG9jIFxcXCJUaGUgY29pbiBjb250cmFjdCB0b2tlbiBzY2hlbWFcXFwiXFxuICAgIEBtb2RlbCBbIChpbnZhcmlhbnQgKD49IGJhbGFuY2UgMC4wKSkgXVxcblxcbiAgICBiYWxhbmNlOmRlY2ltYWxcXG4gICAgZ3VhcmQ6Z3VhcmQpXFxuXFxuICAoZGVmdGFibGUgY29pbi10YWJsZTp7Y29pbi1zY2hlbWF9KVxcblxcbiAgOyAtLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLVxcbiAgOyBDYXBhYmlsaXRpZXNcXG5cXG4gIChkZWZjYXAgR09WRVJOQU5DRSAoKVxcbiAgICAoZW5mb3JjZSBmYWxzZSBcXFwiRW5mb3JjZSBub24tdXBncmFkZWFiaWxpdHlcXFwiKSlcXG5cXG4gIChkZWZjYXAgR0FTICgpXFxuICAgIFxcXCJNYWdpYyBjYXBhYmlsaXR5IHRvIHByb3RlY3QgZ2FzIGJ1eSBhbmQgcmVkZWVtXFxcIlxcbiAgICB0cnVlKVxcblxcbiAgKGRlZmNhcCBDT0lOQkFTRSAoKVxcbiAgICBcXFwiTWFnaWMgY2FwYWJpbGl0eSB0byBwcm90ZWN0IG1pbmVyIHJld2FyZFxcXCJcXG4gICAgdHJ1ZSlcXG5cXG4gIChkZWZjYXAgR0VORVNJUyAoKVxcbiAgICBcXFwiTWFnaWMgY2FwYWJpbGl0eSBjb25zdHJhaW5pbmcgZ2VuZXNpcyB0cmFuc2FjdGlvbnNcXFwiXFxuICAgIHRydWUpXFxuXFxuICAoZGVmY2FwIFJFTUVESUFURSAoKVxcbiAgICBcXFwiTWFnaWMgY2FwYWJpbGl0eSBmb3IgcmVtZWRpYXRpb24gdHJhbnNhY3Rpb25zXFxcIlxcbiAgICB0cnVlKVxcblxcbiAgKGRlZmNhcCBERUJJVCAoc2VuZGVyOnN0cmluZylcXG4gICAgXFxcIkNhcGFiaWxpdHkgZm9yIG1hbmFnaW5nIGRlYml0aW5nIG9wZXJhdGlvbnNcXFwiXFxuICAgIChlbmZvcmNlLWd1YXJkIChhdCAnZ3VhcmQgKHJlYWQgY29pbi10YWJsZSBzZW5kZXIpKSlcXG4gICAgKGVuZm9yY2UgKCE9IHNlbmRlciBcXFwiXFxcIikgXFxcInZhbGlkIHNlbmRlclxcXCIpKVxcblxcbiAgKGRlZmNhcCBDUkVESVQgKHJlY2VpdmVyOnN0cmluZylcXG4gICAgXFxcIkNhcGFiaWxpdHkgZm9yIG1hbmFnaW5nIGNyZWRpdGluZyBvcGVyYXRpb25zXFxcIlxcbiAgICAoZW5mb3JjZSAoIT0gcmVjZWl2ZXIgXFxcIlxcXCIpIFxcXCJ2YWxpZCByZWNlaXZlclxcXCIpKVxcblxcbiAgKGRlZmNhcCBST1RBVEUgKGFjY291bnQ6c3RyaW5nKVxcbiAgICBAZG9jIFxcXCJBdXRvbm9tb3VzbHkgbWFuYWdlZCBjYXBhYmlsaXR5IGZvciBndWFyZCByb3RhdGlvblxcXCJcXG4gICAgQG1hbmFnZWRcXG4gICAgdHJ1ZSlcXG5cXG4gIChkZWZjYXAgVFJBTlNGRVI6Ym9vbFxcbiAgICAoIHNlbmRlcjpzdHJpbmdcXG4gICAgICByZWNlaXZlcjpzdHJpbmdcXG4gICAgICBhbW91bnQ6ZGVjaW1hbFxcbiAgICApXFxuICAgIEBtYW5hZ2VkIGFtb3VudCBUUkFOU0ZFUi1tZ3JcXG4gICAgKGVuZm9yY2UgKCE9IHNlbmRlciByZWNlaXZlcikgXFxcInNhbWUgc2VuZGVyIGFuZCByZWNlaXZlclxcXCIpXFxuICAgIChlbmZvcmNlLXVuaXQgYW1vdW50KVxcbiAgICAoZW5mb3JjZSAoPiBhbW91bnQgMC4wKSBcXFwiUG9zaXRpdmUgYW1vdW50XFxcIilcXG4gICAgKGNvbXBvc2UtY2FwYWJpbGl0eSAoREVCSVQgc2VuZGVyKSlcXG4gICAgKGNvbXBvc2UtY2FwYWJpbGl0eSAoQ1JFRElUIHJlY2VpdmVyKSlcXG4gIClcXG5cXG4gIChkZWZ1biBUUkFOU0ZFUi1tZ3I6ZGVjaW1hbFxcbiAgICAoIG1hbmFnZWQ6ZGVjaW1hbFxcbiAgICAgIHJlcXVlc3RlZDpkZWNpbWFsXFxuICAgIClcXG5cXG4gICAgKGxldCAoKG5ld2JhbCAoLSBtYW5hZ2VkIHJlcXVlc3RlZCkpKVxcbiAgICAgIChlbmZvcmNlICg-PSBuZXdiYWwgMC4wKVxcbiAgICAgICAgKGZvcm1hdCBcXFwiVFJBTlNGRVIgZXhjZWVkZWQgZm9yIGJhbGFuY2Uge31cXFwiIFttYW5hZ2VkXSkpXFxuICAgICAgbmV3YmFsKVxcbiAgKVxcblxcbiAgKGRlZmNhcCBUUkFOU0ZFUl9YQ0hBSU46Ym9vbFxcbiAgICAoIHNlbmRlcjpzdHJpbmdcXG4gICAgICByZWNlaXZlcjpzdHJpbmdcXG4gICAgICBhbW91bnQ6ZGVjaW1hbFxcbiAgICAgIHRhcmdldC1jaGFpbjpzdHJpbmdcXG4gICAgKVxcblxcbiAgICBAbWFuYWdlZCBhbW91bnQgVFJBTlNGRVJfWENIQUlOLW1nclxcbiAgICAoZW5mb3JjZS11bml0IGFtb3VudClcXG4gICAgKGVuZm9yY2UgKD4gYW1vdW50IDAuMCkgXFxcIkNyb3NzLWNoYWluIHRyYW5zZmVycyByZXF1aXJlIGEgcG9zaXRpdmUgYW1vdW50XFxcIilcXG4gICAgKGNvbXBvc2UtY2FwYWJpbGl0eSAoREVCSVQgc2VuZGVyKSlcXG4gIClcXG5cXG4gIChkZWZ1biBUUkFOU0ZFUl9YQ0hBSU4tbWdyOmRlY2ltYWxcXG4gICAgKCBtYW5hZ2VkOmRlY2ltYWxcXG4gICAgICByZXF1ZXN0ZWQ6ZGVjaW1hbFxcbiAgICApXFxuXFxuICAgIChlbmZvcmNlICg-PSBtYW5hZ2VkIHJlcXVlc3RlZClcXG4gICAgICAoZm9ybWF0IFxcXCJUUkFOU0ZFUl9YQ0hBSU4gZXhjZWVkZWQgZm9yIGJhbGFuY2Uge31cXFwiIFttYW5hZ2VkXSkpXFxuICAgIDAuMFxcbiAgKVxcblxcbiAgKGRlZmNhcCBUUkFOU0ZFUl9YQ0hBSU5fUkVDRDpib29sXFxuICAgICggc2VuZGVyOnN0cmluZ1xcbiAgICAgIHJlY2VpdmVyOnN0cmluZ1xcbiAgICAgIGFtb3VudDpkZWNpbWFsXFxuICAgICAgc291cmNlLWNoYWluOnN0cmluZ1xcbiAgICApXFxuICAgIEBldmVudCB0cnVlXFxuICApXFxuXFxuICA7IHYzIGNhcGFiaWxpdGllc1xcbiAgKGRlZmNhcCBSRUxFQVNFX0FMTE9DQVRJT05cXG4gICAgKCBhY2NvdW50OnN0cmluZ1xcbiAgICAgIGFtb3VudDpkZWNpbWFsXFxuICAgIClcXG4gICAgQGRvYyBcXFwiRXZlbnQgZm9yIGFsbG9jYXRpb24gcmVsZWFzZSwgY2FuIGJlIHVzZWQgZm9yIHNpZyBzY29waW5nLlxcXCJcXG4gICAgQGV2ZW50IHRydWVcXG4gIClcXG5cXG4gIDsgLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS1cXG4gIDsgQ29uc3RhbnRzXFxuXFxuICAoZGVmY29uc3QgQ09JTl9DSEFSU0VUIENIQVJTRVRfTEFUSU4xXFxuICAgIFxcXCJUaGUgZGVmYXVsdCBjb2luIGNvbnRyYWN0IGNoYXJhY3RlciBzZXRcXFwiKVxcblxcbiAgKGRlZmNvbnN0IE1JTklNVU1fUFJFQ0lTSU9OIDEyXFxuICAgIFxcXCJNaW5pbXVtIGFsbG93ZWQgcHJlY2lzaW9uIGZvciBjb2luIHRyYW5zYWN0aW9uc1xcXCIpXFxuXFxuICAoZGVmY29uc3QgTUlOSU1VTV9BQ0NPVU5UX0xFTkdUSCAzXFxuICAgIFxcXCJNaW5pbXVtIGFjY291bnQgbGVuZ3RoIGFkbWlzc2libGUgZm9yIGNvaW4gYWNjb3VudHNcXFwiKVxcblxcbiAgKGRlZmNvbnN0IE1BWElNVU1fQUNDT1VOVF9MRU5HVEggMjU2XFxuICAgIFxcXCJNYXhpbXVtIGFjY291bnQgbmFtZSBsZW5ndGggYWRtaXNzaWJsZSBmb3IgY29pbiBhY2NvdW50c1xcXCIpXFxuXFxuICAoZGVmY29uc3QgVkFMSURfQ0hBSU5fSURTIChtYXAgKGludC10by1zdHIgMTApIChlbnVtZXJhdGUgMCAxOSkpXFxuICAgIFxcXCJMaXN0IG9mIGFsbCB2YWxpZCBDaGFpbndlYiBjaGFpbiBpZHNcXFwiKVxcblxcbiAgOyAtLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLVxcbiAgOyBVdGlsaXRpZXNcXG5cXG4gIChkZWZ1biBlbmZvcmNlLXVuaXQ6Ym9vbCAoYW1vdW50OmRlY2ltYWwpXFxuICAgIEBkb2MgXFxcIkVuZm9yY2UgbWluaW11bSBwcmVjaXNpb24gYWxsb3dlZCBmb3IgY29pbiB0cmFuc2FjdGlvbnNcXFwiXFxuXFxuICAgIChlbmZvcmNlXFxuICAgICAgKD0gKGZsb29yIGFtb3VudCBNSU5JTVVNX1BSRUNJU0lPTilcXG4gICAgICAgICBhbW91bnQpXFxuICAgICAgKGZvcm1hdCBcXFwiQW1vdW50IHZpb2xhdGVzIG1pbmltdW0gcHJlY2lzaW9uOiB7fVxcXCIgW2Ftb3VudF0pKVxcbiAgICApXFxuXFxuICAoZGVmdW4gdmFsaWRhdGUtYWNjb3VudCAoYWNjb3VudDpzdHJpbmcpXFxuICAgIEBkb2MgXFxcIkVuZm9yY2UgdGhhdCBhbiBhY2NvdW50IG5hbWUgY29uZm9ybXMgdG8gdGhlIGNvaW4gY29udHJhY3QgXFxcXFxcbiAgICAgICAgIFxcXFxtaW5pbXVtIGFuZCBtYXhpbXVtIGxlbmd0aCByZXF1aXJlbWVudHMsIGFzIHdlbGwgYXMgdGhlICAgIFxcXFxcXG4gICAgICAgICBcXFxcbGF0aW4tMSBjaGFyYWN0ZXIgc2V0LlxcXCJcXG5cXG4gICAgKGVuZm9yY2VcXG4gICAgICAoaXMtY2hhcnNldCBDT0lOX0NIQVJTRVQgYWNjb3VudClcXG4gICAgICAoZm9ybWF0XFxuICAgICAgICBcXFwiQWNjb3VudCBkb2VzIG5vdCBjb25mb3JtIHRvIHRoZSBjb2luIGNvbnRyYWN0IGNoYXJzZXQ6IHt9XFxcIlxcbiAgICAgICAgW2FjY291bnRdKSlcXG5cXG4gICAgKGxldCAoKGFjY291bnQtbGVuZ3RoIChsZW5ndGggYWNjb3VudCkpKVxcblxcbiAgICAgIChlbmZvcmNlXFxuICAgICAgICAoPj0gYWNjb3VudC1sZW5ndGggTUlOSU1VTV9BQ0NPVU5UX0xFTkdUSClcXG4gICAgICAgIChmb3JtYXRcXG4gICAgICAgICAgXFxcIkFjY291bnQgbmFtZSBkb2VzIG5vdCBjb25mb3JtIHRvIHRoZSBtaW4gbGVuZ3RoIHJlcXVpcmVtZW50OiB7fVxcXCJcXG4gICAgICAgICAgW2FjY291bnRdKSlcXG5cXG4gICAgICAoZW5mb3JjZVxcbiAgICAgICAgKDw9IGFjY291bnQtbGVuZ3RoIE1BWElNVU1fQUNDT1VOVF9MRU5HVEgpXFxuICAgICAgICAoZm9ybWF0XFxuICAgICAgICAgIFxcXCJBY2NvdW50IG5hbWUgZG9lcyBub3QgY29uZm9ybSB0byB0aGUgbWF4IGxlbmd0aCByZXF1aXJlbWVudDoge31cXFwiXFxuICAgICAgICAgIFthY2NvdW50XSkpXFxuICAgICAgKVxcbiAgKVxcblxcbiAgOyAtLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLVxcbiAgOyBDb2luIENvbnRyYWN0XFxuXFxuICAoZGVmdW4gZ2FzLW9ubHkgKClcXG4gICAgXFxcIlByZWRpY2F0ZSBmb3IgZ2FzLW9ubHkgdXNlciBndWFyZHMuXFxcIlxcbiAgICAocmVxdWlyZS1jYXBhYmlsaXR5IChHQVMpKSlcXG5cXG4gIChkZWZ1biBnYXMtZ3VhcmQgKGd1YXJkOmd1YXJkKVxcbiAgICBcXFwiUHJlZGljYXRlIGZvciBnYXMgKyBzaW5nbGUga2V5IHVzZXIgZ3VhcmRzXFxcIlxcbiAgICAoZW5mb3JjZS1vbmVcXG4gICAgICBcXFwiRW5mb3JjZSBlaXRoZXIgdGhlIHByZXNlbmNlIG9mIGEgR0FTIGNhcCBvciBrZXlzZXRcXFwiXFxuICAgICAgWyAoZ2FzLW9ubHkpXFxuICAgICAgICAoZW5mb3JjZS1ndWFyZCBndWFyZClcXG4gICAgICBdKSlcXG5cXG4gIChkZWZ1biBidXktZ2FzOnN0cmluZyAoc2VuZGVyOnN0cmluZyB0b3RhbDpkZWNpbWFsKVxcbiAgICBAZG9jIFxcXCJUaGlzIGZ1bmN0aW9uIGRlc2NyaWJlcyB0aGUgbWFpbiAnZ2FzIGJ1eScgb3BlcmF0aW9uLiBBdCB0aGlzIHBvaW50IFxcXFxcXG4gICAgXFxcXE1JTkVSIGhhcyBiZWVuIGNob3NlbiBmcm9tIHRoZSBwb29sLCBhbmQgd2lsbCBiZSB2YWxpZGF0ZWQuIFRoZSBTRU5ERVIgICBcXFxcXFxuICAgIFxcXFxvZiB0aGlzIHRyYW5zYWN0aW9uIGhhcyBzcGVjaWZpZWQgYSBnYXMgbGltaXQgTElNSVQgKG1heGltdW0gZ2FzKSBmb3IgICAgXFxcXFxcbiAgICBcXFxcdGhlIHRyYW5zYWN0aW9uLCBhbmQgdGhlIHByaWNlIGlzIHRoZSBzcG90IHByaWNlIG9mIGdhcyBhdCB0aGF0IHRpbWUuICAgIFxcXFxcXG4gICAgXFxcXFRoZSBnYXMgYnV5IHdpbGwgYmUgZXhlY3V0ZWQgcHJpb3IgdG8gZXhlY3V0aW5nIFNFTkRFUidzIGNvZGUuXFxcIlxcblxcbiAgICBAbW9kZWwgWyAocHJvcGVydHkgKD4gdG90YWwgMC4wKSlcXG4gICAgICAgICAgICAgKHByb3BlcnR5ICh2YWxpZC1hY2NvdW50IHNlbmRlcikpXFxuICAgICAgICAgICBdXFxuXFxuICAgICh2YWxpZGF0ZS1hY2NvdW50IHNlbmRlcilcXG5cXG4gICAgKGVuZm9yY2UtdW5pdCB0b3RhbClcXG4gICAgKGVuZm9yY2UgKD4gdG90YWwgMC4wKSBcXFwiZ2FzIHN1cHBseSBtdXN0IGJlIGEgcG9zaXRpdmUgcXVhbnRpdHlcXFwiKVxcblxcbiAgICAocmVxdWlyZS1jYXBhYmlsaXR5IChHQVMpKVxcbiAgICAod2l0aC1jYXBhYmlsaXR5IChERUJJVCBzZW5kZXIpXFxuICAgICAgKGRlYml0IHNlbmRlciB0b3RhbCkpXFxuICAgIClcXG5cXG4gIChkZWZ1biByZWRlZW0tZ2FzOnN0cmluZyAobWluZXI6c3RyaW5nIG1pbmVyLWd1YXJkOmd1YXJkIHNlbmRlcjpzdHJpbmcgdG90YWw6ZGVjaW1hbClcXG4gICAgQGRvYyBcXFwiVGhpcyBmdW5jdGlvbiBkZXNjcmliZXMgdGhlIG1haW4gJ3JlZGVlbSBnYXMnIG9wZXJhdGlvbi4gQXQgdGhpcyAgICBcXFxcXFxuICAgIFxcXFxwb2ludCwgdGhlIFNFTkRFUidzIHRyYW5zYWN0aW9uIGhhcyBiZWVuIGV4ZWN1dGVkLCBhbmQgdGhlIGdhcyB0aGF0ICAgICAgXFxcXFxcbiAgICBcXFxcd2FzIGNoYXJnZWQgaGFzIGJlZW4gY2FsY3VsYXRlZC4gTUlORVIgd2lsbCBiZSBjcmVkaXRlZCB0aGUgZ2FzIGNvc3QsICAgIFxcXFxcXG4gICAgXFxcXGFuZCBTRU5ERVIgd2lsbCByZWNlaXZlIHRoZSByZW1haW5kZXIgdXAgdG8gdGhlIGxpbWl0XFxcIlxcblxcbiAgICBAbW9kZWwgWyAocHJvcGVydHkgKD4gdG90YWwgMC4wKSlcXG4gICAgICAgICAgICAgKHByb3BlcnR5ICh2YWxpZC1hY2NvdW50IHNlbmRlcikpXFxuICAgICAgICAgICAgIChwcm9wZXJ0eSAodmFsaWQtYWNjb3VudCBtaW5lcikpXFxuICAgICAgICAgICBdXFxuXFxuICAgICh2YWxpZGF0ZS1hY2NvdW50IHNlbmRlcilcXG4gICAgKHZhbGlkYXRlLWFjY291bnQgbWluZXIpXFxuICAgIChlbmZvcmNlLXVuaXQgdG90YWwpXFxuXFxuICAgIChyZXF1aXJlLWNhcGFiaWxpdHkgKEdBUykpXFxuICAgIChsZXQqXFxuICAgICAgKChmZWUgKHJlYWQtZGVjaW1hbCBcXFwiZmVlXFxcIikpXFxuICAgICAgIChyZWZ1bmQgKC0gdG90YWwgZmVlKSkpXFxuXFxuICAgICAgKGVuZm9yY2UtdW5pdCBmZWUpXFxuICAgICAgKGVuZm9yY2UgKD49IGZlZSAwLjApXFxuICAgICAgICBcXFwiZmVlIG11c3QgYmUgYSBub24tbmVnYXRpdmUgcXVhbnRpdHlcXFwiKVxcblxcbiAgICAgIChlbmZvcmNlICg-PSByZWZ1bmQgMC4wKVxcbiAgICAgICAgXFxcInJlZnVuZCBtdXN0IGJlIGEgbm9uLW5lZ2F0aXZlIHF1YW50aXR5XFxcIilcXG5cXG4gICAgICAoZW1pdC1ldmVudCAoVFJBTlNGRVIgc2VuZGVyIG1pbmVyIGZlZSkpIDt2M1xcblxcbiAgICAgICAgOyBkaXJlY3RseSB1cGRhdGUgaW5zdGVhZCBvZiBjcmVkaXRcXG4gICAgICAod2l0aC1jYXBhYmlsaXR5IChDUkVESVQgc2VuZGVyKVxcbiAgICAgICAgKGlmICg-IHJlZnVuZCAwLjApXFxuICAgICAgICAgICh3aXRoLXJlYWQgY29pbi10YWJsZSBzZW5kZXJcXG4gICAgICAgICAgICB7IFxcXCJiYWxhbmNlXFxcIiA6PSBiYWxhbmNlIH1cXG4gICAgICAgICAgICAodXBkYXRlIGNvaW4tdGFibGUgc2VuZGVyXFxuICAgICAgICAgICAgICB7IFxcXCJiYWxhbmNlXFxcIjogKCsgYmFsYW5jZSByZWZ1bmQpIH0pKVxcblxcbiAgICAgICAgICBcXFwibm9vcFxcXCIpKVxcblxcbiAgICAgICh3aXRoLWNhcGFiaWxpdHkgKENSRURJVCBtaW5lcilcXG4gICAgICAgIChpZiAoPiBmZWUgMC4wKVxcbiAgICAgICAgICAoY3JlZGl0IG1pbmVyIG1pbmVyLWd1YXJkIGZlZSlcXG4gICAgICAgICAgXFxcIm5vb3BcXFwiKSlcXG4gICAgICApXFxuXFxuICAgIClcXG5cXG4gIChkZWZ1biBjcmVhdGUtYWNjb3VudDpzdHJpbmcgKGFjY291bnQ6c3RyaW5nIGd1YXJkOmd1YXJkKVxcbiAgICBAbW9kZWwgWyAocHJvcGVydHkgKHZhbGlkLWFjY291bnQgYWNjb3VudCkpIF1cXG5cXG4gICAgKHZhbGlkYXRlLWFjY291bnQgYWNjb3VudClcXG4gICAgKGVuZm9yY2UtcmVzZXJ2ZWQgYWNjb3VudCBndWFyZClcXG5cXG4gICAgKGluc2VydCBjb2luLXRhYmxlIGFjY291bnRcXG4gICAgICB7IFxcXCJiYWxhbmNlXFxcIiA6IDAuMFxcbiAgICAgICwgXFxcImd1YXJkXFxcIiAgIDogZ3VhcmRcXG4gICAgICB9KVxcbiAgICApXFxuXFxuICAoZGVmdW4gZ2V0LWJhbGFuY2U6ZGVjaW1hbCAoYWNjb3VudDpzdHJpbmcpXFxuICAgICh3aXRoLXJlYWQgY29pbi10YWJsZSBhY2NvdW50XFxuICAgICAgeyBcXFwiYmFsYW5jZVxcXCIgOj0gYmFsYW5jZSB9XFxuICAgICAgYmFsYW5jZVxcbiAgICAgIClcXG4gICAgKVxcblxcbiAgKGRlZnVuIGRldGFpbHM6b2JqZWN0e2Z1bmdpYmxlLXYyLmFjY291bnQtZGV0YWlsc31cXG4gICAgKCBhY2NvdW50OnN0cmluZyApXFxuICAgICh3aXRoLXJlYWQgY29pbi10YWJsZSBhY2NvdW50XFxuICAgICAgeyBcXFwiYmFsYW5jZVxcXCIgOj0gYmFsXFxuICAgICAgLCBcXFwiZ3VhcmRcXFwiIDo9IGcgfVxcbiAgICAgIHsgXFxcImFjY291bnRcXFwiIDogYWNjb3VudFxcbiAgICAgICwgXFxcImJhbGFuY2VcXFwiIDogYmFsXFxuICAgICAgLCBcXFwiZ3VhcmRcXFwiOiBnIH0pXFxuICAgIClcXG5cXG4gIChkZWZ1biByb3RhdGU6c3RyaW5nIChhY2NvdW50OnN0cmluZyBuZXctZ3VhcmQ6Z3VhcmQpXFxuICAgICh3aXRoLWNhcGFiaWxpdHkgKFJPVEFURSBhY2NvdW50KVxcblxcbiAgICAgIDsgQWxsb3cgcm90YXRpb24gb25seSBmb3IgdmFuaXR5IGFjY291bnRzLCBvclxcbiAgICAgIDsgcmUtcm90YXRpbmcgYSBwcmluY2lwYWwgYWNjb3VudCBiYWNrIHRvIGl0cyBwcm9wZXIgZ3VhcmRcXG4gICAgICAoZW5mb3JjZSAob3IgKG5vdCAoaXMtcHJpbmNpcGFsIGFjY291bnQpKVxcbiAgICAgICAgICAgICAgICAgICh2YWxpZGF0ZS1wcmluY2lwYWwgbmV3LWd1YXJkIGFjY291bnQpKVxcbiAgICAgICAgXFxcIkl0IGlzIHVuc2FmZSBmb3IgcHJpbmNpcGFsIGFjY291bnRzIHRvIHJvdGF0ZSB0aGVpciBndWFyZFxcXCIpXFxuXFxuICAgICAgKHdpdGgtcmVhZCBjb2luLXRhYmxlIGFjY291bnRcXG4gICAgICAgIHsgXFxcImd1YXJkXFxcIiA6PSBvbGQtZ3VhcmQgfVxcbiAgICAgICAgKGVuZm9yY2UtZ3VhcmQgb2xkLWd1YXJkKVxcbiAgICAgICAgKHVwZGF0ZSBjb2luLXRhYmxlIGFjY291bnRcXG4gICAgICAgICAgeyBcXFwiZ3VhcmRcXFwiIDogbmV3LWd1YXJkIH1cXG4gICAgICAgICAgKSkpXFxuICAgIClcXG5cXG5cXG4gIChkZWZ1biBwcmVjaXNpb246aW50ZWdlclxcbiAgICAoKVxcbiAgICBNSU5JTVVNX1BSRUNJU0lPTilcXG5cXG4gIChkZWZ1biB0cmFuc2ZlcjpzdHJpbmcgKHNlbmRlcjpzdHJpbmcgcmVjZWl2ZXI6c3RyaW5nIGFtb3VudDpkZWNpbWFsKVxcbiAgICBAbW9kZWwgWyAocHJvcGVydHkgY29uc2VydmVzLW1hc3MpXFxuICAgICAgICAgICAgIChwcm9wZXJ0eSAoPiBhbW91bnQgMC4wKSlcXG4gICAgICAgICAgICAgKHByb3BlcnR5ICh2YWxpZC1hY2NvdW50IHNlbmRlcikpXFxuICAgICAgICAgICAgIChwcm9wZXJ0eSAodmFsaWQtYWNjb3VudCByZWNlaXZlcikpXFxuICAgICAgICAgICAgIChwcm9wZXJ0eSAoIT0gc2VuZGVyIHJlY2VpdmVyKSkgXVxcblxcbiAgICAoZW5mb3JjZSAoIT0gc2VuZGVyIHJlY2VpdmVyKVxcbiAgICAgIFxcXCJzZW5kZXIgY2Fubm90IGJlIHRoZSByZWNlaXZlciBvZiBhIHRyYW5zZmVyXFxcIilcXG5cXG4gICAgKHZhbGlkYXRlLWFjY291bnQgc2VuZGVyKVxcbiAgICAodmFsaWRhdGUtYWNjb3VudCByZWNlaXZlcilcXG5cXG4gICAgKGVuZm9yY2UgKD4gYW1vdW50IDAuMClcXG4gICAgICBcXFwidHJhbnNmZXIgYW1vdW50IG11c3QgYmUgcG9zaXRpdmVcXFwiKVxcblxcbiAgICAoZW5mb3JjZS11bml0IGFtb3VudClcXG5cXG4gICAgKHdpdGgtY2FwYWJpbGl0eSAoVFJBTlNGRVIgc2VuZGVyIHJlY2VpdmVyIGFtb3VudClcXG4gICAgICAoZGViaXQgc2VuZGVyIGFtb3VudClcXG4gICAgICAod2l0aC1yZWFkIGNvaW4tdGFibGUgcmVjZWl2ZXJcXG4gICAgICAgIHsgXFxcImd1YXJkXFxcIiA6PSBnIH1cXG5cXG4gICAgICAgIChjcmVkaXQgcmVjZWl2ZXIgZyBhbW91bnQpKVxcbiAgICAgIClcXG4gICAgKVxcblxcbiAgKGRlZnVuIHRyYW5zZmVyLWNyZWF0ZTpzdHJpbmdcXG4gICAgKCBzZW5kZXI6c3RyaW5nXFxuICAgICAgcmVjZWl2ZXI6c3RyaW5nXFxuICAgICAgcmVjZWl2ZXItZ3VhcmQ6Z3VhcmRcXG4gICAgICBhbW91bnQ6ZGVjaW1hbCApXFxuXFxuICAgIEBtb2RlbCBbIChwcm9wZXJ0eSBjb25zZXJ2ZXMtbWFzcykgXVxcblxcbiAgICAoZW5mb3JjZSAoIT0gc2VuZGVyIHJlY2VpdmVyKVxcbiAgICAgIFxcXCJzZW5kZXIgY2Fubm90IGJlIHRoZSByZWNlaXZlciBvZiBhIHRyYW5zZmVyXFxcIilcXG5cXG4gICAgKHZhbGlkYXRlLWFjY291bnQgc2VuZGVyKVxcbiAgICAodmFsaWRhdGUtYWNjb3VudCByZWNlaXZlcilcXG5cXG4gICAgKGVuZm9yY2UgKD4gYW1vdW50IDAuMClcXG4gICAgICBcXFwidHJhbnNmZXIgYW1vdW50IG11c3QgYmUgcG9zaXRpdmVcXFwiKVxcblxcbiAgICAoZW5mb3JjZS11bml0IGFtb3VudClcXG5cXG4gICAgKHdpdGgtY2FwYWJpbGl0eSAoVFJBTlNGRVIgc2VuZGVyIHJlY2VpdmVyIGFtb3VudClcXG4gICAgICAoZGViaXQgc2VuZGVyIGFtb3VudClcXG4gICAgICAoY3JlZGl0IHJlY2VpdmVyIHJlY2VpdmVyLWd1YXJkIGFtb3VudCkpXFxuICAgIClcXG5cXG4gIChkZWZ1biBjb2luYmFzZTpzdHJpbmcgKGFjY291bnQ6c3RyaW5nIGFjY291bnQtZ3VhcmQ6Z3VhcmQgYW1vdW50OmRlY2ltYWwpXFxuICAgIEBkb2MgXFxcIkludGVybmFsIGZ1bmN0aW9uIGZvciB0aGUgaW5pdGlhbCBjcmVhdGlvbiBvZiBjb2lucy4gIFRoaXMgZnVuY3Rpb24gXFxcXFxcbiAgICBcXFxcY2Fubm90IGJlIHVzZWQgb3V0c2lkZSBvZiB0aGUgY29pbiBjb250cmFjdC5cXFwiXFxuXFxuICAgIEBtb2RlbCBbIChwcm9wZXJ0eSAodmFsaWQtYWNjb3VudCBhY2NvdW50KSlcXG4gICAgICAgICAgICAgKHByb3BlcnR5ICg-IGFtb3VudCAwLjApKVxcbiAgICAgICAgICAgXVxcblxcbiAgICAodmFsaWRhdGUtYWNjb3VudCBhY2NvdW50KVxcbiAgICAoZW5mb3JjZS11bml0IGFtb3VudClcXG5cXG4gICAgKHJlcXVpcmUtY2FwYWJpbGl0eSAoQ09JTkJBU0UpKVxcbiAgICAoZW1pdC1ldmVudCAoVFJBTlNGRVIgXFxcIlxcXCIgYWNjb3VudCBhbW91bnQpKSA7djNcXG4gICAgKHdpdGgtY2FwYWJpbGl0eSAoQ1JFRElUIGFjY291bnQpXFxuICAgICAgKGNyZWRpdCBhY2NvdW50IGFjY291bnQtZ3VhcmQgYW1vdW50KSlcXG4gICAgKVxcblxcbiAgKGRlZnVuIHJlbWVkaWF0ZTpzdHJpbmcgKGFjY291bnQ6c3RyaW5nIGFtb3VudDpkZWNpbWFsKVxcbiAgICBAZG9jIFxcXCJBbGxvd3MgZm9yIHJlbWVkaWF0aW9uIHRyYW5zYWN0aW9ucy4gVGhpcyBmdW5jdGlvbiBcXFxcXFxuICAgICAgICAgXFxcXGlzIHByb3RlY3RlZCBieSB0aGUgUkVNRURJQVRFIGNhcGFiaWxpdHlcXFwiXFxuICAgIEBtb2RlbCBbIChwcm9wZXJ0eSAodmFsaWQtYWNjb3VudCBhY2NvdW50KSlcXG4gICAgICAgICAgICAgKHByb3BlcnR5ICg-IGFtb3VudCAwLjApKVxcbiAgICAgICAgICAgXVxcblxcbiAgICAodmFsaWRhdGUtYWNjb3VudCBhY2NvdW50KVxcblxcbiAgICAoZW5mb3JjZSAoPiBhbW91bnQgMC4wKVxcbiAgICAgIFxcXCJSZW1lZGlhdGlvbiBhbW91bnQgbXVzdCBiZSBwb3NpdGl2ZVxcXCIpXFxuXFxuICAgIChlbmZvcmNlLXVuaXQgYW1vdW50KVxcblxcbiAgICAocmVxdWlyZS1jYXBhYmlsaXR5IChSRU1FRElBVEUpKVxcbiAgICAoZW1pdC1ldmVudCAoVFJBTlNGRVIgXFxcIlxcXCIgYWNjb3VudCBhbW91bnQpKSA7djNcXG4gICAgKHdpdGgtcmVhZCBjb2luLXRhYmxlIGFjY291bnRcXG4gICAgICB7IFxcXCJiYWxhbmNlXFxcIiA6PSBiYWxhbmNlIH1cXG5cXG4gICAgICAoZW5mb3JjZSAoPD0gYW1vdW50IGJhbGFuY2UpIFxcXCJJbnN1ZmZpY2llbnQgZnVuZHNcXFwiKVxcblxcbiAgICAgICh1cGRhdGUgY29pbi10YWJsZSBhY2NvdW50XFxuICAgICAgICB7IFxcXCJiYWxhbmNlXFxcIiA6ICgtIGJhbGFuY2UgYW1vdW50KSB9XFxuICAgICAgICApKVxcbiAgICApXFxuXFxuICAoZGVmcGFjdCBmdW5kLXR4IChzZW5kZXI6c3RyaW5nIG1pbmVyOnN0cmluZyBtaW5lci1ndWFyZDpndWFyZCB0b3RhbDpkZWNpbWFsKVxcbiAgICBAZG9jIFxcXCInZnVuZC10eCcgaXMgYSBzcGVjaWFsIHBhY3QgdG8gZnVuZCBhIHRyYW5zYWN0aW9uIGluIHR3byBzdGVwcywgICAgIFxcXFxcXG4gICAgXFxcXHdpdGggdGhlIGFjdHVhbCB0cmFuc2FjdGlvbiB0cmFuc3BpcmluZyBpbiB0aGUgbWlkZGxlOiAgICAgICAgICAgICAgICAgICBcXFxcXFxuICAgIFxcXFwgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgXFxcXFxcbiAgICBcXFxcICAxKSBBIGJ1eWluZyBwaGFzZSwgZGViaXRpbmcgdGhlIHNlbmRlciBmb3IgdG90YWwgZ2FzIGFuZCBmZWUsIHlpZWxkaW5nIFxcXFxcXG4gICAgXFxcXCAgICAgVFhfTUFYX0NIQVJHRS4gICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICBcXFxcXFxuICAgIFxcXFwgIDIpIEEgc2V0dGxlbWVudCBwaGFzZSwgcmVzdW1pbmcgVFhfTUFYX0NIQVJHRSwgYW5kIGFsbG9jYXRpbmcgdG8gdGhlICAgXFxcXFxcbiAgICBcXFxcICAgICBjb2luYmFzZSBhY2NvdW50IGZvciB1c2VkIGdhcyBhbmQgZmVlLCBhbmQgc2VuZGVyIGFjY291bnQgZm9yIGJhbC0gIFxcXFxcXG4gICAgXFxcXCAgICAgYW5jZSAodW51c2VkIGdhcywgaWYgYW55KS5cXFwiXFxuXFxuICAgIEBtb2RlbCBbIChwcm9wZXJ0eSAoPiB0b3RhbCAwLjApKVxcbiAgICAgICAgICAgICAocHJvcGVydHkgKHZhbGlkLWFjY291bnQgc2VuZGVyKSlcXG4gICAgICAgICAgICAgKHByb3BlcnR5ICh2YWxpZC1hY2NvdW50IG1pbmVyKSlcXG4gICAgICAgICAgICAgOyhwcm9wZXJ0eSBjb25zZXJ2ZXMtbWFzcykgbm90IHN1cHBvcnRlZCB5ZXRcXG4gICAgICAgICAgIF1cXG5cXG4gICAgKHN0ZXAgKGJ1eS1nYXMgc2VuZGVyIHRvdGFsKSlcXG4gICAgKHN0ZXAgKHJlZGVlbS1nYXMgbWluZXIgbWluZXItZ3VhcmQgc2VuZGVyIHRvdGFsKSlcXG4gICAgKVxcblxcbiAgKGRlZnVuIGRlYml0OnN0cmluZyAoYWNjb3VudDpzdHJpbmcgYW1vdW50OmRlY2ltYWwpXFxuICAgIEBkb2MgXFxcIkRlYml0IEFNT1VOVCBmcm9tIEFDQ09VTlQgYmFsYW5jZVxcXCJcXG5cXG4gICAgQG1vZGVsIFsgKHByb3BlcnR5ICg-IGFtb3VudCAwLjApKVxcbiAgICAgICAgICAgICAocHJvcGVydHkgKHZhbGlkLWFjY291bnQgYWNjb3VudCkpXFxuICAgICAgICAgICBdXFxuXFxuICAgICh2YWxpZGF0ZS1hY2NvdW50IGFjY291bnQpXFxuXFxuICAgIChlbmZvcmNlICg-IGFtb3VudCAwLjApXFxuICAgICAgXFxcImRlYml0IGFtb3VudCBtdXN0IGJlIHBvc2l0aXZlXFxcIilcXG5cXG4gICAgKGVuZm9yY2UtdW5pdCBhbW91bnQpXFxuXFxuICAgIChyZXF1aXJlLWNhcGFiaWxpdHkgKERFQklUIGFjY291bnQpKVxcbiAgICAod2l0aC1yZWFkIGNvaW4tdGFibGUgYWNjb3VudFxcbiAgICAgIHsgXFxcImJhbGFuY2VcXFwiIDo9IGJhbGFuY2UgfVxcblxcbiAgICAgIChlbmZvcmNlICg8PSBhbW91bnQgYmFsYW5jZSkgXFxcIkluc3VmZmljaWVudCBmdW5kc1xcXCIpXFxuXFxuICAgICAgKHVwZGF0ZSBjb2luLXRhYmxlIGFjY291bnRcXG4gICAgICAgIHsgXFxcImJhbGFuY2VcXFwiIDogKC0gYmFsYW5jZSBhbW91bnQpIH1cXG4gICAgICAgICkpXFxuICAgIClcXG5cXG5cXG4gIChkZWZ1biBjcmVkaXQ6c3RyaW5nIChhY2NvdW50OnN0cmluZyBndWFyZDpndWFyZCBhbW91bnQ6ZGVjaW1hbClcXG4gICAgQGRvYyBcXFwiQ3JlZGl0IEFNT1VOVCB0byBBQ0NPVU5UIGJhbGFuY2VcXFwiXFxuXFxuICAgIEBtb2RlbCBbIChwcm9wZXJ0eSAoPiBhbW91bnQgMC4wKSlcXG4gICAgICAgICAgICAgKHByb3BlcnR5ICh2YWxpZC1hY2NvdW50IGFjY291bnQpKVxcbiAgICAgICAgICAgXVxcblxcbiAgICAodmFsaWRhdGUtYWNjb3VudCBhY2NvdW50KVxcblxcbiAgICAoZW5mb3JjZSAoPiBhbW91bnQgMC4wKSBcXFwiY3JlZGl0IGFtb3VudCBtdXN0IGJlIHBvc2l0aXZlXFxcIilcXG4gICAgKGVuZm9yY2UtdW5pdCBhbW91bnQpXFxuXFxuICAgIChyZXF1aXJlLWNhcGFiaWxpdHkgKENSRURJVCBhY2NvdW50KSlcXG4gICAgKHdpdGgtZGVmYXVsdC1yZWFkIGNvaW4tdGFibGUgYWNjb3VudFxcbiAgICAgIHsgXFxcImJhbGFuY2VcXFwiIDogLTEuMCwgXFxcImd1YXJkXFxcIiA6IGd1YXJkIH1cXG4gICAgICB7IFxcXCJiYWxhbmNlXFxcIiA6PSBiYWxhbmNlLCBcXFwiZ3VhcmRcXFwiIDo9IHJldGcgfVxcbiAgICAgIDsgd2UgZG9uJ3Qgd2FudCB0byBvdmVyd3JpdGUgYW4gZXhpc3RpbmcgZ3VhcmQgd2l0aCB0aGUgdXNlci1zdXBwbGllZCBvbmVcXG4gICAgICAoZW5mb3JjZSAoPSByZXRnIGd1YXJkKVxcbiAgICAgICAgXFxcImFjY291bnQgZ3VhcmRzIGRvIG5vdCBtYXRjaFxcXCIpXFxuXFxuICAgICAgKGxldCAoKGlzLW5ld1xcbiAgICAgICAgICAgICAoaWYgKD0gYmFsYW5jZSAtMS4wKVxcbiAgICAgICAgICAgICAgICAgKGVuZm9yY2UtcmVzZXJ2ZWQgYWNjb3VudCBndWFyZClcXG4gICAgICAgICAgICAgICBmYWxzZSkpKVxcblxcbiAgICAgICAgKHdyaXRlIGNvaW4tdGFibGUgYWNjb3VudFxcbiAgICAgICAgICB7IFxcXCJiYWxhbmNlXFxcIiA6IChpZiBpcy1uZXcgYW1vdW50ICgrIGJhbGFuY2UgYW1vdW50KSlcXG4gICAgICAgICAgLCBcXFwiZ3VhcmRcXFwiICAgOiByZXRnXFxuICAgICAgICAgIH0pKVxcbiAgICAgICkpXFxuXFxuICAoZGVmdW4gY2hlY2stcmVzZXJ2ZWQ6c3RyaW5nIChhY2NvdW50OnN0cmluZylcXG4gICAgXFxcIiBDaGVja3MgQUNDT1VOVCBmb3IgcmVzZXJ2ZWQgbmFtZSBhbmQgcmV0dXJucyB0eXBlIGlmIFxcXFxcXG4gICAgXFxcXCBmb3VuZCBvciBlbXB0eSBzdHJpbmcuIFJlc2VydmVkIG5hbWVzIHN0YXJ0IHdpdGggYSBcXFxcXFxuICAgIFxcXFwgc2luZ2xlIGNoYXIgYW5kIGNvbG9uLCBlLmcuICdjOmZvbycsIHdoaWNoIHdvdWxkIHJldHVybiAnYycgYXMgdHlwZS5cXFwiXFxuICAgIChsZXQgKChwZnggKHRha2UgMiBhY2NvdW50KSkpXFxuICAgICAgKGlmICg9IFxcXCI6XFxcIiAodGFrZSAtMSBwZngpKSAodGFrZSAxIHBmeCkgXFxcIlxcXCIpKSlcXG5cXG4gIChkZWZ1biBlbmZvcmNlLXJlc2VydmVkOmJvb2wgKGFjY291bnQ6c3RyaW5nIGd1YXJkOmd1YXJkKVxcbiAgICBAZG9jIFxcXCJFbmZvcmNlIHJlc2VydmVkIGFjY291bnQgbmFtZSBwcm90b2NvbHMuXFxcIlxcbiAgICAoaWYgKHZhbGlkYXRlLXByaW5jaXBhbCBndWFyZCBhY2NvdW50KVxcbiAgICAgIHRydWVcXG4gICAgICAobGV0ICgociAoY2hlY2stcmVzZXJ2ZWQgYWNjb3VudCkpKVxcbiAgICAgICAgKGlmICg9IHIgXFxcIlxcXCIpXFxuICAgICAgICAgIHRydWVcXG4gICAgICAgICAgKGlmICg9IHIgXFxcImtcXFwiKVxcbiAgICAgICAgICAgIChlbmZvcmNlIGZhbHNlIFxcXCJTaW5nbGUta2V5IGFjY291bnQgcHJvdG9jb2wgdmlvbGF0aW9uXFxcIilcXG4gICAgICAgICAgICAoZW5mb3JjZSBmYWxzZVxcbiAgICAgICAgICAgICAgKGZvcm1hdCBcXFwiUmVzZXJ2ZWQgcHJvdG9jb2wgZ3VhcmQgdmlvbGF0aW9uOiB7fVxcXCIgW3JdKSlcXG4gICAgICAgICAgICApKSkpKVxcblxcblxcbiAgKGRlZnNjaGVtYSBjcm9zc2NoYWluLXNjaGVtYVxcbiAgICBAZG9jIFxcXCJTY2hlbWEgZm9yIHlpZWxkZWQgdmFsdWUgaW4gY3Jvc3MtY2hhaW4gdHJhbnNmZXJzXFxcIlxcbiAgICByZWNlaXZlcjpzdHJpbmdcXG4gICAgcmVjZWl2ZXItZ3VhcmQ6Z3VhcmRcXG4gICAgYW1vdW50OmRlY2ltYWxcXG4gICAgc291cmNlLWNoYWluOnN0cmluZylcXG5cXG4gIChkZWZwYWN0IHRyYW5zZmVyLWNyb3NzY2hhaW46c3RyaW5nXFxuICAgICggc2VuZGVyOnN0cmluZ1xcbiAgICAgIHJlY2VpdmVyOnN0cmluZ1xcbiAgICAgIHJlY2VpdmVyLWd1YXJkOmd1YXJkXFxuICAgICAgdGFyZ2V0LWNoYWluOnN0cmluZ1xcbiAgICAgIGFtb3VudDpkZWNpbWFsIClcXG5cXG4gICAgQG1vZGVsIFsgKHByb3BlcnR5ICg-IGFtb3VudCAwLjApKVxcbiAgICAgICAgICAgICAocHJvcGVydHkgKHZhbGlkLWFjY291bnQgc2VuZGVyKSlcXG4gICAgICAgICAgICAgKHByb3BlcnR5ICh2YWxpZC1hY2NvdW50IHJlY2VpdmVyKSlcXG4gICAgICAgICAgIF1cXG5cXG4gICAgKHN0ZXBcXG4gICAgICAod2l0aC1jYXBhYmlsaXR5XFxuICAgICAgICAoVFJBTlNGRVJfWENIQUlOIHNlbmRlciByZWNlaXZlciBhbW91bnQgdGFyZ2V0LWNoYWluKVxcblxcbiAgICAgICAgKHZhbGlkYXRlLWFjY291bnQgc2VuZGVyKVxcbiAgICAgICAgKHZhbGlkYXRlLWFjY291bnQgcmVjZWl2ZXIpXFxuXFxuICAgICAgICAoZW5mb3JjZSAoIT0gXFxcIlxcXCIgdGFyZ2V0LWNoYWluKSBcXFwiZW1wdHkgdGFyZ2V0LWNoYWluXFxcIilcXG4gICAgICAgIChlbmZvcmNlICghPSAoYXQgJ2NoYWluLWlkIChjaGFpbi1kYXRhKSkgdGFyZ2V0LWNoYWluKVxcbiAgICAgICAgICBcXFwiY2Fubm90IHJ1biBjcm9zcy1jaGFpbiB0cmFuc2ZlcnMgdG8gdGhlIHNhbWUgY2hhaW5cXFwiKVxcblxcbiAgICAgICAgKGVuZm9yY2UgKD4gYW1vdW50IDAuMClcXG4gICAgICAgICAgXFxcInRyYW5zZmVyIHF1YW50aXR5IG11c3QgYmUgcG9zaXRpdmVcXFwiKVxcblxcbiAgICAgICAgKGVuZm9yY2UtdW5pdCBhbW91bnQpXFxuXFxuICAgICAgICAoZW5mb3JjZSAoY29udGFpbnMgdGFyZ2V0LWNoYWluIFZBTElEX0NIQUlOX0lEUylcXG4gICAgICAgICAgXFxcInRhcmdldCBjaGFpbiBpcyBub3QgYSB2YWxpZCBjaGFpbndlYiBjaGFpbiBpZFxcXCIpXFxuXFxuICAgICAgICA7OyBzdGVwIDEgLSBkZWJpdCBkZWxldGUtYWNjb3VudCBvbiBjdXJyZW50IGNoYWluXFxuICAgICAgICAoZGViaXQgc2VuZGVyIGFtb3VudClcXG4gICAgICAgIChlbWl0LWV2ZW50IChUUkFOU0ZFUiBzZW5kZXIgXFxcIlxcXCIgYW1vdW50KSlcXG5cXG4gICAgICAgIChsZXRcXG4gICAgICAgICAgKChjcm9zc2NoYWluLWRldGFpbHM6b2JqZWN0e2Nyb3NzY2hhaW4tc2NoZW1hfVxcbiAgICAgICAgICAgIHsgXFxcInJlY2VpdmVyXFxcIiA6IHJlY2VpdmVyXFxuICAgICAgICAgICAgLCBcXFwicmVjZWl2ZXItZ3VhcmRcXFwiIDogcmVjZWl2ZXItZ3VhcmRcXG4gICAgICAgICAgICAsIFxcXCJhbW91bnRcXFwiIDogYW1vdW50XFxuICAgICAgICAgICAgLCBcXFwic291cmNlLWNoYWluXFxcIiA6IChhdCAnY2hhaW4taWQgKGNoYWluLWRhdGEpKVxcbiAgICAgICAgICAgIH0pKVxcbiAgICAgICAgICAoeWllbGQgY3Jvc3NjaGFpbi1kZXRhaWxzIHRhcmdldC1jaGFpbilcXG4gICAgICAgICAgKSkpXFxuXFxuICAgIChzdGVwXFxuICAgICAgKHJlc3VtZVxcbiAgICAgICAgeyBcXFwicmVjZWl2ZXJcXFwiIDo9IHJlY2VpdmVyXFxuICAgICAgICAsIFxcXCJyZWNlaXZlci1ndWFyZFxcXCIgOj0gcmVjZWl2ZXItZ3VhcmRcXG4gICAgICAgICwgXFxcImFtb3VudFxcXCIgOj0gYW1vdW50XFxuICAgICAgICAsIFxcXCJzb3VyY2UtY2hhaW5cXFwiIDo9IHNvdXJjZS1jaGFpblxcbiAgICAgICAgfVxcblxcbiAgICAgICAgKGVtaXQtZXZlbnQgKFRSQU5TRkVSIFxcXCJcXFwiIHJlY2VpdmVyIGFtb3VudCkpXFxuICAgICAgICAoZW1pdC1ldmVudCAoVFJBTlNGRVJfWENIQUlOX1JFQ0QgXFxcIlxcXCIgcmVjZWl2ZXIgYW1vdW50IHNvdXJjZS1jaGFpbikpXFxuXFxuICAgICAgICA7OyBzdGVwIDIgLSBjcmVkaXQgY3JlYXRlIGFjY291bnQgb24gdGFyZ2V0IGNoYWluXFxuICAgICAgICAod2l0aC1jYXBhYmlsaXR5IChDUkVESVQgcmVjZWl2ZXIpXFxuICAgICAgICAgIChjcmVkaXQgcmVjZWl2ZXIgcmVjZWl2ZXItZ3VhcmQgYW1vdW50KSlcXG4gICAgICAgICkpXFxuICAgIClcXG5cXG5cXG4gIDsgLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS1cXG4gIDsgQ29pbiBhbGxvY2F0aW9uc1xcblxcbiAgKGRlZnNjaGVtYSBhbGxvY2F0aW9uLXNjaGVtYVxcbiAgICBAZG9jIFxcXCJHZW5lc2lzIGFsbG9jYXRpb24gcmVnaXN0cnlcXFwiXFxuICAgIDtAbW9kZWwgWyAoaW52YXJpYW50ICg-PSBiYWxhbmNlIDAuMCkpIF1cXG5cXG4gICAgYmFsYW5jZTpkZWNpbWFsXFxuICAgIGRhdGU6dGltZVxcbiAgICBndWFyZDpndWFyZFxcbiAgICByZWRlZW1lZDpib29sKVxcblxcbiAgKGRlZnRhYmxlIGFsbG9jYXRpb24tdGFibGU6e2FsbG9jYXRpb24tc2NoZW1hfSlcXG5cXG4gIChkZWZ1biBjcmVhdGUtYWxsb2NhdGlvbi1hY2NvdW50XFxuICAgICggYWNjb3VudDpzdHJpbmdcXG4gICAgICBkYXRlOnRpbWVcXG4gICAgICBrZXlzZXQtcmVmOnN0cmluZ1xcbiAgICAgIGFtb3VudDpkZWNpbWFsXFxuICAgIClcXG5cXG4gICAgQGRvYyBcXFwiQWRkIGFuIGVudHJ5IHRvIHRoZSBjb2luIGFsbG9jYXRpb24gdGFibGUuIFRoaXMgZnVuY3Rpb24gXFxcXFxcbiAgICAgICAgIFxcXFxhbHNvIGNyZWF0ZXMgYSBjb3JyZXNwb25kaW5nIGVtcHR5IGNvaW4gY29udHJhY3QgYWNjb3VudCBcXFxcXFxuICAgICAgICAgXFxcXG9mIHRoZSBzYW1lIG5hbWUgYW5kIGd1YXJkLiBSZXF1aXJlcyBHRU5FU0lTIGNhcGFiaWxpdHkuIFxcXCJcXG5cXG4gICAgQG1vZGVsIFsgKHByb3BlcnR5ICh2YWxpZC1hY2NvdW50IGFjY291bnQpKSBdXFxuXFxuICAgIChyZXF1aXJlLWNhcGFiaWxpdHkgKEdFTkVTSVMpKVxcblxcbiAgICAodmFsaWRhdGUtYWNjb3VudCBhY2NvdW50KVxcbiAgICAoZW5mb3JjZSAoPj0gYW1vdW50IDAuMClcXG4gICAgICBcXFwiYWxsb2NhdGlvbiBhbW91bnQgbXVzdCBiZSBub24tbmVnYXRpdmVcXFwiKVxcblxcbiAgICAoZW5mb3JjZS11bml0IGFtb3VudClcXG5cXG4gICAgKGxldFxcbiAgICAgICgoZ3VhcmQ6Z3VhcmQgKGtleXNldC1yZWYtZ3VhcmQga2V5c2V0LXJlZikpKVxcblxcbiAgICAgIChjcmVhdGUtYWNjb3VudCBhY2NvdW50IGd1YXJkKVxcblxcbiAgICAgIChpbnNlcnQgYWxsb2NhdGlvbi10YWJsZSBhY2NvdW50XFxuICAgICAgICB7IFxcXCJiYWxhbmNlXFxcIiA6IGFtb3VudFxcbiAgICAgICAgLCBcXFwiZGF0ZVxcXCIgOiBkYXRlXFxuICAgICAgICAsIFxcXCJndWFyZFxcXCIgOiBndWFyZFxcbiAgICAgICAgLCBcXFwicmVkZWVtZWRcXFwiIDogZmFsc2VcXG4gICAgICAgIH0pKSlcXG5cXG4gIChkZWZ1biByZWxlYXNlLWFsbG9jYXRpb25cXG4gICAgKCBhY2NvdW50OnN0cmluZyApXFxuXFxuICAgIEBkb2MgXFxcIlJlbGVhc2UgZnVuZHMgYXNzb2NpYXRlZCB3aXRoIGFsbG9jYXRpb24gQUNDT1VOVCBpbnRvIG1haW4gbGVkZ2VyLiAgIFxcXFxcXG4gICAgICAgICBcXFxcQUNDT1VOVCBtdXN0IGFscmVhZHkgZXhpc3QgaW4gbWFpbiBsZWRnZXIuIEFsbG9jYXRpb24gaXMgZGVhY3RpdmF0ZWQgXFxcXFxcbiAgICAgICAgIFxcXFxhZnRlciByZWxlYXNlLlxcXCJcXG4gICAgQG1vZGVsIFsgKHByb3BlcnR5ICh2YWxpZC1hY2NvdW50IGFjY291bnQpKSBdXFxuXFxuICAgICh2YWxpZGF0ZS1hY2NvdW50IGFjY291bnQpXFxuXFxuICAgICh3aXRoLXJlYWQgYWxsb2NhdGlvbi10YWJsZSBhY2NvdW50XFxuICAgICAgeyBcXFwiYmFsYW5jZVxcXCIgOj0gYmFsYW5jZVxcbiAgICAgICwgXFxcImRhdGVcXFwiIDo9IHJlbGVhc2UtdGltZVxcbiAgICAgICwgXFxcInJlZGVlbWVkXFxcIiA6PSByZWRlZW1lZFxcbiAgICAgICwgXFxcImd1YXJkXFxcIiA6PSBndWFyZFxcbiAgICAgIH1cXG5cXG4gICAgICAobGV0ICgoY3Vyci10aW1lOnRpbWUgKGF0ICdibG9jay10aW1lIChjaGFpbi1kYXRhKSkpKVxcblxcbiAgICAgICAgKGVuZm9yY2UgKG5vdCByZWRlZW1lZClcXG4gICAgICAgICAgXFxcImFsbG9jYXRpb24gZnVuZHMgaGF2ZSBhbHJlYWR5IGJlZW4gcmVkZWVtZWRcXFwiKVxcblxcbiAgICAgICAgKGVuZm9yY2VcXG4gICAgICAgICAgKD49IGN1cnItdGltZSByZWxlYXNlLXRpbWUpXFxuICAgICAgICAgIChmb3JtYXQgXFxcImZ1bmRzIGxvY2tlZCB1bnRpbCB7fS4gY3VycmVudCB0aW1lOiB7fVxcXCIgW3JlbGVhc2UtdGltZSBjdXJyLXRpbWVdKSlcXG5cXG4gICAgICAgICh3aXRoLWNhcGFiaWxpdHkgKFJFTEVBU0VfQUxMT0NBVElPTiBhY2NvdW50IGJhbGFuY2UpXFxuXFxuICAgICAgICAoZW5mb3JjZS1ndWFyZCBndWFyZClcXG5cXG4gICAgICAgICh3aXRoLWNhcGFiaWxpdHkgKENSRURJVCBhY2NvdW50KVxcbiAgICAgICAgICAoZW1pdC1ldmVudCAoVFJBTlNGRVIgXFxcIlxcXCIgYWNjb3VudCBiYWxhbmNlKSlcXG4gICAgICAgICAgKGNyZWRpdCBhY2NvdW50IGd1YXJkIGJhbGFuY2UpXFxuXFxuICAgICAgICAgICh1cGRhdGUgYWxsb2NhdGlvbi10YWJsZSBhY2NvdW50XFxuICAgICAgICAgICAgeyBcXFwicmVkZWVtZWRcXFwiIDogdHJ1ZVxcbiAgICAgICAgICAgICwgXFxcImJhbGFuY2VcXFwiIDogMC4wXFxuICAgICAgICAgICAgfSlcXG5cXG4gICAgICAgICAgXFxcIkFsbG9jYXRpb24gc3VjY2Vzc2Z1bGx5IHJlbGVhc2VkIHRvIG1haW4gbGVkZ2VyXFxcIikpXFxuICAgICkpKVxcblxcbilcXG5cXG4oY3JlYXRlLXRhYmxlIGNvaW4tdGFibGUpXFxuKGNyZWF0ZS10YWJsZSBhbGxvY2F0aW9uLXRhYmxlKVxcblwifX0sXCJzaWduZXJzXCI6W10sXCJtZXRhXCI6e1wiY3JlYXRpb25UaW1lXCI6MCxcInR0bFwiOjE3MjgwMCxcImdhc0xpbWl0XCI6MCxcImNoYWluSWRcIjpcIlwiLFwiZ2FzUHJpY2VcIjowLFwic2VuZGVyXCI6XCJcIn0sXCJub25jZVwiOlwiY29pbi1jb250cmFjdC12Ni1pbnN0YWxsXCJ9In0", unsafeFromText "eyJnYXMiOjAsInJlc3VsdCI6eyJzdGF0dXMiOiJzdWNjZXNzIiwiZGF0YSI6IlRhYmxlQ3JlYXRlZCJ9LCJyZXFLZXkiOiJHUklRdTRoQUtrMElEOUY4el8tMHlYeUFLSjMzTVB5VFlNWE9qbFBKbXBJIiwibG9ncyI6IkxKWlA1V2ZFN1VfNGZINWltQm56dE94ZndyWWN0enQtdmNoSkRvUXN2T1EiLCJtZXRhRGF0YSI6bnVsbCwiY29udGludWF0aW9uIjpudWxsLCJ0eElkIjozfQ") + , (unsafeFromText "eyJoYXNoIjoiU0IzVzVFTGl6azl4elNWWk9MX3dsem5VNjh5aUhPQzlwWUhreHBVXzBnbyIsInNpZ3MiOltdLCJjbWQiOiJ7XCJuZXR3b3JrSWRcIjpudWxsLFwicGF5bG9hZFwiOntcImV4ZWNcIjp7XCJkYXRhXCI6bnVsbCxcImNvZGVcIjpcIihpbnRlcmZhY2UgZ2FzLXBheWVyLXYxXFxuXFxuICAoZGVmY2FwIEdBU19QQVlFUjpib29sXFxuICAgICggdXNlcjpzdHJpbmdcXG4gICAgICBsaW1pdDppbnRlZ2VyXFxuICAgICAgcHJpY2U6ZGVjaW1hbFxcbiAgICApXFxuICAgIEBkb2NcXG4gICAgXFxcIiBQcm92aWRlIGEgY2FwYWJpbGl0eSBpbmRpY2F0aW5nIHRoYXQgZGVjbGFyaW5nIG1vZHVsZSBzdXBwb3J0cyBcXFxcXFxuICAgIFxcXFwgZ2FzIHBheW1lbnQgZm9yIFVTRVIgZm9yIGdhcyBMSU1JVCBhbmQgUFJJQ0UuIEZ1bmN0aW9uYWxpdHkgXFxcXFxcbiAgICBcXFxcIHNob3VsZCByZXF1aXJlIGNhcGFiaWxpdHkgKGNvaW4uRlVORF9UWCksIGFuZCBzaG91bGQgdmFsaWRhdGUgXFxcXFxcbiAgICBcXFxcIHRoZSBzcGVuZCBvZiAobGltaXQgKiBwcmljZSksIHBvc3NpYmx5IHVwZGF0aW5nIHNvbWUgZGF0YWJhc2UgXFxcXFxcbiAgICBcXFxcIGVudHJ5LiBcXFxcXFxuICAgIFxcXFwgU2hvdWxkIGNvbXBvc2UgY2FwYWJpbGl0eSByZXF1aXJlZCBmb3IgJ2NyZWF0ZS1nYXMtcGF5ZXItZ3VhcmQnLlxcXCJcXG4gICAgQG1vZGVsXFxuICAgIFsgKHByb3BlcnR5ICh1c2VyICE9IFxcXCJcXFwiKSlcXG4gICAgICAocHJvcGVydHkgKGxpbWl0ID4gMCkpXFxuICAgICAgKHByb3BlcnR5IChwcmljZSA-IDAuMCkpXFxuICAgIF1cXG4gIClcXG5cXG4gIChkZWZ1biBjcmVhdGUtZ2FzLXBheWVyLWd1YXJkOmd1YXJkICgpXFxuICAgIEBkb2NcXG4gICAgXFxcIiBQcm92aWRlIGEgZ3VhcmQgc3VpdGFibGUgZm9yIGNvbnRyb2xsaW5nIGEgY29pbiBhY2NvdW50IHRoYXQgY2FuIFxcXFxcXG4gICAgXFxcXCBwYXkgZ2FzIHZpYSBHQVNfUEFZRVIgbWVjaGFuaWNzLiBHZW5lcmFsbHkgdGhpcyBpcyBhY2NvbXBsaXNoZWQgXFxcXFxcbiAgICBcXFxcIGJ5IGhhdmluZyBHQVNfUEFZRVIgY29tcG9zZSBhbiB1bnBhcmFtZXRlcml6ZWQsIHVubWFuYWdlZCBjYXBhYmlsaXR5IFxcXFxcXG4gICAgXFxcXCB0aGF0IGlzIHJlcXVpcmVkIGluIHRoaXMgZ3VhcmQuIFRodXMsIGlmIGNvaW4gY29udHJhY3QgaXMgYWJsZSB0byBcXFxcXFxuICAgIFxcXFwgc3VjY2Vzc2Z1bGx5IGFjcXVpcmUgR0FTX1BBWUVSLCB0aGUgY29tcG9zZWQgJ2Fub255bW91cycgY2FwIHJlcXVpcmVkIFxcXFxcXG4gICAgXFxcXCBoZXJlIHdpbGwgYmUgaW4gc2NvcGUsIGFuZCBnYXMgYnV5IHdpbGwgc3VjY2VlZC5cXFwiXFxuICApXFxuXFxuKVxcblwifX0sXCJzaWduZXJzXCI6W10sXCJtZXRhXCI6e1wiY3JlYXRpb25UaW1lXCI6MCxcInR0bFwiOjE3MjgwMCxcImdhc0xpbWl0XCI6MCxcImNoYWluSWRcIjpcIlwiLFwiZ2FzUHJpY2VcIjowLFwic2VuZGVyXCI6XCJcIn0sXCJub25jZVwiOlwiZ2VuZXNpcy0wMVwifSJ9", unsafeFromText "eyJnYXMiOjAsInJlc3VsdCI6eyJzdGF0dXMiOiJzdWNjZXNzIiwiZGF0YSI6IkxvYWRlZCBpbnRlcmZhY2UgZ2FzLXBheWVyLXYxLCBoYXNoIGlJV0FQMW9lbl9rcFhqRmJuUU04N0FKUlpJZ3RzZlpjQXdZckV5MjFSV1EifSwicmVxS2V5IjoiU0IzVzVFTGl6azl4elNWWk9MX3dsem5VNjh5aUhPQzlwWUhreHBVXzBnbyIsImxvZ3MiOiJ3TXdXV3hkSFVuU1VOWXJ1RXlISEtTTzUyeGtkVXU0TXBmbE1FcHYyT05FIiwibWV0YURhdGEiOm51bGwsImNvbnRpbnVhdGlvbiI6bnVsbCwidHhJZCI6NH0") + , (unsafeFromText "eyJoYXNoIjoiQ1pteWxXZmllUk1CTXU1dzJFT21wRndLLXQ3YmNPVHM0bUsyYVQzM3VSNCIsInNpZ3MiOltdLCJjbWQiOiJ7XCJuZXR3b3JrSWRcIjpudWxsLFwicGF5bG9hZFwiOntcImV4ZWNcIjp7XCJkYXRhXCI6e1wibnMtYWRtaW4ta2V5c2V0XCI6W1wiMzY4ODIwZjgwYzMyNGJiYzdjMmIwNjEwNjg4YTdkYTQzZTM5ZjkxZDExODczMjY3MWNkOWM3NTAwZmY0M2NjYVwiXSxcIm5zLW9wZXJhdGUta2V5c2V0XCI6W1wiMzY4ODIwZjgwYzMyNGJiYzdjMmIwNjEwNjg4YTdkYTQzZTM5ZjkxZDExODczMjY3MWNkOWM3NTAwZmY0M2NjYVwiXSxcIm5zLWdlbmVzaXMta2V5c2V0XCI6e1wicHJlZFwiOlwiPVwiLFwia2V5c1wiOltdfX0sXCJjb2RlXCI6XCIoZGVmaW5lLWtleXNldCAnbnMtYWRtaW4ta2V5c2V0IChyZWFkLWtleXNldCAnbnMtYWRtaW4ta2V5c2V0KSlcXG4oZGVmaW5lLWtleXNldCAnbnMtb3BlcmF0ZS1rZXlzZXQgKHJlYWQta2V5c2V0ICducy1nZW5lc2lzLWtleXNldCkpXFxuXFxuKG1vZHVsZSBucyBHT1ZFUk5BTkNFXFxuICBcXFwiQWRtaW5pc3RlcnMgZGVmaW5pdGlvbiBvZiBuZXcgbmFtZXNwYWNlcyBpbiBDaGFpbndlYi5cXFwiXFxuXFxuICAoZGVmc2NoZW1hIHJlZy1lbnRyeVxcbiAgICBhZG1pbi1ndWFyZDpndWFyZFxcbiAgICBhY3RpdmU6Ym9vbClcXG5cXG4gIChkZWZ0YWJsZSByZWdpc3RyeTp7cmVnLWVudHJ5fSlcXG5cXG4gIChkZWZjYXAgR09WRVJOQU5DRSAoKVxcbiAgICAoZW5mb3JjZS1rZXlzZXQgJ25zLWFkbWluLWtleXNldCkpXFxuXFxuICAoZGVmY2FwIE9QRVJBVEUgKClcXG4gICAgKGVuZm9yY2Uta2V5c2V0ICducy1vcGVyYXRlLWtleXNldCkpXFxuXFxuICAoZGVmY29uc3QgR1VBUkRfU1VDQ0VTUyAoY3JlYXRlLXVzZXItZ3VhcmQgKHN1Y2Nlc3MpKSlcXG4gIChkZWZjb25zdCBHVUFSRF9GQUlMVVJFIChjcmVhdGUtdXNlci1ndWFyZCAoZmFpbHVyZSkpKVxcblxcbiAgKGRlZnVuIHN1Y2Nlc3MgKClcXG4gICAgdHJ1ZSlcXG4gIChkZWZ1biBmYWlsdXJlICgpXFxuICAgIChlbmZvcmNlIGZhbHNlIFxcXCJEaXNhYmxlZFxcXCIpKVxcblxcbiAgKGRlZnVuIHZhbGlkYXRlLW5hbWUgKG5hbWUpXFxuICAgIChlbmZvcmNlICghPSBcXFwiXFxcIiBuYW1lKSBcXFwiRW1wdHkgbmFtZSBub3QgYWxsb3dlZFxcXCIpXFxuICAgIChlbmZvcmNlICg8IChsZW5ndGggbmFtZSkgNjQpIFxcXCJOYW1lIG11c3QgYmUgbGVzcyB0aGFuIDY0IGNoYXJhY3RlcnMgbG9uZ1xcXCIpXFxuICAgIChlbmZvcmNlIChpcy1jaGFyc2V0IENIQVJTRVRfTEFUSU4xIG5hbWUpXFxuICAgICAgICAgICAgIFxcXCJOYW1lIG11c3QgYmUgaW4gbGF0aW4xIGNoYXJzZXRcXFwiKSlcXG5cXG4gIChkZWZ1biBjcmVhdGUtcHJpbmNpcGFsLW5hbWVzcGFjZTpzdHJpbmdcXG4gICAgICAoIGc6Z3VhcmRcXG4gICAgICAgIClcXG4gICAgXFxcIiBGb3JtYXQgcHJpbmNpcGFsIG5hbWVzcGFjZSBhcyBQYWN0IGhhc2ggKEJMQUtFMmIyNTYpIG9mIHByaW5jaXBhbCBcXFxcXFxuICAgIFxcXFwgaW4gaGV4IHRydW5jYXRlZCB0byAxNjAgYml0cyAoNDAgY2hhcmFjdGVycyksIHByZXBlbmRlZCB3aXRoICduXycuXFxcXFxcbiAgICBcXFxcIE9ubHkgdzogYW5kIGs6IGFjY291bnQgcHJvdG9jb2xzIGFyZSBzdXBwb3J0ZWQuIFxcXCJcXG5cXG4gICAgKGxldFxcbiAgICAgICgodHkgKHR5cGVvZi1wcmluY2lwYWwgKGNyZWF0ZS1wcmluY2lwYWwgZykpKSlcXG5cXG4gICAgICA7OyBvbmx5IHc6IGFuZCBrOiBjdXJyZW50bHkgc3VwcG9ydGVkXFxuICAgICAgKGlmIChvciAoPSB0eSBcXFwiazpcXFwiKSAoPSB0eSBcXFwidzpcXFwiKSlcXG4gICAgICAgICgrIFxcXCJuX1xcXCIgKHRha2UgNDAgKGludC10by1zdHIgMTYgKHN0ci10by1pbnQgNjQgKGhhc2ggZykpKSkpXFxuICAgICAgICAoZW5mb3JjZSBmYWxzZVxcbiAgICAgICAgICAoZm9ybWF0IFxcXCJVbnN1cHBvcnRlZCBndWFyZCBwcm90b2NvbDoge31cXFwiIFt0eV0pKVxcbiAgICAgICAgKSlcXG4gIClcXG5cXG4gIChkZWZ1biB2YWxpZGF0ZTpib29sXFxuICAgICAgKCBucy1uYW1lOnN0cmluZ1xcbiAgICAgICAgbnMtYWRtaW46Z3VhcmRcXG4gICAgICAgIClcXG4gICAgXFxcIiBNYW5hZ2VzIG5hbWVzcGFjZSBpbnN0YWxsIGZvciBDaGFpbndlYi4gXFxcXFxcbiAgICBcXFxcIEFsbG93cyBwcmluY2lwYWwgbmFtZXNwYWNlcy4gXFxcXFxcbiAgICBcXFxcIE5vbi1wcmluY2lwYWwgbmFtZXNwYWNlcyByZXF1aXJlIGFjdGl2ZSByb3cgaW4gcmVnaXN0cnkgXFxcXFxcbiAgICBcXFxcIGZvciBOUy1OQU1FIHdpdGggZ3VhcmQgbWF0Y2hpbmcgTlMtQURNSU4uXFxcIlxcblxcbiAgICAoaWYgKD0gKGNyZWF0ZS1wcmluY2lwYWwtbmFtZXNwYWNlIG5zLWFkbWluKSBucy1uYW1lKVxcblxcbiAgICAgIHRydWUgOzsgYWxsb3cgcHJpbmNpcGFsIG5hbWVzcGFjZXNcXG5cXG4gICAgICAod2l0aC1kZWZhdWx0LXJlYWQgcmVnaXN0cnkgbnMtbmFtZSAgICAgICA7OyBvdGhlcndpc2UgZW5mb3JjZSByZWdpc3RyeVxcbiAgICAgICAgeyAnYWRtaW4tZ3VhcmQgOiBucy1hZG1pblxcbiAgICAgICAgLCAnYWN0aXZlIDogZmFsc2UgfVxcbiAgICAgICAgeyAnYWRtaW4tZ3VhcmQgOj0gYWdcXG4gICAgICAgICwgJ2FjdGl2ZSA6PSBpcy1hY3RpdmUgfVxcblxcbiAgICAgICAgKGVuZm9yY2UgaXMtYWN0aXZlIFxcXCJJbmFjdGl2ZSBvciB1bnJlZ2lzdGVyZWQgbmFtZXNwYWNlXFxcIilcXG4gICAgICAgIChlbmZvcmNlICg9IG5zLWFkbWluIGFnKSBcXFwiQWRtaW4gZ3VhcmQgbXVzdCBtYXRjaCBndWFyZCBpbiByZWdpc3RyeVxcXCIpXFxuXFxuICAgICAgICB0cnVlKVxcbiAgICAgICkpXFxuXFxuICAoZGVmdW4gd3JpdGUtcmVnaXN0cnk6c3RyaW5nXFxuICAgICAgKCBucy1uYW1lOnN0cmluZ1xcbiAgICAgICAgZ3VhcmQ6Z3VhcmRcXG4gICAgICAgIGFjdGl2ZTpib29sXFxuICAgICAgICApXFxuICAgIFxcXCIgV3JpdGUgZW50cnkgd2l0aCBHVUFSRCBhbmQgQUNUSVZFIGludG8gcmVnaXN0cnkgZm9yIE5BTUUuIFxcXFxcXG4gICAgXFxcXCBHdWFyZGVkIGJ5IG9wZXJhdGUga2V5c2V0LiBcXFwiXFxuXFxuICAgICh3aXRoLWNhcGFiaWxpdHkgKE9QRVJBVEUpXFxuXFxuICAgICAgKHZhbGlkYXRlLW5hbWUgbnMtbmFtZSlcXG5cXG4gICAgICAod3JpdGUgcmVnaXN0cnkgbnMtbmFtZVxcbiAgICAgICAgeyAnYWRtaW4tZ3VhcmQ6IGd1YXJkXFxuICAgICAgICAsICdhY3RpdmU6IGFjdGl2ZSB9KVxcblxcbiAgICAgIFxcXCJSZWdpc3RlciBlbnRyeSB3cml0dGVuXFxcIikpXFxuXFxuICAoZGVmdW4gcXVlcnk6b2JqZWN0e3JlZy1lbnRyeX1cXG4gICAgICAoIG5zLW5hbWU6c3RyaW5nIClcXG4gICAgKHJlYWQgcmVnaXN0cnkgbnMtbmFtZSkpXFxuXFxuKVxcblxcbihjcmVhdGUtdGFibGUgcmVnaXN0cnkpXFxuXFxuKHdyaXRlLXJlZ2lzdHJ5IFxcXCJrYWRlbmFcXFwiXFxuICAoa2V5c2V0LXJlZi1ndWFyZCAnbnMtb3BlcmF0ZS1rZXlzZXQpIHRydWUpXFxuKHdyaXRlLXJlZ2lzdHJ5IFxcXCJ1c2VyXFxcIiBHVUFSRF9GQUlMVVJFIHRydWUpXFxuKHdyaXRlLXJlZ2lzdHJ5IFxcXCJmcmVlXFxcIiBHVUFSRF9GQUlMVVJFIHRydWUpXFxuXFxuKGRlZmluZS1uYW1lc3BhY2UgXFxcImthZGVuYVxcXCJcXG4gIChrZXlzZXQtcmVmLWd1YXJkICducy1vcGVyYXRlLWtleXNldClcXG4gIChrZXlzZXQtcmVmLWd1YXJkICducy1vcGVyYXRlLWtleXNldCkpXFxuXFxuKGRlZmluZS1uYW1lc3BhY2UgXFxcInVzZXJcXFwiIEdVQVJEX1NVQ0NFU1MgR1VBUkRfRkFJTFVSRSlcXG4oZGVmaW5lLW5hbWVzcGFjZSBcXFwiZnJlZVxcXCIgR1VBUkRfU1VDQ0VTUyBHVUFSRF9GQUlMVVJFKVxcbjs7cm90YXRlIHRvIHJlYWwgb3BlcmF0ZSBrZXlzZXRcXG4oZGVmaW5lLWtleXNldCAnbnMtb3BlcmF0ZS1rZXlzZXQgKHJlYWQta2V5c2V0ICducy1vcGVyYXRlLWtleXNldCkpXFxuXCJ9fSxcInNpZ25lcnNcIjpbXSxcIm1ldGFcIjp7XCJjcmVhdGlvblRpbWVcIjowLFwidHRsXCI6MTcyODAwLFwiZ2FzTGltaXRcIjowLFwiY2hhaW5JZFwiOlwiXCIsXCJnYXNQcmljZVwiOjAsXCJzZW5kZXJcIjpcIlwifSxcIm5vbmNlXCI6XCJsb2FkLW5zLWRldm5ldC1zZW5kZXIwMFwifSJ9", unsafeFromText "eyJnYXMiOjAsInJlc3VsdCI6eyJzdGF0dXMiOiJzdWNjZXNzIiwiZGF0YSI6IktleXNldCB3cml0ZSBzdWNjZXNzIn0sInJlcUtleSI6IkNabXlsV2ZpZVJNQk11NXcyRU9tcEZ3Sy10N2JjT1RzNG1LMmFUMzN1UjQiLCJsb2dzIjoidDdzQzg1Y1hlWFdSdG90M1lEb2pSejZibWtncEN6enJQQ0Z6QThzTkg3OCIsIm1ldGFEYXRhIjpudWxsLCJjb250aW51YXRpb24iOm51bGwsInR4SWQiOjV9") + , (unsafeFromText "eyJoYXNoIjoiWE5BNmxPSjFXLTdYWXY1WWI0QXFsNzRveFlJN09KcWpPUVQ1b1k0OHEtZyIsInNpZ3MiOltdLCJjbWQiOiJ7XCJuZXR3b3JrSWRcIjpudWxsLFwicGF5bG9hZFwiOntcImV4ZWNcIjp7XCJkYXRhXCI6e1wiYWxsb2NhdGlvbi10ZXN0MDFcIjpbXCI3MDExYzM3OTE0MGZmODk5ZjdlNjEzYWMwYTk3ODRhN2MwYTUxNWQzMGZlMGFiMmIwYzA3ZTVhYTE3NjM1ZTNlXCJdLFwiYWxsb2NhdGlvbjAyXCI6W1wiZTllNGU3MWJkMDYzZGNmN2UwNmJkNWIxYTE2Njg4ODk3ZDE1Y2E4YmQyZTUwOWM0NTNjNjE2MjE5YzE4NmNjNVwiXSxcImFsbG9jYXRpb24wMFwiOltcImQ4MmQwZGNkZTk4MjU1MDVkODZhZmI2ZGNjMTA0MTFkNmI2N2E0MjlhNzllMjFiZGE0YmIxMTliZjI4YWI4NzFcIl0sXCJhbGxvY2F0aW9uLXRlc3QwMlwiOltcIjA2NTQ0ZTIyYmZlZjIzMGQ2ZDIyZjk0ODZhYzZjYjc2YmYyNThlYmZiZjAxMzdlZTU4ZjY1NzQzZTFhNWI4YzRcIl0sXCJhbGxvY2F0aW9uMDFcIjpbXCJiNGM4YTNlYTkxZDMxNDZiMDU2MDk5NDc0MGYwZTNlZWQ5MWM1OWQyZWVjYTFkYzk5ZjBjMjg3Mjg0NWMyOTRkXCJdfSxcImNvZGVcIjpcIihkZWZpbmUta2V5c2V0IFxcXCJhbGxvY2F0aW9uMDBcXFwiIChyZWFkLWtleXNldCBcXFwiYWxsb2NhdGlvbjAwXFxcIikpXFxuKGRlZmluZS1rZXlzZXQgXFxcImFsbG9jYXRpb24wMVxcXCIgKHJlYWQta2V5c2V0IFxcXCJhbGxvY2F0aW9uMDFcXFwiKSlcXG4oZGVmaW5lLWtleXNldCBcXFwiYWxsb2NhdGlvbjAyXFxcIiAocmVhZC1rZXlzZXQgXFxcImFsbG9jYXRpb24wMlxcXCIpKVxcbihkZWZpbmUta2V5c2V0IFxcXCJhbGxvY2F0aW9uLXRlc3QwMVxcXCIgKHJlYWQta2V5c2V0IFxcXCJhbGxvY2F0aW9uLXRlc3QwMVxcXCIpKVxcbihkZWZpbmUta2V5c2V0IFxcXCJhbGxvY2F0aW9uLXRlc3QwMlxcXCIgKHJlYWQta2V5c2V0IFxcXCJhbGxvY2F0aW9uLXRlc3QwMlxcXCIpKVwifX0sXCJzaWduZXJzXCI6W10sXCJtZXRhXCI6e1wiY3JlYXRpb25UaW1lXCI6MCxcInR0bFwiOjE3MjgwMCxcImdhc0xpbWl0XCI6MCxcImNoYWluSWRcIjpcIlwiLFwiZ2FzUHJpY2VcIjowLFwic2VuZGVyXCI6XCJcIn0sXCJub25jZVwiOlwiZGV2bmV0LWtleXNldHNcIn0ifQ", unsafeFromText "eyJnYXMiOjAsInJlc3VsdCI6eyJzdGF0dXMiOiJzdWNjZXNzIiwiZGF0YSI6IktleXNldCB3cml0ZSBzdWNjZXNzIn0sInJlcUtleSI6IlhOQTZsT0oxVy03WFl2NVliNEFxbDc0b3hZSTdPSnFqT1FUNW9ZNDhxLWciLCJsb2dzIjoiYXJRSWpQVGRrcXhoQTNjWl9WaVE3OXM3Uk5XRTlGV2Rha0xWdXl4Nlc0YyIsIm1ldGFEYXRhIjpudWxsLCJjb250aW51YXRpb24iOm51bGwsInR4SWQiOjZ9") + , (unsafeFromText "eyJoYXNoIjoiNWtxZ0tzWWtwbjZCcS1KUnhNYnA1VG9jUWhRWGRJVVNiM1NGQm1Ba3VWcyIsInNpZ3MiOltdLCJjbWQiOiJ7XCJuZXR3b3JrSWRcIjpudWxsLFwicGF5bG9hZFwiOntcImV4ZWNcIjp7XCJkYXRhXCI6bnVsbCxcImNvZGVcIjpcIihjb2luLmNyZWF0ZS1hbGxvY2F0aW9uLWFjY291bnQgXFxcImFsbG9jYXRpb24wMFxcXCIgKHRpbWUgXFxcIjE5MDAtMTAtMTVUMTg6MDA6MDBaXFxcIikgXFxcImFsbG9jYXRpb24wMFxcXCIgMTAwMDAwMC4wKVxcbihjb2luLmNyZWF0ZS1hbGxvY2F0aW9uLWFjY291bnQgXFxcImFsbG9jYXRpb24wMVxcXCIgKHRpbWUgXFxcIjIxMDAtMTAtMzFUMTg6MDA6MDBaXFxcIikgXFxcImFsbG9jYXRpb24wMVxcXCIgMTAwMDAwMC4wKVxcbihjb2luLmNyZWF0ZS1hbGxvY2F0aW9uLWFjY291bnQgXFxcImFsbG9jYXRpb24wMlxcXCIgKHRpbWUgXFxcIjE5MDAtMTAtMzFUMTg6MDA6MDBaXFxcIikgXFxcImFsbG9jYXRpb24wMlxcXCIgMTAwMDAwMC4wKVxcbihjb2luLmNyZWF0ZS1hbGxvY2F0aW9uLWFjY291bnQgXFxcImFsbG9jYXRpb24tdGVzdDAxXFxcIiAodGltZSBcXFwiMTkwMC0xMC0zMVQxODowMDowMFpcXFwiKSBcXFwiYWxsb2NhdGlvbi10ZXN0MDFcXFwiIDEwMDAwMDAuMClcXG4oY29pbi5jcmVhdGUtYWxsb2NhdGlvbi1hY2NvdW50IFxcXCJhbGxvY2F0aW9uLXRlc3QwMlxcXCIgKHRpbWUgXFxcIjE5MDAtMTAtMzFUMTg6MDA6MDBaXFxcIikgXFxcImFsbG9jYXRpb24tdGVzdDAyXFxcIiAyMDAwMDAwLjApXCJ9fSxcInNpZ25lcnNcIjpbXSxcIm1ldGFcIjp7XCJjcmVhdGlvblRpbWVcIjowLFwidHRsXCI6MTcyODAwLFwiZ2FzTGltaXRcIjowLFwiY2hhaW5JZFwiOlwiXCIsXCJnYXNQcmljZVwiOjAsXCJzZW5kZXJcIjpcIlwifSxcIm5vbmNlXCI6XCJkZXZuZXQtYWxsb2NhdGlvbnNcIn0ifQ", unsafeFromText "eyJnYXMiOjAsInJlc3VsdCI6eyJzdGF0dXMiOiJzdWNjZXNzIiwiZGF0YSI6IldyaXRlIHN1Y2NlZWRlZCJ9LCJyZXFLZXkiOiI1a3FnS3NZa3BuNkJxLUpSeE1icDVUb2NRaFFYZElVU2IzU0ZCbUFrdVZzIiwibG9ncyI6IkhpX3ZfVEhFT2s2aEJFRU0yWmV2Vzh3eVJsQWpUZzNjVUQydXBlVkx0b1UiLCJtZXRhRGF0YSI6bnVsbCwiY29udGludWF0aW9uIjpudWxsLCJ0eElkIjo3fQ") + , (unsafeFromText "eyJoYXNoIjoibWd3Z3lCdTRGS3NEQ042Q3dWOEJNcFdNcnBwb2UtVkJKYTFYRjktLTFQRSIsInNpZ3MiOltdLCJjbWQiOiJ7XCJuZXR3b3JrSWRcIjpudWxsLFwicGF5bG9hZFwiOntcImV4ZWNcIjp7XCJkYXRhXCI6e1wic2VuZGVyMDdcIjpbXCI0YzMxZGM5ZWU3ZjI0MTc3Zjc4YjZmNTE4MDEyYTIwODMyNmUyYWYxZjM3YmIwYTI0MDViNTA1NmQwY2FkNjI4XCJdLFwic2VuZGVyMDFcIjpbXCI2YmUyZjQ4NWE3YWY3NWZlZGI0YjdmMTUzYTkwM2Y3ZTYwMDBjYTRhYTUwMTE3OWM5MWEyNDUwYjc3N2JkMmE3XCJdLFwic2VuZGVyMDZcIjpbXCI1ZmZjMWY3ZmVmN2E0NDczODYyNTc2MmY3NWE0MjI5NDU0OTUxZTAzZjJhZmM2ZjgxMzA5YzBjMWJkZjllZTZmXCJdLFwic2VuZGVyMDBcIjpbXCIzNjg4MjBmODBjMzI0YmJjN2MyYjA2MTA2ODhhN2RhNDNlMzlmOTFkMTE4NzMyNjcxY2Q5Yzc1MDBmZjQzY2NhXCJdLFwiZTdmN1wiOltcImU3Zjc2MzRlOTI1NTQxZjM2OGI4MjdhZDVjNzI0MjE5MDUxMDBmNjIwNTI4NWE3OGMxOWQ3YjRhMzg3MTE4MDVcIl0sXCJzZW5kZXIwNVwiOltcImYwOWQ4ZjYzOTRhZWE0MjVmZTY3ODNkODhjZDgxMzYzZDgwMTdmMTZhZmQzNzExYzU3NWJlMGY1Y2Q1YzliYjlcIl0sXCJzZW5kZXIwNFwiOltcIjJkNzBhYTRmNjk3YzNhM2I4ZGQ2ZDk3NzQ1YWMwNzRlZGNmZDBlYjY1YzM3Nzc0Y2RlMjUxMzU0ODNiZWE3MWVcIl0sXCJtdWx0aS0wMi0wMy0wNC1hbnlcIjp7XCJwcmVkXCI6XCJrZXlzLWFueVwiLFwia2V5c1wiOltcIjJkNzBhYTRmNjk3YzNhM2I4ZGQ2ZDk3NzQ1YWMwNzRlZGNmZDBlYjY1YzM3Nzc0Y2RlMjUxMzU0ODNiZWE3MWVcIixcIjNhOWRkNTMyZDczZGFjZTE5NWRiYjY0ZDFkYmE2NTcyZmI3ODNkMGZkZDMyNDY4NWUzMmZiZGEyZjg5Zjk5YTZcIixcIjQzZjJhZGIxZGUxOTIwMDBjYjM3NzdiYWNjN2Y5ODNiNjYxNGZkOWMxNzE1Y2Q0NGNkNDg0YjZkM2EwZDM0YzhcIl19LFwic2VuZGVyMDlcIjpbXCJjNTlkOTg0MGIwYjY2MDkwODM2NTQ2YjdlYjRhNzM2MDYyNTc1MjdlYzhjMmI0ODIzMDBmZDIyOTI2NGIwN2U2XCJdLFwic2VuZGVyMDNcIjpbXCI0M2YyYWRiMWRlMTkyMDAwY2IzNzc3YmFjYzdmOTgzYjY2MTRmZDljMTcxNWNkNDRjZDQ4NGI2ZDNhMGQzNGM4XCJdLFwibXVsdGktMDAtMDFcIjpbXCIzNjg4MjBmODBjMzI0YmJjN2MyYjA2MTA2ODhhN2RhNDNlMzlmOTFkMTE4NzMyNjcxY2Q5Yzc1MDBmZjQzY2NhXCIsXCI2YmUyZjQ4NWE3YWY3NWZlZGI0YjdmMTUzYTkwM2Y3ZTYwMDBjYTRhYTUwMTE3OWM5MWEyNDUwYjc3N2JkMmE3XCJdLFwic2VuZGVyMDhcIjpbXCI2M2IyZWJhNGVkNzBkNDYxMmQzZTdiYzkwZGIyZmJmNGM3NmY3YjA3NDM2M2U4NmQ3M2YwYmM2MTdmOGU4YjgxXCJdLFwic2VuZGVyMDJcIjpbXCIzYTlkZDUzMmQ3M2RhY2UxOTVkYmI2NGQxZGJhNjU3MmZiNzgzZDBmZGQzMjQ2ODVlMzJmYmRhMmY4OWY5OWE2XCJdfSxcImNvZGVcIjpcIihjb2luLmNvaW5iYXNlIFxcXCJzZW5kZXIwMFxcXCIgKHJlYWQta2V5c2V0IFxcXCJzZW5kZXIwMFxcXCIpIDEwMDAwMDAwMC4wKVxcbihjb2luLmNvaW5iYXNlIFxcXCJzZW5kZXIwMVxcXCIgKHJlYWQta2V5c2V0IFxcXCJzZW5kZXIwMVxcXCIpIDExMDAwMDAwMC4wKVxcbihjb2luLmNvaW5iYXNlIFxcXCJzZW5kZXIwMlxcXCIgKHJlYWQta2V5c2V0IFxcXCJzZW5kZXIwMlxcXCIpIDEyMDAwMDAwMC4wKVxcbihjb2luLmNvaW5iYXNlIFxcXCJzZW5kZXIwM1xcXCIgKHJlYWQta2V5c2V0IFxcXCJzZW5kZXIwM1xcXCIpIDEzMDAwMDAwMC4wKVxcbihjb2luLmNvaW5iYXNlIFxcXCJzZW5kZXIwNFxcXCIgKHJlYWQta2V5c2V0IFxcXCJzZW5kZXIwNFxcXCIpIDE0MDAwMDAwMC4wKVxcbihjb2luLmNvaW5iYXNlIFxcXCJzZW5kZXIwNVxcXCIgKHJlYWQta2V5c2V0IFxcXCJzZW5kZXIwNVxcXCIpIDE1MDAwMDAwMC4wKVxcbihjb2luLmNvaW5iYXNlIFxcXCJzZW5kZXIwNlxcXCIgKHJlYWQta2V5c2V0IFxcXCJzZW5kZXIwNlxcXCIpIDE2MDAwMDAwMC4wKVxcbihjb2luLmNvaW5iYXNlIFxcXCJzZW5kZXIwN1xcXCIgKHJlYWQta2V5c2V0IFxcXCJzZW5kZXIwN1xcXCIpIDE3MDAwMDAwMC4wKVxcbihjb2luLmNvaW5iYXNlIFxcXCJzZW5kZXIwOFxcXCIgKHJlYWQta2V5c2V0IFxcXCJzZW5kZXIwOFxcXCIpIDE4MDAwMDAwMC4wKVxcbihjb2luLmNvaW5iYXNlIFxcXCJzZW5kZXIwOVxcXCIgKHJlYWQta2V5c2V0IFxcXCJzZW5kZXIwOVxcXCIpIDE5MDAwMDAwMC4wKVxcbihjb2luLmNvaW5iYXNlIFxcXCJtdWx0aS0wMC0wMVxcXCIgKHJlYWQta2V5c2V0IFxcXCJtdWx0aS0wMC0wMVxcXCIpIDEwMTAwMDAwMC4wKVxcbihjb2luLmNvaW5iYXNlIFxcXCJtdWx0aS0wMi0wMy0wNC1hbnlcXFwiIChyZWFkLWtleXNldCBcXFwibXVsdGktMDItMDMtMDQtYW55XFxcIikgMTIzNDAwMDAwLjApXFxuXFxuKGNvaW4uY29pbmJhc2UgXFxcImU3Zjc2MzRlOTI1NTQxZjM2OGI4MjdhZDVjNzI0MjE5MDUxMDBmNjIwNTI4NWE3OGMxOWQ3YjRhMzg3MTE4MDVcXFwiIChyZWFkLWtleXNldCBcXFwiZTdmN1xcXCIpIDE1MC4wKVwifX0sXCJzaWduZXJzXCI6W10sXCJtZXRhXCI6e1wiY3JlYXRpb25UaW1lXCI6MCxcInR0bFwiOjE3MjgwMCxcImdhc0xpbWl0XCI6MCxcImNoYWluSWRcIjpcIlwiLFwiZ2FzUHJpY2VcIjowLFwic2VuZGVyXCI6XCJcIn0sXCJub25jZVwiOlwiZGV2bmV0LWdyYW50c05cIn0ifQ", unsafeFromText "eyJnYXMiOjAsInJlc3VsdCI6eyJzdGF0dXMiOiJzdWNjZXNzIiwiZGF0YSI6IldyaXRlIHN1Y2NlZWRlZCJ9LCJyZXFLZXkiOiJtZ3dneUJ1NEZLc0RDTjZDd1Y4Qk1wV01ycHBvZS1WQkphMVhGOS0tMVBFIiwibG9ncyI6IkF3MTVuVFF0YmlQYlVCQm1reGpRV09JZlc3ZHNfUi1sWjhNMGZDMXAxZHciLCJldmVudHMiOlt7InBhcmFtcyI6WyIiLCJzZW5kZXIwMCIsMTAwMDAwMDAwXSwibmFtZSI6IlRSQU5TRkVSIiwibW9kdWxlIjp7Im5hbWVzcGFjZSI6bnVsbCwibmFtZSI6ImNvaW4ifSwibW9kdWxlSGFzaCI6IjNpSUJRZEpuc3Q0NFoyWmdYb0hQa0FhdXliSjBoODVsX2VuX1NHSE5pYkUifSx7InBhcmFtcyI6WyIiLCJzZW5kZXIwMSIsMTEwMDAwMDAwXSwibmFtZSI6IlRSQU5TRkVSIiwibW9kdWxlIjp7Im5hbWVzcGFjZSI6bnVsbCwibmFtZSI6ImNvaW4ifSwibW9kdWxlSGFzaCI6IjNpSUJRZEpuc3Q0NFoyWmdYb0hQa0FhdXliSjBoODVsX2VuX1NHSE5pYkUifSx7InBhcmFtcyI6WyIiLCJzZW5kZXIwMiIsMTIwMDAwMDAwXSwibmFtZSI6IlRSQU5TRkVSIiwibW9kdWxlIjp7Im5hbWVzcGFjZSI6bnVsbCwibmFtZSI6ImNvaW4ifSwibW9kdWxlSGFzaCI6IjNpSUJRZEpuc3Q0NFoyWmdYb0hQa0FhdXliSjBoODVsX2VuX1NHSE5pYkUifSx7InBhcmFtcyI6WyIiLCJzZW5kZXIwMyIsMTMwMDAwMDAwXSwibmFtZSI6IlRSQU5TRkVSIiwibW9kdWxlIjp7Im5hbWVzcGFjZSI6bnVsbCwibmFtZSI6ImNvaW4ifSwibW9kdWxlSGFzaCI6IjNpSUJRZEpuc3Q0NFoyWmdYb0hQa0FhdXliSjBoODVsX2VuX1NHSE5pYkUifSx7InBhcmFtcyI6WyIiLCJzZW5kZXIwNCIsMTQwMDAwMDAwXSwibmFtZSI6IlRSQU5TRkVSIiwibW9kdWxlIjp7Im5hbWVzcGFjZSI6bnVsbCwibmFtZSI6ImNvaW4ifSwibW9kdWxlSGFzaCI6IjNpSUJRZEpuc3Q0NFoyWmdYb0hQa0FhdXliSjBoODVsX2VuX1NHSE5pYkUifSx7InBhcmFtcyI6WyIiLCJzZW5kZXIwNSIsMTUwMDAwMDAwXSwibmFtZSI6IlRSQU5TRkVSIiwibW9kdWxlIjp7Im5hbWVzcGFjZSI6bnVsbCwibmFtZSI6ImNvaW4ifSwibW9kdWxlSGFzaCI6IjNpSUJRZEpuc3Q0NFoyWmdYb0hQa0FhdXliSjBoODVsX2VuX1NHSE5pYkUifSx7InBhcmFtcyI6WyIiLCJzZW5kZXIwNiIsMTYwMDAwMDAwXSwibmFtZSI6IlRSQU5TRkVSIiwibW9kdWxlIjp7Im5hbWVzcGFjZSI6bnVsbCwibmFtZSI6ImNvaW4ifSwibW9kdWxlSGFzaCI6IjNpSUJRZEpuc3Q0NFoyWmdYb0hQa0FhdXliSjBoODVsX2VuX1NHSE5pYkUifSx7InBhcmFtcyI6WyIiLCJzZW5kZXIwNyIsMTcwMDAwMDAwXSwibmFtZSI6IlRSQU5TRkVSIiwibW9kdWxlIjp7Im5hbWVzcGFjZSI6bnVsbCwibmFtZSI6ImNvaW4ifSwibW9kdWxlSGFzaCI6IjNpSUJRZEpuc3Q0NFoyWmdYb0hQa0FhdXliSjBoODVsX2VuX1NHSE5pYkUifSx7InBhcmFtcyI6WyIiLCJzZW5kZXIwOCIsMTgwMDAwMDAwXSwibmFtZSI6IlRSQU5TRkVSIiwibW9kdWxlIjp7Im5hbWVzcGFjZSI6bnVsbCwibmFtZSI6ImNvaW4ifSwibW9kdWxlSGFzaCI6IjNpSUJRZEpuc3Q0NFoyWmdYb0hQa0FhdXliSjBoODVsX2VuX1NHSE5pYkUifSx7InBhcmFtcyI6WyIiLCJzZW5kZXIwOSIsMTkwMDAwMDAwXSwibmFtZSI6IlRSQU5TRkVSIiwibW9kdWxlIjp7Im5hbWVzcGFjZSI6bnVsbCwibmFtZSI6ImNvaW4ifSwibW9kdWxlSGFzaCI6IjNpSUJRZEpuc3Q0NFoyWmdYb0hQa0FhdXliSjBoODVsX2VuX1NHSE5pYkUifSx7InBhcmFtcyI6WyIiLCJtdWx0aS0wMC0wMSIsMTAxMDAwMDAwXSwibmFtZSI6IlRSQU5TRkVSIiwibW9kdWxlIjp7Im5hbWVzcGFjZSI6bnVsbCwibmFtZSI6ImNvaW4ifSwibW9kdWxlSGFzaCI6IjNpSUJRZEpuc3Q0NFoyWmdYb0hQa0FhdXliSjBoODVsX2VuX1NHSE5pYkUifSx7InBhcmFtcyI6WyIiLCJtdWx0aS0wMi0wMy0wNC1hbnkiLDEyMzQwMDAwMF0sIm5hbWUiOiJUUkFOU0ZFUiIsIm1vZHVsZSI6eyJuYW1lc3BhY2UiOm51bGwsIm5hbWUiOiJjb2luIn0sIm1vZHVsZUhhc2giOiIzaUlCUWRKbnN0NDRaMlpnWG9IUGtBYXV5YkowaDg1bF9lbl9TR0hOaWJFIn0seyJwYXJhbXMiOlsiIiwiZTdmNzYzNGU5MjU1NDFmMzY4YjgyN2FkNWM3MjQyMTkwNTEwMGY2MjA1Mjg1YTc4YzE5ZDdiNGEzODcxMTgwNSIsMTUwXSwibmFtZSI6IlRSQU5TRkVSIiwibW9kdWxlIjp7Im5hbWVzcGFjZSI6bnVsbCwibmFtZSI6ImNvaW4ifSwibW9kdWxlSGFzaCI6IjNpSUJRZEpuc3Q0NFoyWmdYb0hQa0FhdXliSjBoODVsX2VuX1NHSE5pYkUifV0sIm1ldGFEYXRhIjpudWxsLCJjb250aW51YXRpb24iOm51bGwsInR4SWQiOjh9") + ] diff --git a/src/Chainweb/BlockHeader/Genesis/QuirkedGasPact5InstantTimedCPM0Payload.hs b/src/Chainweb/BlockHeader/Genesis/QuirkedGasPact5InstantTimedCPM0Payload.hs index ee608e1470..9ddc46c0c0 100644 --- a/src/Chainweb/BlockHeader/Genesis/QuirkedGasPact5InstantTimedCPM0Payload.hs +++ b/src/Chainweb/BlockHeader/Genesis/QuirkedGasPact5InstantTimedCPM0Payload.hs @@ -8,7 +8,7 @@ import qualified Data.Text as T import qualified Data.Vector as V import GHC.Stack -import Chainweb.Payload +import Chainweb.Pact.Payload import Chainweb.Utils (unsafeFromText, toText) payloadBlock :: HasCallStack => PayloadWithOutputs @@ -21,19 +21,19 @@ payloadBlock where actualHash, expectedHash :: BlockPayloadHash actualHash = _payloadWithOutputsPayloadHash payload - expectedHash = unsafeFromText "xkWm_gAq2hok8YgyecdTx7tkwQ7rzu7O6bEeSuDk1ac" + expectedHash = unsafeFromText "1I4CRQ2BGFZEFr7_X_U1hMPPZI4YMbfxEr6cyrRYlsA" payload = newPayloadWithOutputs minerData coinbase txs minerData = unsafeFromText "eyJhY2NvdW50IjoiTm9NaW5lciIsInByZWRpY2F0ZSI6IjwiLCJwdWJsaWMta2V5cyI6W119" coinbase = unsafeFromText "eyJnYXMiOjAsInJlc3VsdCI6eyJzdGF0dXMiOiJzdWNjZXNzIiwiZGF0YSI6Ik5PX0NPSU5CQVNFIn0sInJlcUtleSI6IkRsZFJ3Q2JsUTdMb3F5NndZSm5hb2RIbDMwZDNqM2VILXF0RnpmRXY0NmciLCJsb2dzIjpudWxsLCJtZXRhRGF0YSI6bnVsbCwiY29udGludWF0aW9uIjpudWxsLCJ0eElkIjpudWxsfQ" txs = V.fromList - [ (unsafeFromText "eyJoYXNoIjoiNDhUMExqQW5TRnBGV3h2dmFQVi1fNkUtQ2pEQVBoV1lVRldidnlmMmxGcyIsInNpZ3MiOltdLCJjbWQiOiJ7XCJuZXR3b3JrSWRcIjpudWxsLFwicGF5bG9hZFwiOntcImV4ZWNcIjp7XCJkYXRhXCI6bnVsbCxcImNvZGVcIjpcIihpbnRlcmZhY2UgZnVuZ2libGUtdjFcXG5cXG4gIFxcXCIgU3RhbmRhcmQgZm9yIGZ1bmdpYmxlIGNvaW5zIGFuZCB0b2tlbnMgYXMgc3BlY2lmaWVkIGluIEtJUC0wMDAyLiBcXFwiXFxuXFxuICAgOyAtLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tXFxuICAgOyBTY2hlbWFcXG5cXG4gICAoZGVmc2NoZW1hIGFjY291bnQtZGV0YWlsc1xcbiAgICBAZG9jIFxcXCJTY2hlbWEgZm9yIHJlc3VsdHMgb2YgJ2FjY291bnQnIG9wZXJhdGlvbi5cXFwiXFxuICAgIEBtb2RlbCBbIChpbnZhcmlhbnQgKCE9IFxcXCJcXFwiIHNlbmRlcikpIF1cXG5cXG4gICAgYWNjb3VudDpzdHJpbmdcXG4gICAgYmFsYW5jZTpkZWNpbWFsXFxuICAgIGd1YXJkOmd1YXJkKVxcblxcblxcbiAgIDsgLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLVxcbiAgIDsgQ2Fwc1xcblxcbiAgIChkZWZjYXAgVFJBTlNGRVI6Ym9vbFxcbiAgICAgKCBzZW5kZXI6c3RyaW5nXFxuICAgICAgIHJlY2VpdmVyOnN0cmluZ1xcbiAgICAgICBhbW91bnQ6ZGVjaW1hbFxcbiAgICAgKVxcbiAgICAgQGRvYyBcXFwiIE1hbmFnZWQgY2FwYWJpbGl0eSBzZWFsaW5nIEFNT1VOVCBmb3IgdHJhbnNmZXIgZnJvbSBTRU5ERVIgdG8gXFxcXFxcbiAgICAgICAgICBcXFxcIFJFQ0VJVkVSLiBQZXJtaXRzIGFueSBudW1iZXIgb2YgdHJhbnNmZXJzIHVwIHRvIEFNT1VOVC5cXFwiXFxuICAgICBAbWFuYWdlZCBhbW91bnQgVFJBTlNGRVItbWdyXFxuICAgICApXFxuXFxuICAgKGRlZnVuIFRSQU5TRkVSLW1ncjpkZWNpbWFsXFxuICAgICAoIG1hbmFnZWQ6ZGVjaW1hbFxcbiAgICAgICByZXF1ZXN0ZWQ6ZGVjaW1hbFxcbiAgICAgKVxcbiAgICAgQGRvYyBcXFwiIE1hbmFnZXMgVFJBTlNGRVIgQU1PVU5UIGxpbmVhcmx5LCBcXFxcXFxuICAgICAgICAgIFxcXFwgc3VjaCB0aGF0IGEgcmVxdWVzdCBmb3IgMS4wIGFtb3VudCBvbiBhIDMuMCBcXFxcXFxuICAgICAgICAgIFxcXFwgbWFuYWdlZCBxdWFudGl0eSBlbWl0cyB1cGRhdGVkIGFtb3VudCAyLjAuXFxcIlxcbiAgICAgKVxcblxcbiAgIDsgLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLVxcbiAgIDsgRnVuY3Rpb25hbGl0eVxcblxcbiAgIChkZWZ1biB0cmFuc2Zlci1jcmVhdGU6c3RyaW5nXFxuICAgICAoIHNlbmRlcjpzdHJpbmdcXG4gICAgICAgcmVjZWl2ZXI6c3RyaW5nXFxuICAgICAgIHJlY2VpdmVyLWd1YXJkOmd1YXJkXFxuICAgICAgIGFtb3VudDpkZWNpbWFsXFxuICAgICApXFxuICAgICBAZG9jIFxcXCIgVHJhbnNmZXIgQU1PVU5UIGJldHdlZW4gYWNjb3VudHMgU0VOREVSIGFuZCBSRUNFSVZFUi4gXFxcXFxcbiAgICAgICAgICBcXFxcIEZhaWxzIGlmIFNFTkRFUiBkb2VzIG5vdCBleGlzdC4gSWYgUkVDRUlWRVIgZXhpc3RzLCBndWFyZCBcXFxcXFxuICAgICAgICAgIFxcXFwgbXVzdCBtYXRjaCBleGlzdGluZyB2YWx1ZS4gSWYgUkVDRUlWRVIgZG9lcyBub3QgZXhpc3QsIFxcXFxcXG4gICAgICAgICAgXFxcXCBSRUNFSVZFUiBhY2NvdW50IGlzIGNyZWF0ZWQgdXNpbmcgUkVDRUlWRVItR1VBUkQuIFxcXFxcXG4gICAgICAgICAgXFxcXCBTdWJqZWN0IHRvIG1hbmFnZW1lbnQgYnkgVFJBTlNGRVIgY2FwYWJpbGl0eS5cXFwiXFxuICAgICBAbW9kZWwgWyAocHJvcGVydHkgKD4gYW1vdW50IDAuMCkpXFxuICAgICAgICAgICAgICAocHJvcGVydHkgKCE9IHNlbmRlciBcXFwiXFxcIikpXFxuICAgICAgICAgICAgICAocHJvcGVydHkgKCE9IHJlY2VpdmVyIFxcXCJcXFwiKSlcXG4gICAgICAgICAgICAgIChwcm9wZXJ0eSAoIT0gc2VuZGVyIHJlY2VpdmVyKSlcXG4gICAgICAgICAgICBdXFxuICAgICApXFxuXFxuICAgKGRlZnBhY3QgdHJhbnNmZXItY3Jvc3NjaGFpbjpzdHJpbmdcXG4gICAgICggc2VuZGVyOnN0cmluZ1xcbiAgICAgICByZWNlaXZlcjpzdHJpbmdcXG4gICAgICAgcmVjZWl2ZXItZ3VhcmQ6Z3VhcmRcXG4gICAgICAgdGFyZ2V0LWNoYWluOnN0cmluZ1xcbiAgICAgICBhbW91bnQ6ZGVjaW1hbFxcbiAgICAgKVxcbiAgICAgQGRvYyBcXFwiIDItc3RlcCBwYWN0IHRvIHRyYW5zZmVyIEFNT1VOVCBmcm9tIFNFTkRFUiBvbiBjdXJyZW50IGNoYWluIFxcXFxcXG4gICAgICAgICAgXFxcXCB0byBSRUNFSVZFUiBvbiBUQVJHRVQtQ0hBSU4gdmlhIFNQViBwcm9vZi4gXFxcXFxcbiAgICAgICAgICBcXFxcIFRBUkdFVC1DSEFJTiBtdXN0IGJlIGRpZmZlcmVudCB0aGFuIGN1cnJlbnQgY2hhaW4gaWQuIFxcXFxcXG4gICAgICAgICAgXFxcXCBGaXJzdCBzdGVwIGRlYml0cyBBTU9VTlQgY29pbnMgaW4gU0VOREVSIGFjY291bnQgYW5kIHlpZWxkcyBcXFxcXFxuICAgICAgICAgIFxcXFwgUkVDRUlWRVIsIFJFQ0VJVkVSX0dVQVJEIGFuZCBBTU9VTlQgdG8gVEFSR0VULUNIQUlOLiBcXFxcXFxuICAgICAgICAgIFxcXFwgU2Vjb25kIHN0ZXAgY29udGludWF0aW9uIGlzIHNlbnQgaW50byBUQVJHRVQtQ0hBSU4gd2l0aCBwcm9vZiBcXFxcXFxuICAgICAgICAgIFxcXFwgb2J0YWluZWQgZnJvbSB0aGUgc3B2ICdvdXRwdXQnIGVuZHBvaW50IG9mIENoYWlud2ViLiBcXFxcXFxuICAgICAgICAgIFxcXFwgUHJvb2YgaXMgdmFsaWRhdGVkIGFuZCBSRUNFSVZFUiBpcyBjcmVkaXRlZCB3aXRoIEFNT1VOVCBcXFxcXFxuICAgICAgICAgIFxcXFwgY3JlYXRpbmcgYWNjb3VudCB3aXRoIFJFQ0VJVkVSX0dVQVJEIGFzIG5lY2Vzc2FyeS5cXFwiXFxuICAgICBAbW9kZWwgWyAocHJvcGVydHkgKD4gYW1vdW50IDAuMCkpXFxuICAgICAgICAgICAgICAocHJvcGVydHkgKCE9IHNlbmRlciBcXFwiXFxcIikpXFxuICAgICAgICAgICAgICAocHJvcGVydHkgKCE9IHJlY2VpdmVyIFxcXCJcXFwiKSlcXG4gICAgICAgICAgICAgIChwcm9wZXJ0eSAoIT0gc2VuZGVyIHJlY2VpdmVyKSlcXG4gICAgICAgICAgICAgIChwcm9wZXJ0eSAoIT0gdGFyZ2V0LWNoYWluIFxcXCJcXFwiKSlcXG4gICAgICAgICAgICBdXFxuICAgICApXFxuXFxuICAgKGRlZnVuIGdldC1iYWxhbmNlOmRlY2ltYWxcXG4gICAgICggYWNjb3VudDpzdHJpbmcgKVxcbiAgICAgXFxcIiBHZXQgYmFsYW5jZSBmb3IgQUNDT1VOVC4gRmFpbHMgaWYgYWNjb3VudCBkb2VzIG5vdCBleGlzdC5cXFwiXFxuICAgICApXFxuXFxuICAgKGRlZnVuIGRldGFpbHM6b2JqZWN0e2FjY291bnQtZGV0YWlsc31cXG4gICAgICggYWNjb3VudDogc3RyaW5nIClcXG4gICAgIFxcXCIgR2V0IGFuIG9iamVjdCB3aXRoIGRldGFpbHMgb2YgQUNDT1VOVC4gXFxcXFxcbiAgICAgXFxcXCBGYWlscyBpZiBhY2NvdW50IGRvZXMgbm90IGV4aXN0LlxcXCJcXG4gICAgIClcXG5cXG4gICAoZGVmdW4gcHJlY2lzaW9uOmludGVnZXJcXG4gICAgICgpXFxuICAgICBcXFwiUmV0dXJuIHRoZSBtYXhpbXVtIGFsbG93ZWQgZGVjaW1hbCBwcmVjaXNpb24uXFxcIlxcbiAgICAgKVxcblxcbiAgIChkZWZ1biBlbmZvcmNlLXVuaXQ6Ym9vbFxcbiAgICAgKCBhbW91bnQ6ZGVjaW1hbCApXFxuICAgICBcXFwiIEVuZm9yY2UgbWluaW11bSBwcmVjaXNpb24gYWxsb3dlZCBmb3IgdHJhbnNhY3Rpb25zLlxcXCJcXG4gICAgIClcXG5cXG4gICAoZGVmdW4gY3JlYXRlLWFjY291bnQ6c3RyaW5nXFxuICAgICAoIGFjY291bnQ6c3RyaW5nXFxuICAgICAgIGd1YXJkOmd1YXJkXFxuICAgICApXFxuICAgICBcXFwiIENyZWF0ZSBBQ0NPVU5UIHdpdGggMC4wIGJhbGFuY2UsIHdpdGggR1VBUkQgY29udHJvbGxpbmcgYWNjZXNzLlxcXCJcXG4gICAgIClcXG5cXG4gICAoZGVmdW4gcm90YXRlOnN0cmluZ1xcbiAgICAgKCBhY2NvdW50OnN0cmluZ1xcbiAgICAgICBuZXctZ3VhcmQ6Z3VhcmRcXG4gICAgIClcXG4gICAgIFxcXCIgUm90YXRlIGd1YXJkIGZvciBBQ0NPVU5ULiBUcmFuc2FjdGlvbiBpcyB2YWxpZGF0ZWQgYWdhaW5zdCBcXFxcXFxuICAgICBcXFxcIGV4aXN0aW5nIGd1YXJkIGJlZm9yZSBpbnN0YWxsaW5nIG5ldyBndWFyZC4gXFxcIlxcbiAgICAgKVxcblxcbilcXG5cIn19LFwic2lnbmVyc1wiOltdLFwibWV0YVwiOntcImNyZWF0aW9uVGltZVwiOjAsXCJ0dGxcIjoxNzI4MDAsXCJnYXNMaW1pdFwiOjAsXCJjaGFpbklkXCI6XCJcIixcImdhc1ByaWNlXCI6MCxcInNlbmRlclwiOlwiXCJ9LFwibm9uY2VcIjpcImdlbmVzaXMtMDFcIn0ifQ", unsafeFromText "eyJnYXMiOjEsInJlc3VsdCI6eyJzdGF0dXMiOiJzdWNjZXNzIiwiZGF0YSI6IkxvYWRlZCBpbnRlcmZhY2UgZnVuZ2libGUtdjEsIGhhc2ggTm1kUnRzekN3YWNqSEd5eUU5Tl9mbFFNUlJCaGNIVkZQNE9qaGlQZWoxRSJ9LCJyZXFLZXkiOiI0OFQwTGpBblNGcEZXeHZ2YVBWLV82RS1DakRBUGhXWVVGV2J2eWYybEZzIiwibG9ncyI6IlB3eDlycG9kS2prSGNPUlh2WFVRSUpjRVZRZDhPSXRNM0FlakNFRExMVXMiLCJtZXRhRGF0YSI6bnVsbCwiY29udGludWF0aW9uIjpudWxsLCJ0eElkIjowfQ") - , (unsafeFromText "eyJoYXNoIjoieW5ucDFYVVNSTjJrMUYwYTZ2dXM3RFp0SDZjcHN6MVhmX0d3V0xnTFhTTSIsInNpZ3MiOltdLCJjbWQiOiJ7XCJuZXR3b3JrSWRcIjpudWxsLFwicGF5bG9hZFwiOntcImV4ZWNcIjp7XCJkYXRhXCI6bnVsbCxcImNvZGVcIjpcIihpbnRlcmZhY2UgZnVuZ2libGUteGNoYWluLXYxXFxuXFxuICBcXFwiIFRoaXMgaW50ZXJmYWNlIG9mZmVycyBhIHN0YW5kYXJkIGNhcGFiaWxpdHkgZm9yIGNyb3NzLWNoYWluIFxcXFxcXG4gIFxcXFwgdHJhbnNmZXJzIGFuZCBhc3NvY2lhdGVkIGV2ZW50cy4gXFxcIlxcblxcbiAgKGRlZmNhcCBUUkFOU0ZFUl9YQ0hBSU46Ym9vbFxcbiAgICAoIHNlbmRlcjpzdHJpbmdcXG4gICAgICByZWNlaXZlcjpzdHJpbmdcXG4gICAgICBhbW91bnQ6ZGVjaW1hbFxcbiAgICAgIHRhcmdldC1jaGFpbjpzdHJpbmdcXG4gICAgKVxcbiAgICBAZG9jIFxcXCIgTWFuYWdlZCBjYXBhYmlsaXR5IHNlYWxpbmcgQU1PVU5UIGZvciB0cmFuc2ZlciBcXFxcXFxuICAgICAgICAgXFxcXCBmcm9tIFNFTkRFUiB0byBSRUNFSVZFUiBvbiBUQVJHRVQtQ0hBSU4uIFBlcm1pdHMgXFxcXFxcbiAgICAgICAgIFxcXFwgYW55IG51bWJlciBvZiBjcm9zcy1jaGFpbiB0cmFuc2ZlcnMgdXAgdG8gQU1PVU5ULlxcXCJcXG5cXG4gICAgQG1hbmFnZWQgYW1vdW50IFRSQU5TRkVSX1hDSEFJTi1tZ3JcXG4gICAgKVxcblxcbiAgKGRlZnVuIFRSQU5TRkVSX1hDSEFJTi1tZ3I6ZGVjaW1hbFxcbiAgICAoIG1hbmFnZWQ6ZGVjaW1hbFxcbiAgICAgIHJlcXVlc3RlZDpkZWNpbWFsXFxuICAgIClcXG4gICAgQGRvYyBcXFwiIEFsbG93cyBUUkFOU0ZFUi1YQ0hBSU4gQU1PVU5UIHRvIGJlIGxlc3MgdGhhbiBvciBcXFxcXFxuICAgICAgICAgXFxcXCBlcXVhbCBtYW5hZ2VkIHF1YW50aXR5IGFzIGEgb25lLXNob3QsIHJldHVybmluZyAwLjAuXFxcIlxcbiAgKVxcblxcbiAgKGRlZmNhcCBUUkFOU0ZFUl9YQ0hBSU5fUkVDRDpib29sXFxuICAgICggc2VuZGVyOnN0cmluZ1xcbiAgICAgIHJlY2VpdmVyOnN0cmluZ1xcbiAgICAgIGFtb3VudDpkZWNpbWFsXFxuICAgICAgc291cmNlLWNoYWluOnN0cmluZ1xcbiAgICApXFxuICAgIEBkb2MgXFxcIkV2ZW50IGVtaXR0ZWQgb24gcmVjZWlwdCBvZiBjcm9zcy1jaGFpbiB0cmFuc2Zlci5cXFwiXFxuICAgIEBldmVudFxcbiAgKVxcbilcXG5cIn19LFwic2lnbmVyc1wiOltdLFwibWV0YVwiOntcImNyZWF0aW9uVGltZVwiOjAsXCJ0dGxcIjoxNzI4MDAsXCJnYXNMaW1pdFwiOjAsXCJjaGFpbklkXCI6XCJcIixcImdhc1ByaWNlXCI6MCxcInNlbmRlclwiOlwiXCJ9LFwibm9uY2VcIjpcImdlbmVzaXMteGNoYWluXCJ9In0", unsafeFromText "eyJnYXMiOjEsInJlc3VsdCI6eyJzdGF0dXMiOiJzdWNjZXNzIiwiZGF0YSI6IkxvYWRlZCBpbnRlcmZhY2UgZnVuZ2libGUteGNoYWluLXYxLCBoYXNoIGg4OWljM2doejIzUmprMHBITkt0Rk93cnZTczdtYm11cWxvVlhPaGwyR0kifSwicmVxS2V5IjoieW5ucDFYVVNSTjJrMUYwYTZ2dXM3RFp0SDZjcHN6MVhmX0d3V0xnTFhTTSIsImxvZ3MiOiJSUDhnMUJrZnkyQjN1bHE0WWU4amF1VlRZcGpqRXlaLWtydGJ5SVg2STRnIiwibWV0YURhdGEiOm51bGwsImNvbnRpbnVhdGlvbiI6bnVsbCwidHhJZCI6MX0") - , (unsafeFromText "eyJoYXNoIjoiMDVCdGo3ZUJaQlc3by1TYUxvVmhBaWNNVVBaVUJiRzZRVDhfTEFrQ3hIcyIsInNpZ3MiOltdLCJjbWQiOiJ7XCJuZXR3b3JrSWRcIjpudWxsLFwicGF5bG9hZFwiOntcImV4ZWNcIjp7XCJkYXRhXCI6bnVsbCxcImNvZGVcIjpcIihpbnRlcmZhY2UgZnVuZ2libGUtdjJcXG5cXG4gIFxcXCIgU3RhbmRhcmQgZm9yIGZ1bmdpYmxlIGNvaW5zIGFuZCB0b2tlbnMgYXMgc3BlY2lmaWVkIGluIEtJUC0wMDAyLiBcXFwiXFxuXFxuICAgOyAtLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tXFxuICAgOyBTY2hlbWFcXG5cXG4gICAoZGVmc2NoZW1hIGFjY291bnQtZGV0YWlsc1xcbiAgICBAZG9jIFxcXCJTY2hlbWEgZm9yIHJlc3VsdHMgb2YgJ2FjY291bnQnIG9wZXJhdGlvbi5cXFwiXFxuICAgIEBtb2RlbCBbIChpbnZhcmlhbnQgKCE9IFxcXCJcXFwiIHNlbmRlcikpIF1cXG5cXG4gICAgYWNjb3VudDpzdHJpbmdcXG4gICAgYmFsYW5jZTpkZWNpbWFsXFxuICAgIGd1YXJkOmd1YXJkKVxcblxcblxcbiAgIDsgLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLVxcbiAgIDsgQ2Fwc1xcblxcbiAgIChkZWZjYXAgVFJBTlNGRVI6Ym9vbFxcbiAgICAgKCBzZW5kZXI6c3RyaW5nXFxuICAgICAgIHJlY2VpdmVyOnN0cmluZ1xcbiAgICAgICBhbW91bnQ6ZGVjaW1hbFxcbiAgICAgKVxcbiAgICAgQGRvYyBcXFwiIE1hbmFnZWQgY2FwYWJpbGl0eSBzZWFsaW5nIEFNT1VOVCBmb3IgdHJhbnNmZXIgZnJvbSBTRU5ERVIgdG8gXFxcXFxcbiAgICAgICAgICBcXFxcIFJFQ0VJVkVSLiBQZXJtaXRzIGFueSBudW1iZXIgb2YgdHJhbnNmZXJzIHVwIHRvIEFNT1VOVC5cXFwiXFxuICAgICBAbWFuYWdlZCBhbW91bnQgVFJBTlNGRVItbWdyXFxuICAgICApXFxuXFxuICAgKGRlZnVuIFRSQU5TRkVSLW1ncjpkZWNpbWFsXFxuICAgICAoIG1hbmFnZWQ6ZGVjaW1hbFxcbiAgICAgICByZXF1ZXN0ZWQ6ZGVjaW1hbFxcbiAgICAgKVxcbiAgICAgQGRvYyBcXFwiIE1hbmFnZXMgVFJBTlNGRVIgQU1PVU5UIGxpbmVhcmx5LCBcXFxcXFxuICAgICAgICAgIFxcXFwgc3VjaCB0aGF0IGEgcmVxdWVzdCBmb3IgMS4wIGFtb3VudCBvbiBhIDMuMCBcXFxcXFxuICAgICAgICAgIFxcXFwgbWFuYWdlZCBxdWFudGl0eSBlbWl0cyB1cGRhdGVkIGFtb3VudCAyLjAuXFxcIlxcbiAgICAgKVxcblxcbiAgIDsgLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLVxcbiAgIDsgRnVuY3Rpb25hbGl0eVxcblxcblxcbiAgKGRlZnVuIHRyYW5zZmVyOnN0cmluZ1xcbiAgICAoIHNlbmRlcjpzdHJpbmdcXG4gICAgICByZWNlaXZlcjpzdHJpbmdcXG4gICAgICBhbW91bnQ6ZGVjaW1hbFxcbiAgICApXFxuICAgIEBkb2MgXFxcIiBUcmFuc2ZlciBBTU9VTlQgYmV0d2VlbiBhY2NvdW50cyBTRU5ERVIgYW5kIFJFQ0VJVkVSLiBcXFxcXFxuICAgICAgICAgXFxcXCBGYWlscyBpZiBlaXRoZXIgU0VOREVSIG9yIFJFQ0VJVkVSIGRvZXMgbm90IGV4aXN0LlxcXCJcXG4gICAgQG1vZGVsIFsgKHByb3BlcnR5ICg-IGFtb3VudCAwLjApKVxcbiAgICAgICAgICAgICAocHJvcGVydHkgKCE9IHNlbmRlciBcXFwiXFxcIikpXFxuICAgICAgICAgICAgIChwcm9wZXJ0eSAoIT0gcmVjZWl2ZXIgXFxcIlxcXCIpKVxcbiAgICAgICAgICAgICAocHJvcGVydHkgKCE9IHNlbmRlciByZWNlaXZlcikpXFxuICAgICAgICAgICBdXFxuICAgIClcXG5cXG4gICAoZGVmdW4gdHJhbnNmZXItY3JlYXRlOnN0cmluZ1xcbiAgICAgKCBzZW5kZXI6c3RyaW5nXFxuICAgICAgIHJlY2VpdmVyOnN0cmluZ1xcbiAgICAgICByZWNlaXZlci1ndWFyZDpndWFyZFxcbiAgICAgICBhbW91bnQ6ZGVjaW1hbFxcbiAgICAgKVxcbiAgICAgQGRvYyBcXFwiIFRyYW5zZmVyIEFNT1VOVCBiZXR3ZWVuIGFjY291bnRzIFNFTkRFUiBhbmQgUkVDRUlWRVIuIFxcXFxcXG4gICAgICAgICAgXFxcXCBGYWlscyBpZiBTRU5ERVIgZG9lcyBub3QgZXhpc3QuIElmIFJFQ0VJVkVSIGV4aXN0cywgZ3VhcmQgXFxcXFxcbiAgICAgICAgICBcXFxcIG11c3QgbWF0Y2ggZXhpc3RpbmcgdmFsdWUuIElmIFJFQ0VJVkVSIGRvZXMgbm90IGV4aXN0LCBcXFxcXFxuICAgICAgICAgIFxcXFwgUkVDRUlWRVIgYWNjb3VudCBpcyBjcmVhdGVkIHVzaW5nIFJFQ0VJVkVSLUdVQVJELiBcXFxcXFxuICAgICAgICAgIFxcXFwgU3ViamVjdCB0byBtYW5hZ2VtZW50IGJ5IFRSQU5TRkVSIGNhcGFiaWxpdHkuXFxcIlxcbiAgICAgQG1vZGVsIFsgKHByb3BlcnR5ICg-IGFtb3VudCAwLjApKVxcbiAgICAgICAgICAgICAgKHByb3BlcnR5ICghPSBzZW5kZXIgXFxcIlxcXCIpKVxcbiAgICAgICAgICAgICAgKHByb3BlcnR5ICghPSByZWNlaXZlciBcXFwiXFxcIikpXFxuICAgICAgICAgICAgICAocHJvcGVydHkgKCE9IHNlbmRlciByZWNlaXZlcikpXFxuICAgICAgICAgICAgXVxcbiAgICAgKVxcblxcbiAgIChkZWZwYWN0IHRyYW5zZmVyLWNyb3NzY2hhaW46c3RyaW5nXFxuICAgICAoIHNlbmRlcjpzdHJpbmdcXG4gICAgICAgcmVjZWl2ZXI6c3RyaW5nXFxuICAgICAgIHJlY2VpdmVyLWd1YXJkOmd1YXJkXFxuICAgICAgIHRhcmdldC1jaGFpbjpzdHJpbmdcXG4gICAgICAgYW1vdW50OmRlY2ltYWxcXG4gICAgIClcXG4gICAgIEBkb2MgXFxcIiAyLXN0ZXAgcGFjdCB0byB0cmFuc2ZlciBBTU9VTlQgZnJvbSBTRU5ERVIgb24gY3VycmVudCBjaGFpbiBcXFxcXFxuICAgICAgICAgIFxcXFwgdG8gUkVDRUlWRVIgb24gVEFSR0VULUNIQUlOIHZpYSBTUFYgcHJvb2YuIFxcXFxcXG4gICAgICAgICAgXFxcXCBUQVJHRVQtQ0hBSU4gbXVzdCBiZSBkaWZmZXJlbnQgdGhhbiBjdXJyZW50IGNoYWluIGlkLiBcXFxcXFxuICAgICAgICAgIFxcXFwgRmlyc3Qgc3RlcCBkZWJpdHMgQU1PVU5UIGNvaW5zIGluIFNFTkRFUiBhY2NvdW50IGFuZCB5aWVsZHMgXFxcXFxcbiAgICAgICAgICBcXFxcIFJFQ0VJVkVSLCBSRUNFSVZFUl9HVUFSRCBhbmQgQU1PVU5UIHRvIFRBUkdFVC1DSEFJTi4gXFxcXFxcbiAgICAgICAgICBcXFxcIFNlY29uZCBzdGVwIGNvbnRpbnVhdGlvbiBpcyBzZW50IGludG8gVEFSR0VULUNIQUlOIHdpdGggcHJvb2YgXFxcXFxcbiAgICAgICAgICBcXFxcIG9idGFpbmVkIGZyb20gdGhlIHNwdiAnb3V0cHV0JyBlbmRwb2ludCBvZiBDaGFpbndlYi4gXFxcXFxcbiAgICAgICAgICBcXFxcIFByb29mIGlzIHZhbGlkYXRlZCBhbmQgUkVDRUlWRVIgaXMgY3JlZGl0ZWQgd2l0aCBBTU9VTlQgXFxcXFxcbiAgICAgICAgICBcXFxcIGNyZWF0aW5nIGFjY291bnQgd2l0aCBSRUNFSVZFUl9HVUFSRCBhcyBuZWNlc3NhcnkuXFxcIlxcbiAgICAgQG1vZGVsIFsgKHByb3BlcnR5ICg-IGFtb3VudCAwLjApKVxcbiAgICAgICAgICAgICAgKHByb3BlcnR5ICghPSBzZW5kZXIgXFxcIlxcXCIpKVxcbiAgICAgICAgICAgICAgKHByb3BlcnR5ICghPSByZWNlaXZlciBcXFwiXFxcIikpXFxuICAgICAgICAgICAgICAocHJvcGVydHkgKCE9IHNlbmRlciByZWNlaXZlcikpXFxuICAgICAgICAgICAgICAocHJvcGVydHkgKCE9IHRhcmdldC1jaGFpbiBcXFwiXFxcIikpXFxuICAgICAgICAgICAgXVxcbiAgICAgKVxcblxcbiAgIChkZWZ1biBnZXQtYmFsYW5jZTpkZWNpbWFsXFxuICAgICAoIGFjY291bnQ6c3RyaW5nIClcXG4gICAgIFxcXCIgR2V0IGJhbGFuY2UgZm9yIEFDQ09VTlQuIEZhaWxzIGlmIGFjY291bnQgZG9lcyBub3QgZXhpc3QuXFxcIlxcbiAgICAgKVxcblxcbiAgIChkZWZ1biBkZXRhaWxzOm9iamVjdHthY2NvdW50LWRldGFpbHN9XFxuICAgICAoIGFjY291bnQ6IHN0cmluZyApXFxuICAgICBcXFwiIEdldCBhbiBvYmplY3Qgd2l0aCBkZXRhaWxzIG9mIEFDQ09VTlQuIFxcXFxcXG4gICAgIFxcXFwgRmFpbHMgaWYgYWNjb3VudCBkb2VzIG5vdCBleGlzdC5cXFwiXFxuICAgICApXFxuXFxuICAgKGRlZnVuIHByZWNpc2lvbjppbnRlZ2VyXFxuICAgICAoKVxcbiAgICAgXFxcIlJldHVybiB0aGUgbWF4aW11bSBhbGxvd2VkIGRlY2ltYWwgcHJlY2lzaW9uLlxcXCJcXG4gICAgIClcXG5cXG4gICAoZGVmdW4gZW5mb3JjZS11bml0OmJvb2xcXG4gICAgICggYW1vdW50OmRlY2ltYWwgKVxcbiAgICAgXFxcIiBFbmZvcmNlIG1pbmltdW0gcHJlY2lzaW9uIGFsbG93ZWQgZm9yIHRyYW5zYWN0aW9ucy5cXFwiXFxuICAgICApXFxuXFxuICAgKGRlZnVuIGNyZWF0ZS1hY2NvdW50OnN0cmluZ1xcbiAgICAgKCBhY2NvdW50OnN0cmluZ1xcbiAgICAgICBndWFyZDpndWFyZFxcbiAgICAgKVxcbiAgICAgXFxcIiBDcmVhdGUgQUNDT1VOVCB3aXRoIDAuMCBiYWxhbmNlLCB3aXRoIEdVQVJEIGNvbnRyb2xsaW5nIGFjY2Vzcy5cXFwiXFxuICAgICApXFxuXFxuICAgKGRlZnVuIHJvdGF0ZTpzdHJpbmdcXG4gICAgICggYWNjb3VudDpzdHJpbmdcXG4gICAgICAgbmV3LWd1YXJkOmd1YXJkXFxuICAgICApXFxuICAgICBcXFwiIFJvdGF0ZSBndWFyZCBmb3IgQUNDT1VOVC4gVHJhbnNhY3Rpb24gaXMgdmFsaWRhdGVkIGFnYWluc3QgXFxcXFxcbiAgICAgXFxcXCBleGlzdGluZyBndWFyZCBiZWZvcmUgaW5zdGFsbGluZyBuZXcgZ3VhcmQuIFxcXCJcXG4gICAgIClcXG5cXG4pXFxuXCJ9fSxcInNpZ25lcnNcIjpbXSxcIm1ldGFcIjp7XCJjcmVhdGlvblRpbWVcIjowLFwidHRsXCI6MTcyODAwLFwiZ2FzTGltaXRcIjowLFwiY2hhaW5JZFwiOlwiXCIsXCJnYXNQcmljZVwiOjAsXCJzZW5kZXJcIjpcIlwifSxcIm5vbmNlXCI6XCJmdW5naWJsZS1hc3NldC12MlwifSJ9", unsafeFromText "eyJnYXMiOjEsInJlc3VsdCI6eyJzdGF0dXMiOiJzdWNjZXNzIiwiZGF0YSI6IkxvYWRlZCBpbnRlcmZhY2UgZnVuZ2libGUtdjIsIGhhc2ggWXhFLUtnQzZKbUttQ2NnS1RKbWxFbl9JNThJNEVYbWhmcnZ6WDdiZXJZayJ9LCJyZXFLZXkiOiIwNUJ0ajdlQlpCVzdvLVNhTG9WaEFpY01VUFpVQmJHNlFUOF9MQWtDeEhzIiwibG9ncyI6IjFTQmJBNHVzS0E5OFNlX09WRUdkcVk5WjJoSW1jVmcydWpISDJkM1ZmeEkiLCJtZXRhRGF0YSI6bnVsbCwiY29udGludWF0aW9uIjpudWxsLCJ0eElkIjoyfQ") - , (unsafeFromText "eyJoYXNoIjoiR1JJUXU0aEFLazBJRDlGOHpfLTB5WHlBS0ozM01QeVRZTVhPamxQSm1wSSIsInNpZ3MiOltdLCJjbWQiOiJ7XCJuZXR3b3JrSWRcIjpudWxsLFwicGF5bG9hZFwiOntcImV4ZWNcIjp7XCJkYXRhXCI6bnVsbCxcImNvZGVcIjpcIlxcbihtb2R1bGUgY29pbiBHT1ZFUk5BTkNFXFxuXFxuICBAZG9jIFxcXCInY29pbicgcmVwcmVzZW50cyB0aGUgS2FkZW5hIENvaW4gQ29udHJhY3QuIFRoaXMgY29udHJhY3QgcHJvdmlkZXMgYm90aCB0aGUgXFxcXFxcbiAgXFxcXGJ1eS9yZWRlZW0gZ2FzIHN1cHBvcnQgaW4gdGhlIGZvcm0gb2YgJ2Z1bmQtdHgnLCBhcyB3ZWxsIGFzIHRyYW5zZmVyLCAgICAgICBcXFxcXFxuICBcXFxcY3JlZGl0LCBkZWJpdCwgY29pbmJhc2UsIGFjY291bnQgY3JlYXRpb24gYW5kIHF1ZXJ5LCBhcyB3ZWxsIGFzIFNQViBidXJuICAgIFxcXFxcXG4gIFxcXFxjcmVhdGUuIFRvIGFjY2VzcyB0aGUgY29pbiBjb250cmFjdCwgeW91IG1heSB1c2UgaXRzIGZ1bGx5LXF1YWxpZmllZCBuYW1lLCAgXFxcXFxcbiAgXFxcXG9yIGlzc3VlIHRoZSAnKHVzZSBjb2luKScgY29tbWFuZCBpbiB0aGUgYm9keSBvZiBhIG1vZHVsZSBkZWNsYXJhdGlvbi5cXFwiXFxuXFxuICBAbW9kZWxcXG4gICAgWyAoZGVmcHJvcGVydHkgY29uc2VydmVzLW1hc3NcXG4gICAgICAgICg9IChjb2x1bW4tZGVsdGEgY29pbi10YWJsZSAnYmFsYW5jZSkgMC4wKSlcXG5cXG4gICAgICAoZGVmcHJvcGVydHkgdmFsaWQtYWNjb3VudCAoYWNjb3VudDpzdHJpbmcpXFxuICAgICAgICAoYW5kXFxuICAgICAgICAgICg-PSAobGVuZ3RoIGFjY291bnQpIDMpXFxuICAgICAgICAgICg8PSAobGVuZ3RoIGFjY291bnQpIDI1NikpKVxcbiAgICBdXFxuXFxuICAoaW1wbGVtZW50cyBmdW5naWJsZS12MilcXG4gIChpbXBsZW1lbnRzIGZ1bmdpYmxlLXhjaGFpbi12MSlcXG5cXG4gIDs7IGNvaW4tdjJcXG4gIChibGVzcyBcXFwidXRfSl9aTmtveWFQVUVKaGl3VmVXbmtTUW45SlQ5c1FDV0tkampWVnJXb1xcXCIpXFxuXFxuICA7OyBjb2luIHYzXFxuICAoYmxlc3MgXFxcIjFvc19zTEFVWXZCenNwbjVqamF3dFJwSldpSDFXUGZoeU5yYWVWdlNJd1VcXFwiKVxcblxcbiAgOzsgY29pbiB2NFxcbiAgKGJsZXNzIFxcXCJCalpXMFQyYWM2cUVfSTVYOEdFNGZhbDZ0VHFqaExUQzdteTB5dFFTeExVXFxcIilcXG5cXG4gIDs7IGNvaW4gdjVcXG4gIChibGVzcyBcXFwickU3RFU4amxRTDl4X01QWXVuaVpKZjVJQ0JUQUVIQUlGUUNCNGJsb2ZQNFxcXCIpXFxuXFxuICA7IC0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tXFxuICA7IFNjaGVtYXMgYW5kIFRhYmxlc1xcblxcbiAgKGRlZnNjaGVtYSBjb2luLXNjaGVtYVxcbiAgICBAZG9jIFxcXCJUaGUgY29pbiBjb250cmFjdCB0b2tlbiBzY2hlbWFcXFwiXFxuICAgIEBtb2RlbCBbIChpbnZhcmlhbnQgKD49IGJhbGFuY2UgMC4wKSkgXVxcblxcbiAgICBiYWxhbmNlOmRlY2ltYWxcXG4gICAgZ3VhcmQ6Z3VhcmQpXFxuXFxuICAoZGVmdGFibGUgY29pbi10YWJsZTp7Y29pbi1zY2hlbWF9KVxcblxcbiAgOyAtLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLVxcbiAgOyBDYXBhYmlsaXRpZXNcXG5cXG4gIChkZWZjYXAgR09WRVJOQU5DRSAoKVxcbiAgICAoZW5mb3JjZSBmYWxzZSBcXFwiRW5mb3JjZSBub24tdXBncmFkZWFiaWxpdHlcXFwiKSlcXG5cXG4gIChkZWZjYXAgR0FTICgpXFxuICAgIFxcXCJNYWdpYyBjYXBhYmlsaXR5IHRvIHByb3RlY3QgZ2FzIGJ1eSBhbmQgcmVkZWVtXFxcIlxcbiAgICB0cnVlKVxcblxcbiAgKGRlZmNhcCBDT0lOQkFTRSAoKVxcbiAgICBcXFwiTWFnaWMgY2FwYWJpbGl0eSB0byBwcm90ZWN0IG1pbmVyIHJld2FyZFxcXCJcXG4gICAgdHJ1ZSlcXG5cXG4gIChkZWZjYXAgR0VORVNJUyAoKVxcbiAgICBcXFwiTWFnaWMgY2FwYWJpbGl0eSBjb25zdHJhaW5pbmcgZ2VuZXNpcyB0cmFuc2FjdGlvbnNcXFwiXFxuICAgIHRydWUpXFxuXFxuICAoZGVmY2FwIFJFTUVESUFURSAoKVxcbiAgICBcXFwiTWFnaWMgY2FwYWJpbGl0eSBmb3IgcmVtZWRpYXRpb24gdHJhbnNhY3Rpb25zXFxcIlxcbiAgICB0cnVlKVxcblxcbiAgKGRlZmNhcCBERUJJVCAoc2VuZGVyOnN0cmluZylcXG4gICAgXFxcIkNhcGFiaWxpdHkgZm9yIG1hbmFnaW5nIGRlYml0aW5nIG9wZXJhdGlvbnNcXFwiXFxuICAgIChlbmZvcmNlLWd1YXJkIChhdCAnZ3VhcmQgKHJlYWQgY29pbi10YWJsZSBzZW5kZXIpKSlcXG4gICAgKGVuZm9yY2UgKCE9IHNlbmRlciBcXFwiXFxcIikgXFxcInZhbGlkIHNlbmRlclxcXCIpKVxcblxcbiAgKGRlZmNhcCBDUkVESVQgKHJlY2VpdmVyOnN0cmluZylcXG4gICAgXFxcIkNhcGFiaWxpdHkgZm9yIG1hbmFnaW5nIGNyZWRpdGluZyBvcGVyYXRpb25zXFxcIlxcbiAgICAoZW5mb3JjZSAoIT0gcmVjZWl2ZXIgXFxcIlxcXCIpIFxcXCJ2YWxpZCByZWNlaXZlclxcXCIpKVxcblxcbiAgKGRlZmNhcCBST1RBVEUgKGFjY291bnQ6c3RyaW5nKVxcbiAgICBAZG9jIFxcXCJBdXRvbm9tb3VzbHkgbWFuYWdlZCBjYXBhYmlsaXR5IGZvciBndWFyZCByb3RhdGlvblxcXCJcXG4gICAgQG1hbmFnZWRcXG4gICAgdHJ1ZSlcXG5cXG4gIChkZWZjYXAgVFJBTlNGRVI6Ym9vbFxcbiAgICAoIHNlbmRlcjpzdHJpbmdcXG4gICAgICByZWNlaXZlcjpzdHJpbmdcXG4gICAgICBhbW91bnQ6ZGVjaW1hbFxcbiAgICApXFxuICAgIEBtYW5hZ2VkIGFtb3VudCBUUkFOU0ZFUi1tZ3JcXG4gICAgKGVuZm9yY2UgKCE9IHNlbmRlciByZWNlaXZlcikgXFxcInNhbWUgc2VuZGVyIGFuZCByZWNlaXZlclxcXCIpXFxuICAgIChlbmZvcmNlLXVuaXQgYW1vdW50KVxcbiAgICAoZW5mb3JjZSAoPiBhbW91bnQgMC4wKSBcXFwiUG9zaXRpdmUgYW1vdW50XFxcIilcXG4gICAgKGNvbXBvc2UtY2FwYWJpbGl0eSAoREVCSVQgc2VuZGVyKSlcXG4gICAgKGNvbXBvc2UtY2FwYWJpbGl0eSAoQ1JFRElUIHJlY2VpdmVyKSlcXG4gIClcXG5cXG4gIChkZWZ1biBUUkFOU0ZFUi1tZ3I6ZGVjaW1hbFxcbiAgICAoIG1hbmFnZWQ6ZGVjaW1hbFxcbiAgICAgIHJlcXVlc3RlZDpkZWNpbWFsXFxuICAgIClcXG5cXG4gICAgKGxldCAoKG5ld2JhbCAoLSBtYW5hZ2VkIHJlcXVlc3RlZCkpKVxcbiAgICAgIChlbmZvcmNlICg-PSBuZXdiYWwgMC4wKVxcbiAgICAgICAgKGZvcm1hdCBcXFwiVFJBTlNGRVIgZXhjZWVkZWQgZm9yIGJhbGFuY2Uge31cXFwiIFttYW5hZ2VkXSkpXFxuICAgICAgbmV3YmFsKVxcbiAgKVxcblxcbiAgKGRlZmNhcCBUUkFOU0ZFUl9YQ0hBSU46Ym9vbFxcbiAgICAoIHNlbmRlcjpzdHJpbmdcXG4gICAgICByZWNlaXZlcjpzdHJpbmdcXG4gICAgICBhbW91bnQ6ZGVjaW1hbFxcbiAgICAgIHRhcmdldC1jaGFpbjpzdHJpbmdcXG4gICAgKVxcblxcbiAgICBAbWFuYWdlZCBhbW91bnQgVFJBTlNGRVJfWENIQUlOLW1nclxcbiAgICAoZW5mb3JjZS11bml0IGFtb3VudClcXG4gICAgKGVuZm9yY2UgKD4gYW1vdW50IDAuMCkgXFxcIkNyb3NzLWNoYWluIHRyYW5zZmVycyByZXF1aXJlIGEgcG9zaXRpdmUgYW1vdW50XFxcIilcXG4gICAgKGNvbXBvc2UtY2FwYWJpbGl0eSAoREVCSVQgc2VuZGVyKSlcXG4gIClcXG5cXG4gIChkZWZ1biBUUkFOU0ZFUl9YQ0hBSU4tbWdyOmRlY2ltYWxcXG4gICAgKCBtYW5hZ2VkOmRlY2ltYWxcXG4gICAgICByZXF1ZXN0ZWQ6ZGVjaW1hbFxcbiAgICApXFxuXFxuICAgIChlbmZvcmNlICg-PSBtYW5hZ2VkIHJlcXVlc3RlZClcXG4gICAgICAoZm9ybWF0IFxcXCJUUkFOU0ZFUl9YQ0hBSU4gZXhjZWVkZWQgZm9yIGJhbGFuY2Uge31cXFwiIFttYW5hZ2VkXSkpXFxuICAgIDAuMFxcbiAgKVxcblxcbiAgKGRlZmNhcCBUUkFOU0ZFUl9YQ0hBSU5fUkVDRDpib29sXFxuICAgICggc2VuZGVyOnN0cmluZ1xcbiAgICAgIHJlY2VpdmVyOnN0cmluZ1xcbiAgICAgIGFtb3VudDpkZWNpbWFsXFxuICAgICAgc291cmNlLWNoYWluOnN0cmluZ1xcbiAgICApXFxuICAgIEBldmVudCB0cnVlXFxuICApXFxuXFxuICA7IHYzIGNhcGFiaWxpdGllc1xcbiAgKGRlZmNhcCBSRUxFQVNFX0FMTE9DQVRJT05cXG4gICAgKCBhY2NvdW50OnN0cmluZ1xcbiAgICAgIGFtb3VudDpkZWNpbWFsXFxuICAgIClcXG4gICAgQGRvYyBcXFwiRXZlbnQgZm9yIGFsbG9jYXRpb24gcmVsZWFzZSwgY2FuIGJlIHVzZWQgZm9yIHNpZyBzY29waW5nLlxcXCJcXG4gICAgQGV2ZW50IHRydWVcXG4gIClcXG5cXG4gIDsgLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS1cXG4gIDsgQ29uc3RhbnRzXFxuXFxuICAoZGVmY29uc3QgQ09JTl9DSEFSU0VUIENIQVJTRVRfTEFUSU4xXFxuICAgIFxcXCJUaGUgZGVmYXVsdCBjb2luIGNvbnRyYWN0IGNoYXJhY3RlciBzZXRcXFwiKVxcblxcbiAgKGRlZmNvbnN0IE1JTklNVU1fUFJFQ0lTSU9OIDEyXFxuICAgIFxcXCJNaW5pbXVtIGFsbG93ZWQgcHJlY2lzaW9uIGZvciBjb2luIHRyYW5zYWN0aW9uc1xcXCIpXFxuXFxuICAoZGVmY29uc3QgTUlOSU1VTV9BQ0NPVU5UX0xFTkdUSCAzXFxuICAgIFxcXCJNaW5pbXVtIGFjY291bnQgbGVuZ3RoIGFkbWlzc2libGUgZm9yIGNvaW4gYWNjb3VudHNcXFwiKVxcblxcbiAgKGRlZmNvbnN0IE1BWElNVU1fQUNDT1VOVF9MRU5HVEggMjU2XFxuICAgIFxcXCJNYXhpbXVtIGFjY291bnQgbmFtZSBsZW5ndGggYWRtaXNzaWJsZSBmb3IgY29pbiBhY2NvdW50c1xcXCIpXFxuXFxuICAoZGVmY29uc3QgVkFMSURfQ0hBSU5fSURTIChtYXAgKGludC10by1zdHIgMTApIChlbnVtZXJhdGUgMCAxOSkpXFxuICAgIFxcXCJMaXN0IG9mIGFsbCB2YWxpZCBDaGFpbndlYiBjaGFpbiBpZHNcXFwiKVxcblxcbiAgOyAtLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLVxcbiAgOyBVdGlsaXRpZXNcXG5cXG4gIChkZWZ1biBlbmZvcmNlLXVuaXQ6Ym9vbCAoYW1vdW50OmRlY2ltYWwpXFxuICAgIEBkb2MgXFxcIkVuZm9yY2UgbWluaW11bSBwcmVjaXNpb24gYWxsb3dlZCBmb3IgY29pbiB0cmFuc2FjdGlvbnNcXFwiXFxuXFxuICAgIChlbmZvcmNlXFxuICAgICAgKD0gKGZsb29yIGFtb3VudCBNSU5JTVVNX1BSRUNJU0lPTilcXG4gICAgICAgICBhbW91bnQpXFxuICAgICAgKGZvcm1hdCBcXFwiQW1vdW50IHZpb2xhdGVzIG1pbmltdW0gcHJlY2lzaW9uOiB7fVxcXCIgW2Ftb3VudF0pKVxcbiAgICApXFxuXFxuICAoZGVmdW4gdmFsaWRhdGUtYWNjb3VudCAoYWNjb3VudDpzdHJpbmcpXFxuICAgIEBkb2MgXFxcIkVuZm9yY2UgdGhhdCBhbiBhY2NvdW50IG5hbWUgY29uZm9ybXMgdG8gdGhlIGNvaW4gY29udHJhY3QgXFxcXFxcbiAgICAgICAgIFxcXFxtaW5pbXVtIGFuZCBtYXhpbXVtIGxlbmd0aCByZXF1aXJlbWVudHMsIGFzIHdlbGwgYXMgdGhlICAgIFxcXFxcXG4gICAgICAgICBcXFxcbGF0aW4tMSBjaGFyYWN0ZXIgc2V0LlxcXCJcXG5cXG4gICAgKGVuZm9yY2VcXG4gICAgICAoaXMtY2hhcnNldCBDT0lOX0NIQVJTRVQgYWNjb3VudClcXG4gICAgICAoZm9ybWF0XFxuICAgICAgICBcXFwiQWNjb3VudCBkb2VzIG5vdCBjb25mb3JtIHRvIHRoZSBjb2luIGNvbnRyYWN0IGNoYXJzZXQ6IHt9XFxcIlxcbiAgICAgICAgW2FjY291bnRdKSlcXG5cXG4gICAgKGxldCAoKGFjY291bnQtbGVuZ3RoIChsZW5ndGggYWNjb3VudCkpKVxcblxcbiAgICAgIChlbmZvcmNlXFxuICAgICAgICAoPj0gYWNjb3VudC1sZW5ndGggTUlOSU1VTV9BQ0NPVU5UX0xFTkdUSClcXG4gICAgICAgIChmb3JtYXRcXG4gICAgICAgICAgXFxcIkFjY291bnQgbmFtZSBkb2VzIG5vdCBjb25mb3JtIHRvIHRoZSBtaW4gbGVuZ3RoIHJlcXVpcmVtZW50OiB7fVxcXCJcXG4gICAgICAgICAgW2FjY291bnRdKSlcXG5cXG4gICAgICAoZW5mb3JjZVxcbiAgICAgICAgKDw9IGFjY291bnQtbGVuZ3RoIE1BWElNVU1fQUNDT1VOVF9MRU5HVEgpXFxuICAgICAgICAoZm9ybWF0XFxuICAgICAgICAgIFxcXCJBY2NvdW50IG5hbWUgZG9lcyBub3QgY29uZm9ybSB0byB0aGUgbWF4IGxlbmd0aCByZXF1aXJlbWVudDoge31cXFwiXFxuICAgICAgICAgIFthY2NvdW50XSkpXFxuICAgICAgKVxcbiAgKVxcblxcbiAgOyAtLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLVxcbiAgOyBDb2luIENvbnRyYWN0XFxuXFxuICAoZGVmdW4gZ2FzLW9ubHkgKClcXG4gICAgXFxcIlByZWRpY2F0ZSBmb3IgZ2FzLW9ubHkgdXNlciBndWFyZHMuXFxcIlxcbiAgICAocmVxdWlyZS1jYXBhYmlsaXR5IChHQVMpKSlcXG5cXG4gIChkZWZ1biBnYXMtZ3VhcmQgKGd1YXJkOmd1YXJkKVxcbiAgICBcXFwiUHJlZGljYXRlIGZvciBnYXMgKyBzaW5nbGUga2V5IHVzZXIgZ3VhcmRzXFxcIlxcbiAgICAoZW5mb3JjZS1vbmVcXG4gICAgICBcXFwiRW5mb3JjZSBlaXRoZXIgdGhlIHByZXNlbmNlIG9mIGEgR0FTIGNhcCBvciBrZXlzZXRcXFwiXFxuICAgICAgWyAoZ2FzLW9ubHkpXFxuICAgICAgICAoZW5mb3JjZS1ndWFyZCBndWFyZClcXG4gICAgICBdKSlcXG5cXG4gIChkZWZ1biBidXktZ2FzOnN0cmluZyAoc2VuZGVyOnN0cmluZyB0b3RhbDpkZWNpbWFsKVxcbiAgICBAZG9jIFxcXCJUaGlzIGZ1bmN0aW9uIGRlc2NyaWJlcyB0aGUgbWFpbiAnZ2FzIGJ1eScgb3BlcmF0aW9uLiBBdCB0aGlzIHBvaW50IFxcXFxcXG4gICAgXFxcXE1JTkVSIGhhcyBiZWVuIGNob3NlbiBmcm9tIHRoZSBwb29sLCBhbmQgd2lsbCBiZSB2YWxpZGF0ZWQuIFRoZSBTRU5ERVIgICBcXFxcXFxuICAgIFxcXFxvZiB0aGlzIHRyYW5zYWN0aW9uIGhhcyBzcGVjaWZpZWQgYSBnYXMgbGltaXQgTElNSVQgKG1heGltdW0gZ2FzKSBmb3IgICAgXFxcXFxcbiAgICBcXFxcdGhlIHRyYW5zYWN0aW9uLCBhbmQgdGhlIHByaWNlIGlzIHRoZSBzcG90IHByaWNlIG9mIGdhcyBhdCB0aGF0IHRpbWUuICAgIFxcXFxcXG4gICAgXFxcXFRoZSBnYXMgYnV5IHdpbGwgYmUgZXhlY3V0ZWQgcHJpb3IgdG8gZXhlY3V0aW5nIFNFTkRFUidzIGNvZGUuXFxcIlxcblxcbiAgICBAbW9kZWwgWyAocHJvcGVydHkgKD4gdG90YWwgMC4wKSlcXG4gICAgICAgICAgICAgKHByb3BlcnR5ICh2YWxpZC1hY2NvdW50IHNlbmRlcikpXFxuICAgICAgICAgICBdXFxuXFxuICAgICh2YWxpZGF0ZS1hY2NvdW50IHNlbmRlcilcXG5cXG4gICAgKGVuZm9yY2UtdW5pdCB0b3RhbClcXG4gICAgKGVuZm9yY2UgKD4gdG90YWwgMC4wKSBcXFwiZ2FzIHN1cHBseSBtdXN0IGJlIGEgcG9zaXRpdmUgcXVhbnRpdHlcXFwiKVxcblxcbiAgICAocmVxdWlyZS1jYXBhYmlsaXR5IChHQVMpKVxcbiAgICAod2l0aC1jYXBhYmlsaXR5IChERUJJVCBzZW5kZXIpXFxuICAgICAgKGRlYml0IHNlbmRlciB0b3RhbCkpXFxuICAgIClcXG5cXG4gIChkZWZ1biByZWRlZW0tZ2FzOnN0cmluZyAobWluZXI6c3RyaW5nIG1pbmVyLWd1YXJkOmd1YXJkIHNlbmRlcjpzdHJpbmcgdG90YWw6ZGVjaW1hbClcXG4gICAgQGRvYyBcXFwiVGhpcyBmdW5jdGlvbiBkZXNjcmliZXMgdGhlIG1haW4gJ3JlZGVlbSBnYXMnIG9wZXJhdGlvbi4gQXQgdGhpcyAgICBcXFxcXFxuICAgIFxcXFxwb2ludCwgdGhlIFNFTkRFUidzIHRyYW5zYWN0aW9uIGhhcyBiZWVuIGV4ZWN1dGVkLCBhbmQgdGhlIGdhcyB0aGF0ICAgICAgXFxcXFxcbiAgICBcXFxcd2FzIGNoYXJnZWQgaGFzIGJlZW4gY2FsY3VsYXRlZC4gTUlORVIgd2lsbCBiZSBjcmVkaXRlZCB0aGUgZ2FzIGNvc3QsICAgIFxcXFxcXG4gICAgXFxcXGFuZCBTRU5ERVIgd2lsbCByZWNlaXZlIHRoZSByZW1haW5kZXIgdXAgdG8gdGhlIGxpbWl0XFxcIlxcblxcbiAgICBAbW9kZWwgWyAocHJvcGVydHkgKD4gdG90YWwgMC4wKSlcXG4gICAgICAgICAgICAgKHByb3BlcnR5ICh2YWxpZC1hY2NvdW50IHNlbmRlcikpXFxuICAgICAgICAgICAgIChwcm9wZXJ0eSAodmFsaWQtYWNjb3VudCBtaW5lcikpXFxuICAgICAgICAgICBdXFxuXFxuICAgICh2YWxpZGF0ZS1hY2NvdW50IHNlbmRlcilcXG4gICAgKHZhbGlkYXRlLWFjY291bnQgbWluZXIpXFxuICAgIChlbmZvcmNlLXVuaXQgdG90YWwpXFxuXFxuICAgIChyZXF1aXJlLWNhcGFiaWxpdHkgKEdBUykpXFxuICAgIChsZXQqXFxuICAgICAgKChmZWUgKHJlYWQtZGVjaW1hbCBcXFwiZmVlXFxcIikpXFxuICAgICAgIChyZWZ1bmQgKC0gdG90YWwgZmVlKSkpXFxuXFxuICAgICAgKGVuZm9yY2UtdW5pdCBmZWUpXFxuICAgICAgKGVuZm9yY2UgKD49IGZlZSAwLjApXFxuICAgICAgICBcXFwiZmVlIG11c3QgYmUgYSBub24tbmVnYXRpdmUgcXVhbnRpdHlcXFwiKVxcblxcbiAgICAgIChlbmZvcmNlICg-PSByZWZ1bmQgMC4wKVxcbiAgICAgICAgXFxcInJlZnVuZCBtdXN0IGJlIGEgbm9uLW5lZ2F0aXZlIHF1YW50aXR5XFxcIilcXG5cXG4gICAgICAoZW1pdC1ldmVudCAoVFJBTlNGRVIgc2VuZGVyIG1pbmVyIGZlZSkpIDt2M1xcblxcbiAgICAgICAgOyBkaXJlY3RseSB1cGRhdGUgaW5zdGVhZCBvZiBjcmVkaXRcXG4gICAgICAod2l0aC1jYXBhYmlsaXR5IChDUkVESVQgc2VuZGVyKVxcbiAgICAgICAgKGlmICg-IHJlZnVuZCAwLjApXFxuICAgICAgICAgICh3aXRoLXJlYWQgY29pbi10YWJsZSBzZW5kZXJcXG4gICAgICAgICAgICB7IFxcXCJiYWxhbmNlXFxcIiA6PSBiYWxhbmNlIH1cXG4gICAgICAgICAgICAodXBkYXRlIGNvaW4tdGFibGUgc2VuZGVyXFxuICAgICAgICAgICAgICB7IFxcXCJiYWxhbmNlXFxcIjogKCsgYmFsYW5jZSByZWZ1bmQpIH0pKVxcblxcbiAgICAgICAgICBcXFwibm9vcFxcXCIpKVxcblxcbiAgICAgICh3aXRoLWNhcGFiaWxpdHkgKENSRURJVCBtaW5lcilcXG4gICAgICAgIChpZiAoPiBmZWUgMC4wKVxcbiAgICAgICAgICAoY3JlZGl0IG1pbmVyIG1pbmVyLWd1YXJkIGZlZSlcXG4gICAgICAgICAgXFxcIm5vb3BcXFwiKSlcXG4gICAgICApXFxuXFxuICAgIClcXG5cXG4gIChkZWZ1biBjcmVhdGUtYWNjb3VudDpzdHJpbmcgKGFjY291bnQ6c3RyaW5nIGd1YXJkOmd1YXJkKVxcbiAgICBAbW9kZWwgWyAocHJvcGVydHkgKHZhbGlkLWFjY291bnQgYWNjb3VudCkpIF1cXG5cXG4gICAgKHZhbGlkYXRlLWFjY291bnQgYWNjb3VudClcXG4gICAgKGVuZm9yY2UtcmVzZXJ2ZWQgYWNjb3VudCBndWFyZClcXG5cXG4gICAgKGluc2VydCBjb2luLXRhYmxlIGFjY291bnRcXG4gICAgICB7IFxcXCJiYWxhbmNlXFxcIiA6IDAuMFxcbiAgICAgICwgXFxcImd1YXJkXFxcIiAgIDogZ3VhcmRcXG4gICAgICB9KVxcbiAgICApXFxuXFxuICAoZGVmdW4gZ2V0LWJhbGFuY2U6ZGVjaW1hbCAoYWNjb3VudDpzdHJpbmcpXFxuICAgICh3aXRoLXJlYWQgY29pbi10YWJsZSBhY2NvdW50XFxuICAgICAgeyBcXFwiYmFsYW5jZVxcXCIgOj0gYmFsYW5jZSB9XFxuICAgICAgYmFsYW5jZVxcbiAgICAgIClcXG4gICAgKVxcblxcbiAgKGRlZnVuIGRldGFpbHM6b2JqZWN0e2Z1bmdpYmxlLXYyLmFjY291bnQtZGV0YWlsc31cXG4gICAgKCBhY2NvdW50OnN0cmluZyApXFxuICAgICh3aXRoLXJlYWQgY29pbi10YWJsZSBhY2NvdW50XFxuICAgICAgeyBcXFwiYmFsYW5jZVxcXCIgOj0gYmFsXFxuICAgICAgLCBcXFwiZ3VhcmRcXFwiIDo9IGcgfVxcbiAgICAgIHsgXFxcImFjY291bnRcXFwiIDogYWNjb3VudFxcbiAgICAgICwgXFxcImJhbGFuY2VcXFwiIDogYmFsXFxuICAgICAgLCBcXFwiZ3VhcmRcXFwiOiBnIH0pXFxuICAgIClcXG5cXG4gIChkZWZ1biByb3RhdGU6c3RyaW5nIChhY2NvdW50OnN0cmluZyBuZXctZ3VhcmQ6Z3VhcmQpXFxuICAgICh3aXRoLWNhcGFiaWxpdHkgKFJPVEFURSBhY2NvdW50KVxcblxcbiAgICAgIDsgQWxsb3cgcm90YXRpb24gb25seSBmb3IgdmFuaXR5IGFjY291bnRzLCBvclxcbiAgICAgIDsgcmUtcm90YXRpbmcgYSBwcmluY2lwYWwgYWNjb3VudCBiYWNrIHRvIGl0cyBwcm9wZXIgZ3VhcmRcXG4gICAgICAoZW5mb3JjZSAob3IgKG5vdCAoaXMtcHJpbmNpcGFsIGFjY291bnQpKVxcbiAgICAgICAgICAgICAgICAgICh2YWxpZGF0ZS1wcmluY2lwYWwgbmV3LWd1YXJkIGFjY291bnQpKVxcbiAgICAgICAgXFxcIkl0IGlzIHVuc2FmZSBmb3IgcHJpbmNpcGFsIGFjY291bnRzIHRvIHJvdGF0ZSB0aGVpciBndWFyZFxcXCIpXFxuXFxuICAgICAgKHdpdGgtcmVhZCBjb2luLXRhYmxlIGFjY291bnRcXG4gICAgICAgIHsgXFxcImd1YXJkXFxcIiA6PSBvbGQtZ3VhcmQgfVxcbiAgICAgICAgKGVuZm9yY2UtZ3VhcmQgb2xkLWd1YXJkKVxcbiAgICAgICAgKHVwZGF0ZSBjb2luLXRhYmxlIGFjY291bnRcXG4gICAgICAgICAgeyBcXFwiZ3VhcmRcXFwiIDogbmV3LWd1YXJkIH1cXG4gICAgICAgICAgKSkpXFxuICAgIClcXG5cXG5cXG4gIChkZWZ1biBwcmVjaXNpb246aW50ZWdlclxcbiAgICAoKVxcbiAgICBNSU5JTVVNX1BSRUNJU0lPTilcXG5cXG4gIChkZWZ1biB0cmFuc2ZlcjpzdHJpbmcgKHNlbmRlcjpzdHJpbmcgcmVjZWl2ZXI6c3RyaW5nIGFtb3VudDpkZWNpbWFsKVxcbiAgICBAbW9kZWwgWyAocHJvcGVydHkgY29uc2VydmVzLW1hc3MpXFxuICAgICAgICAgICAgIChwcm9wZXJ0eSAoPiBhbW91bnQgMC4wKSlcXG4gICAgICAgICAgICAgKHByb3BlcnR5ICh2YWxpZC1hY2NvdW50IHNlbmRlcikpXFxuICAgICAgICAgICAgIChwcm9wZXJ0eSAodmFsaWQtYWNjb3VudCByZWNlaXZlcikpXFxuICAgICAgICAgICAgIChwcm9wZXJ0eSAoIT0gc2VuZGVyIHJlY2VpdmVyKSkgXVxcblxcbiAgICAoZW5mb3JjZSAoIT0gc2VuZGVyIHJlY2VpdmVyKVxcbiAgICAgIFxcXCJzZW5kZXIgY2Fubm90IGJlIHRoZSByZWNlaXZlciBvZiBhIHRyYW5zZmVyXFxcIilcXG5cXG4gICAgKHZhbGlkYXRlLWFjY291bnQgc2VuZGVyKVxcbiAgICAodmFsaWRhdGUtYWNjb3VudCByZWNlaXZlcilcXG5cXG4gICAgKGVuZm9yY2UgKD4gYW1vdW50IDAuMClcXG4gICAgICBcXFwidHJhbnNmZXIgYW1vdW50IG11c3QgYmUgcG9zaXRpdmVcXFwiKVxcblxcbiAgICAoZW5mb3JjZS11bml0IGFtb3VudClcXG5cXG4gICAgKHdpdGgtY2FwYWJpbGl0eSAoVFJBTlNGRVIgc2VuZGVyIHJlY2VpdmVyIGFtb3VudClcXG4gICAgICAoZGViaXQgc2VuZGVyIGFtb3VudClcXG4gICAgICAod2l0aC1yZWFkIGNvaW4tdGFibGUgcmVjZWl2ZXJcXG4gICAgICAgIHsgXFxcImd1YXJkXFxcIiA6PSBnIH1cXG5cXG4gICAgICAgIChjcmVkaXQgcmVjZWl2ZXIgZyBhbW91bnQpKVxcbiAgICAgIClcXG4gICAgKVxcblxcbiAgKGRlZnVuIHRyYW5zZmVyLWNyZWF0ZTpzdHJpbmdcXG4gICAgKCBzZW5kZXI6c3RyaW5nXFxuICAgICAgcmVjZWl2ZXI6c3RyaW5nXFxuICAgICAgcmVjZWl2ZXItZ3VhcmQ6Z3VhcmRcXG4gICAgICBhbW91bnQ6ZGVjaW1hbCApXFxuXFxuICAgIEBtb2RlbCBbIChwcm9wZXJ0eSBjb25zZXJ2ZXMtbWFzcykgXVxcblxcbiAgICAoZW5mb3JjZSAoIT0gc2VuZGVyIHJlY2VpdmVyKVxcbiAgICAgIFxcXCJzZW5kZXIgY2Fubm90IGJlIHRoZSByZWNlaXZlciBvZiBhIHRyYW5zZmVyXFxcIilcXG5cXG4gICAgKHZhbGlkYXRlLWFjY291bnQgc2VuZGVyKVxcbiAgICAodmFsaWRhdGUtYWNjb3VudCByZWNlaXZlcilcXG5cXG4gICAgKGVuZm9yY2UgKD4gYW1vdW50IDAuMClcXG4gICAgICBcXFwidHJhbnNmZXIgYW1vdW50IG11c3QgYmUgcG9zaXRpdmVcXFwiKVxcblxcbiAgICAoZW5mb3JjZS11bml0IGFtb3VudClcXG5cXG4gICAgKHdpdGgtY2FwYWJpbGl0eSAoVFJBTlNGRVIgc2VuZGVyIHJlY2VpdmVyIGFtb3VudClcXG4gICAgICAoZGViaXQgc2VuZGVyIGFtb3VudClcXG4gICAgICAoY3JlZGl0IHJlY2VpdmVyIHJlY2VpdmVyLWd1YXJkIGFtb3VudCkpXFxuICAgIClcXG5cXG4gIChkZWZ1biBjb2luYmFzZTpzdHJpbmcgKGFjY291bnQ6c3RyaW5nIGFjY291bnQtZ3VhcmQ6Z3VhcmQgYW1vdW50OmRlY2ltYWwpXFxuICAgIEBkb2MgXFxcIkludGVybmFsIGZ1bmN0aW9uIGZvciB0aGUgaW5pdGlhbCBjcmVhdGlvbiBvZiBjb2lucy4gIFRoaXMgZnVuY3Rpb24gXFxcXFxcbiAgICBcXFxcY2Fubm90IGJlIHVzZWQgb3V0c2lkZSBvZiB0aGUgY29pbiBjb250cmFjdC5cXFwiXFxuXFxuICAgIEBtb2RlbCBbIChwcm9wZXJ0eSAodmFsaWQtYWNjb3VudCBhY2NvdW50KSlcXG4gICAgICAgICAgICAgKHByb3BlcnR5ICg-IGFtb3VudCAwLjApKVxcbiAgICAgICAgICAgXVxcblxcbiAgICAodmFsaWRhdGUtYWNjb3VudCBhY2NvdW50KVxcbiAgICAoZW5mb3JjZS11bml0IGFtb3VudClcXG5cXG4gICAgKHJlcXVpcmUtY2FwYWJpbGl0eSAoQ09JTkJBU0UpKVxcbiAgICAoZW1pdC1ldmVudCAoVFJBTlNGRVIgXFxcIlxcXCIgYWNjb3VudCBhbW91bnQpKSA7djNcXG4gICAgKHdpdGgtY2FwYWJpbGl0eSAoQ1JFRElUIGFjY291bnQpXFxuICAgICAgKGNyZWRpdCBhY2NvdW50IGFjY291bnQtZ3VhcmQgYW1vdW50KSlcXG4gICAgKVxcblxcbiAgKGRlZnVuIHJlbWVkaWF0ZTpzdHJpbmcgKGFjY291bnQ6c3RyaW5nIGFtb3VudDpkZWNpbWFsKVxcbiAgICBAZG9jIFxcXCJBbGxvd3MgZm9yIHJlbWVkaWF0aW9uIHRyYW5zYWN0aW9ucy4gVGhpcyBmdW5jdGlvbiBcXFxcXFxuICAgICAgICAgXFxcXGlzIHByb3RlY3RlZCBieSB0aGUgUkVNRURJQVRFIGNhcGFiaWxpdHlcXFwiXFxuICAgIEBtb2RlbCBbIChwcm9wZXJ0eSAodmFsaWQtYWNjb3VudCBhY2NvdW50KSlcXG4gICAgICAgICAgICAgKHByb3BlcnR5ICg-IGFtb3VudCAwLjApKVxcbiAgICAgICAgICAgXVxcblxcbiAgICAodmFsaWRhdGUtYWNjb3VudCBhY2NvdW50KVxcblxcbiAgICAoZW5mb3JjZSAoPiBhbW91bnQgMC4wKVxcbiAgICAgIFxcXCJSZW1lZGlhdGlvbiBhbW91bnQgbXVzdCBiZSBwb3NpdGl2ZVxcXCIpXFxuXFxuICAgIChlbmZvcmNlLXVuaXQgYW1vdW50KVxcblxcbiAgICAocmVxdWlyZS1jYXBhYmlsaXR5IChSRU1FRElBVEUpKVxcbiAgICAoZW1pdC1ldmVudCAoVFJBTlNGRVIgXFxcIlxcXCIgYWNjb3VudCBhbW91bnQpKSA7djNcXG4gICAgKHdpdGgtcmVhZCBjb2luLXRhYmxlIGFjY291bnRcXG4gICAgICB7IFxcXCJiYWxhbmNlXFxcIiA6PSBiYWxhbmNlIH1cXG5cXG4gICAgICAoZW5mb3JjZSAoPD0gYW1vdW50IGJhbGFuY2UpIFxcXCJJbnN1ZmZpY2llbnQgZnVuZHNcXFwiKVxcblxcbiAgICAgICh1cGRhdGUgY29pbi10YWJsZSBhY2NvdW50XFxuICAgICAgICB7IFxcXCJiYWxhbmNlXFxcIiA6ICgtIGJhbGFuY2UgYW1vdW50KSB9XFxuICAgICAgICApKVxcbiAgICApXFxuXFxuICAoZGVmcGFjdCBmdW5kLXR4IChzZW5kZXI6c3RyaW5nIG1pbmVyOnN0cmluZyBtaW5lci1ndWFyZDpndWFyZCB0b3RhbDpkZWNpbWFsKVxcbiAgICBAZG9jIFxcXCInZnVuZC10eCcgaXMgYSBzcGVjaWFsIHBhY3QgdG8gZnVuZCBhIHRyYW5zYWN0aW9uIGluIHR3byBzdGVwcywgICAgIFxcXFxcXG4gICAgXFxcXHdpdGggdGhlIGFjdHVhbCB0cmFuc2FjdGlvbiB0cmFuc3BpcmluZyBpbiB0aGUgbWlkZGxlOiAgICAgICAgICAgICAgICAgICBcXFxcXFxuICAgIFxcXFwgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgXFxcXFxcbiAgICBcXFxcICAxKSBBIGJ1eWluZyBwaGFzZSwgZGViaXRpbmcgdGhlIHNlbmRlciBmb3IgdG90YWwgZ2FzIGFuZCBmZWUsIHlpZWxkaW5nIFxcXFxcXG4gICAgXFxcXCAgICAgVFhfTUFYX0NIQVJHRS4gICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICBcXFxcXFxuICAgIFxcXFwgIDIpIEEgc2V0dGxlbWVudCBwaGFzZSwgcmVzdW1pbmcgVFhfTUFYX0NIQVJHRSwgYW5kIGFsbG9jYXRpbmcgdG8gdGhlICAgXFxcXFxcbiAgICBcXFxcICAgICBjb2luYmFzZSBhY2NvdW50IGZvciB1c2VkIGdhcyBhbmQgZmVlLCBhbmQgc2VuZGVyIGFjY291bnQgZm9yIGJhbC0gIFxcXFxcXG4gICAgXFxcXCAgICAgYW5jZSAodW51c2VkIGdhcywgaWYgYW55KS5cXFwiXFxuXFxuICAgIEBtb2RlbCBbIChwcm9wZXJ0eSAoPiB0b3RhbCAwLjApKVxcbiAgICAgICAgICAgICAocHJvcGVydHkgKHZhbGlkLWFjY291bnQgc2VuZGVyKSlcXG4gICAgICAgICAgICAgKHByb3BlcnR5ICh2YWxpZC1hY2NvdW50IG1pbmVyKSlcXG4gICAgICAgICAgICAgOyhwcm9wZXJ0eSBjb25zZXJ2ZXMtbWFzcykgbm90IHN1cHBvcnRlZCB5ZXRcXG4gICAgICAgICAgIF1cXG5cXG4gICAgKHN0ZXAgKGJ1eS1nYXMgc2VuZGVyIHRvdGFsKSlcXG4gICAgKHN0ZXAgKHJlZGVlbS1nYXMgbWluZXIgbWluZXItZ3VhcmQgc2VuZGVyIHRvdGFsKSlcXG4gICAgKVxcblxcbiAgKGRlZnVuIGRlYml0OnN0cmluZyAoYWNjb3VudDpzdHJpbmcgYW1vdW50OmRlY2ltYWwpXFxuICAgIEBkb2MgXFxcIkRlYml0IEFNT1VOVCBmcm9tIEFDQ09VTlQgYmFsYW5jZVxcXCJcXG5cXG4gICAgQG1vZGVsIFsgKHByb3BlcnR5ICg-IGFtb3VudCAwLjApKVxcbiAgICAgICAgICAgICAocHJvcGVydHkgKHZhbGlkLWFjY291bnQgYWNjb3VudCkpXFxuICAgICAgICAgICBdXFxuXFxuICAgICh2YWxpZGF0ZS1hY2NvdW50IGFjY291bnQpXFxuXFxuICAgIChlbmZvcmNlICg-IGFtb3VudCAwLjApXFxuICAgICAgXFxcImRlYml0IGFtb3VudCBtdXN0IGJlIHBvc2l0aXZlXFxcIilcXG5cXG4gICAgKGVuZm9yY2UtdW5pdCBhbW91bnQpXFxuXFxuICAgIChyZXF1aXJlLWNhcGFiaWxpdHkgKERFQklUIGFjY291bnQpKVxcbiAgICAod2l0aC1yZWFkIGNvaW4tdGFibGUgYWNjb3VudFxcbiAgICAgIHsgXFxcImJhbGFuY2VcXFwiIDo9IGJhbGFuY2UgfVxcblxcbiAgICAgIChlbmZvcmNlICg8PSBhbW91bnQgYmFsYW5jZSkgXFxcIkluc3VmZmljaWVudCBmdW5kc1xcXCIpXFxuXFxuICAgICAgKHVwZGF0ZSBjb2luLXRhYmxlIGFjY291bnRcXG4gICAgICAgIHsgXFxcImJhbGFuY2VcXFwiIDogKC0gYmFsYW5jZSBhbW91bnQpIH1cXG4gICAgICAgICkpXFxuICAgIClcXG5cXG5cXG4gIChkZWZ1biBjcmVkaXQ6c3RyaW5nIChhY2NvdW50OnN0cmluZyBndWFyZDpndWFyZCBhbW91bnQ6ZGVjaW1hbClcXG4gICAgQGRvYyBcXFwiQ3JlZGl0IEFNT1VOVCB0byBBQ0NPVU5UIGJhbGFuY2VcXFwiXFxuXFxuICAgIEBtb2RlbCBbIChwcm9wZXJ0eSAoPiBhbW91bnQgMC4wKSlcXG4gICAgICAgICAgICAgKHByb3BlcnR5ICh2YWxpZC1hY2NvdW50IGFjY291bnQpKVxcbiAgICAgICAgICAgXVxcblxcbiAgICAodmFsaWRhdGUtYWNjb3VudCBhY2NvdW50KVxcblxcbiAgICAoZW5mb3JjZSAoPiBhbW91bnQgMC4wKSBcXFwiY3JlZGl0IGFtb3VudCBtdXN0IGJlIHBvc2l0aXZlXFxcIilcXG4gICAgKGVuZm9yY2UtdW5pdCBhbW91bnQpXFxuXFxuICAgIChyZXF1aXJlLWNhcGFiaWxpdHkgKENSRURJVCBhY2NvdW50KSlcXG4gICAgKHdpdGgtZGVmYXVsdC1yZWFkIGNvaW4tdGFibGUgYWNjb3VudFxcbiAgICAgIHsgXFxcImJhbGFuY2VcXFwiIDogLTEuMCwgXFxcImd1YXJkXFxcIiA6IGd1YXJkIH1cXG4gICAgICB7IFxcXCJiYWxhbmNlXFxcIiA6PSBiYWxhbmNlLCBcXFwiZ3VhcmRcXFwiIDo9IHJldGcgfVxcbiAgICAgIDsgd2UgZG9uJ3Qgd2FudCB0byBvdmVyd3JpdGUgYW4gZXhpc3RpbmcgZ3VhcmQgd2l0aCB0aGUgdXNlci1zdXBwbGllZCBvbmVcXG4gICAgICAoZW5mb3JjZSAoPSByZXRnIGd1YXJkKVxcbiAgICAgICAgXFxcImFjY291bnQgZ3VhcmRzIGRvIG5vdCBtYXRjaFxcXCIpXFxuXFxuICAgICAgKGxldCAoKGlzLW5ld1xcbiAgICAgICAgICAgICAoaWYgKD0gYmFsYW5jZSAtMS4wKVxcbiAgICAgICAgICAgICAgICAgKGVuZm9yY2UtcmVzZXJ2ZWQgYWNjb3VudCBndWFyZClcXG4gICAgICAgICAgICAgICBmYWxzZSkpKVxcblxcbiAgICAgICAgKHdyaXRlIGNvaW4tdGFibGUgYWNjb3VudFxcbiAgICAgICAgICB7IFxcXCJiYWxhbmNlXFxcIiA6IChpZiBpcy1uZXcgYW1vdW50ICgrIGJhbGFuY2UgYW1vdW50KSlcXG4gICAgICAgICAgLCBcXFwiZ3VhcmRcXFwiICAgOiByZXRnXFxuICAgICAgICAgIH0pKVxcbiAgICAgICkpXFxuXFxuICAoZGVmdW4gY2hlY2stcmVzZXJ2ZWQ6c3RyaW5nIChhY2NvdW50OnN0cmluZylcXG4gICAgXFxcIiBDaGVja3MgQUNDT1VOVCBmb3IgcmVzZXJ2ZWQgbmFtZSBhbmQgcmV0dXJucyB0eXBlIGlmIFxcXFxcXG4gICAgXFxcXCBmb3VuZCBvciBlbXB0eSBzdHJpbmcuIFJlc2VydmVkIG5hbWVzIHN0YXJ0IHdpdGggYSBcXFxcXFxuICAgIFxcXFwgc2luZ2xlIGNoYXIgYW5kIGNvbG9uLCBlLmcuICdjOmZvbycsIHdoaWNoIHdvdWxkIHJldHVybiAnYycgYXMgdHlwZS5cXFwiXFxuICAgIChsZXQgKChwZnggKHRha2UgMiBhY2NvdW50KSkpXFxuICAgICAgKGlmICg9IFxcXCI6XFxcIiAodGFrZSAtMSBwZngpKSAodGFrZSAxIHBmeCkgXFxcIlxcXCIpKSlcXG5cXG4gIChkZWZ1biBlbmZvcmNlLXJlc2VydmVkOmJvb2wgKGFjY291bnQ6c3RyaW5nIGd1YXJkOmd1YXJkKVxcbiAgICBAZG9jIFxcXCJFbmZvcmNlIHJlc2VydmVkIGFjY291bnQgbmFtZSBwcm90b2NvbHMuXFxcIlxcbiAgICAoaWYgKHZhbGlkYXRlLXByaW5jaXBhbCBndWFyZCBhY2NvdW50KVxcbiAgICAgIHRydWVcXG4gICAgICAobGV0ICgociAoY2hlY2stcmVzZXJ2ZWQgYWNjb3VudCkpKVxcbiAgICAgICAgKGlmICg9IHIgXFxcIlxcXCIpXFxuICAgICAgICAgIHRydWVcXG4gICAgICAgICAgKGlmICg9IHIgXFxcImtcXFwiKVxcbiAgICAgICAgICAgIChlbmZvcmNlIGZhbHNlIFxcXCJTaW5nbGUta2V5IGFjY291bnQgcHJvdG9jb2wgdmlvbGF0aW9uXFxcIilcXG4gICAgICAgICAgICAoZW5mb3JjZSBmYWxzZVxcbiAgICAgICAgICAgICAgKGZvcm1hdCBcXFwiUmVzZXJ2ZWQgcHJvdG9jb2wgZ3VhcmQgdmlvbGF0aW9uOiB7fVxcXCIgW3JdKSlcXG4gICAgICAgICAgICApKSkpKVxcblxcblxcbiAgKGRlZnNjaGVtYSBjcm9zc2NoYWluLXNjaGVtYVxcbiAgICBAZG9jIFxcXCJTY2hlbWEgZm9yIHlpZWxkZWQgdmFsdWUgaW4gY3Jvc3MtY2hhaW4gdHJhbnNmZXJzXFxcIlxcbiAgICByZWNlaXZlcjpzdHJpbmdcXG4gICAgcmVjZWl2ZXItZ3VhcmQ6Z3VhcmRcXG4gICAgYW1vdW50OmRlY2ltYWxcXG4gICAgc291cmNlLWNoYWluOnN0cmluZylcXG5cXG4gIChkZWZwYWN0IHRyYW5zZmVyLWNyb3NzY2hhaW46c3RyaW5nXFxuICAgICggc2VuZGVyOnN0cmluZ1xcbiAgICAgIHJlY2VpdmVyOnN0cmluZ1xcbiAgICAgIHJlY2VpdmVyLWd1YXJkOmd1YXJkXFxuICAgICAgdGFyZ2V0LWNoYWluOnN0cmluZ1xcbiAgICAgIGFtb3VudDpkZWNpbWFsIClcXG5cXG4gICAgQG1vZGVsIFsgKHByb3BlcnR5ICg-IGFtb3VudCAwLjApKVxcbiAgICAgICAgICAgICAocHJvcGVydHkgKHZhbGlkLWFjY291bnQgc2VuZGVyKSlcXG4gICAgICAgICAgICAgKHByb3BlcnR5ICh2YWxpZC1hY2NvdW50IHJlY2VpdmVyKSlcXG4gICAgICAgICAgIF1cXG5cXG4gICAgKHN0ZXBcXG4gICAgICAod2l0aC1jYXBhYmlsaXR5XFxuICAgICAgICAoVFJBTlNGRVJfWENIQUlOIHNlbmRlciByZWNlaXZlciBhbW91bnQgdGFyZ2V0LWNoYWluKVxcblxcbiAgICAgICAgKHZhbGlkYXRlLWFjY291bnQgc2VuZGVyKVxcbiAgICAgICAgKHZhbGlkYXRlLWFjY291bnQgcmVjZWl2ZXIpXFxuXFxuICAgICAgICAoZW5mb3JjZSAoIT0gXFxcIlxcXCIgdGFyZ2V0LWNoYWluKSBcXFwiZW1wdHkgdGFyZ2V0LWNoYWluXFxcIilcXG4gICAgICAgIChlbmZvcmNlICghPSAoYXQgJ2NoYWluLWlkIChjaGFpbi1kYXRhKSkgdGFyZ2V0LWNoYWluKVxcbiAgICAgICAgICBcXFwiY2Fubm90IHJ1biBjcm9zcy1jaGFpbiB0cmFuc2ZlcnMgdG8gdGhlIHNhbWUgY2hhaW5cXFwiKVxcblxcbiAgICAgICAgKGVuZm9yY2UgKD4gYW1vdW50IDAuMClcXG4gICAgICAgICAgXFxcInRyYW5zZmVyIHF1YW50aXR5IG11c3QgYmUgcG9zaXRpdmVcXFwiKVxcblxcbiAgICAgICAgKGVuZm9yY2UtdW5pdCBhbW91bnQpXFxuXFxuICAgICAgICAoZW5mb3JjZSAoY29udGFpbnMgdGFyZ2V0LWNoYWluIFZBTElEX0NIQUlOX0lEUylcXG4gICAgICAgICAgXFxcInRhcmdldCBjaGFpbiBpcyBub3QgYSB2YWxpZCBjaGFpbndlYiBjaGFpbiBpZFxcXCIpXFxuXFxuICAgICAgICA7OyBzdGVwIDEgLSBkZWJpdCBkZWxldGUtYWNjb3VudCBvbiBjdXJyZW50IGNoYWluXFxuICAgICAgICAoZGViaXQgc2VuZGVyIGFtb3VudClcXG4gICAgICAgIChlbWl0LWV2ZW50IChUUkFOU0ZFUiBzZW5kZXIgXFxcIlxcXCIgYW1vdW50KSlcXG5cXG4gICAgICAgIChsZXRcXG4gICAgICAgICAgKChjcm9zc2NoYWluLWRldGFpbHM6b2JqZWN0e2Nyb3NzY2hhaW4tc2NoZW1hfVxcbiAgICAgICAgICAgIHsgXFxcInJlY2VpdmVyXFxcIiA6IHJlY2VpdmVyXFxuICAgICAgICAgICAgLCBcXFwicmVjZWl2ZXItZ3VhcmRcXFwiIDogcmVjZWl2ZXItZ3VhcmRcXG4gICAgICAgICAgICAsIFxcXCJhbW91bnRcXFwiIDogYW1vdW50XFxuICAgICAgICAgICAgLCBcXFwic291cmNlLWNoYWluXFxcIiA6IChhdCAnY2hhaW4taWQgKGNoYWluLWRhdGEpKVxcbiAgICAgICAgICAgIH0pKVxcbiAgICAgICAgICAoeWllbGQgY3Jvc3NjaGFpbi1kZXRhaWxzIHRhcmdldC1jaGFpbilcXG4gICAgICAgICAgKSkpXFxuXFxuICAgIChzdGVwXFxuICAgICAgKHJlc3VtZVxcbiAgICAgICAgeyBcXFwicmVjZWl2ZXJcXFwiIDo9IHJlY2VpdmVyXFxuICAgICAgICAsIFxcXCJyZWNlaXZlci1ndWFyZFxcXCIgOj0gcmVjZWl2ZXItZ3VhcmRcXG4gICAgICAgICwgXFxcImFtb3VudFxcXCIgOj0gYW1vdW50XFxuICAgICAgICAsIFxcXCJzb3VyY2UtY2hhaW5cXFwiIDo9IHNvdXJjZS1jaGFpblxcbiAgICAgICAgfVxcblxcbiAgICAgICAgKGVtaXQtZXZlbnQgKFRSQU5TRkVSIFxcXCJcXFwiIHJlY2VpdmVyIGFtb3VudCkpXFxuICAgICAgICAoZW1pdC1ldmVudCAoVFJBTlNGRVJfWENIQUlOX1JFQ0QgXFxcIlxcXCIgcmVjZWl2ZXIgYW1vdW50IHNvdXJjZS1jaGFpbikpXFxuXFxuICAgICAgICA7OyBzdGVwIDIgLSBjcmVkaXQgY3JlYXRlIGFjY291bnQgb24gdGFyZ2V0IGNoYWluXFxuICAgICAgICAod2l0aC1jYXBhYmlsaXR5IChDUkVESVQgcmVjZWl2ZXIpXFxuICAgICAgICAgIChjcmVkaXQgcmVjZWl2ZXIgcmVjZWl2ZXItZ3VhcmQgYW1vdW50KSlcXG4gICAgICAgICkpXFxuICAgIClcXG5cXG5cXG4gIDsgLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS1cXG4gIDsgQ29pbiBhbGxvY2F0aW9uc1xcblxcbiAgKGRlZnNjaGVtYSBhbGxvY2F0aW9uLXNjaGVtYVxcbiAgICBAZG9jIFxcXCJHZW5lc2lzIGFsbG9jYXRpb24gcmVnaXN0cnlcXFwiXFxuICAgIDtAbW9kZWwgWyAoaW52YXJpYW50ICg-PSBiYWxhbmNlIDAuMCkpIF1cXG5cXG4gICAgYmFsYW5jZTpkZWNpbWFsXFxuICAgIGRhdGU6dGltZVxcbiAgICBndWFyZDpndWFyZFxcbiAgICByZWRlZW1lZDpib29sKVxcblxcbiAgKGRlZnRhYmxlIGFsbG9jYXRpb24tdGFibGU6e2FsbG9jYXRpb24tc2NoZW1hfSlcXG5cXG4gIChkZWZ1biBjcmVhdGUtYWxsb2NhdGlvbi1hY2NvdW50XFxuICAgICggYWNjb3VudDpzdHJpbmdcXG4gICAgICBkYXRlOnRpbWVcXG4gICAgICBrZXlzZXQtcmVmOnN0cmluZ1xcbiAgICAgIGFtb3VudDpkZWNpbWFsXFxuICAgIClcXG5cXG4gICAgQGRvYyBcXFwiQWRkIGFuIGVudHJ5IHRvIHRoZSBjb2luIGFsbG9jYXRpb24gdGFibGUuIFRoaXMgZnVuY3Rpb24gXFxcXFxcbiAgICAgICAgIFxcXFxhbHNvIGNyZWF0ZXMgYSBjb3JyZXNwb25kaW5nIGVtcHR5IGNvaW4gY29udHJhY3QgYWNjb3VudCBcXFxcXFxuICAgICAgICAgXFxcXG9mIHRoZSBzYW1lIG5hbWUgYW5kIGd1YXJkLiBSZXF1aXJlcyBHRU5FU0lTIGNhcGFiaWxpdHkuIFxcXCJcXG5cXG4gICAgQG1vZGVsIFsgKHByb3BlcnR5ICh2YWxpZC1hY2NvdW50IGFjY291bnQpKSBdXFxuXFxuICAgIChyZXF1aXJlLWNhcGFiaWxpdHkgKEdFTkVTSVMpKVxcblxcbiAgICAodmFsaWRhdGUtYWNjb3VudCBhY2NvdW50KVxcbiAgICAoZW5mb3JjZSAoPj0gYW1vdW50IDAuMClcXG4gICAgICBcXFwiYWxsb2NhdGlvbiBhbW91bnQgbXVzdCBiZSBub24tbmVnYXRpdmVcXFwiKVxcblxcbiAgICAoZW5mb3JjZS11bml0IGFtb3VudClcXG5cXG4gICAgKGxldFxcbiAgICAgICgoZ3VhcmQ6Z3VhcmQgKGtleXNldC1yZWYtZ3VhcmQga2V5c2V0LXJlZikpKVxcblxcbiAgICAgIChjcmVhdGUtYWNjb3VudCBhY2NvdW50IGd1YXJkKVxcblxcbiAgICAgIChpbnNlcnQgYWxsb2NhdGlvbi10YWJsZSBhY2NvdW50XFxuICAgICAgICB7IFxcXCJiYWxhbmNlXFxcIiA6IGFtb3VudFxcbiAgICAgICAgLCBcXFwiZGF0ZVxcXCIgOiBkYXRlXFxuICAgICAgICAsIFxcXCJndWFyZFxcXCIgOiBndWFyZFxcbiAgICAgICAgLCBcXFwicmVkZWVtZWRcXFwiIDogZmFsc2VcXG4gICAgICAgIH0pKSlcXG5cXG4gIChkZWZ1biByZWxlYXNlLWFsbG9jYXRpb25cXG4gICAgKCBhY2NvdW50OnN0cmluZyApXFxuXFxuICAgIEBkb2MgXFxcIlJlbGVhc2UgZnVuZHMgYXNzb2NpYXRlZCB3aXRoIGFsbG9jYXRpb24gQUNDT1VOVCBpbnRvIG1haW4gbGVkZ2VyLiAgIFxcXFxcXG4gICAgICAgICBcXFxcQUNDT1VOVCBtdXN0IGFscmVhZHkgZXhpc3QgaW4gbWFpbiBsZWRnZXIuIEFsbG9jYXRpb24gaXMgZGVhY3RpdmF0ZWQgXFxcXFxcbiAgICAgICAgIFxcXFxhZnRlciByZWxlYXNlLlxcXCJcXG4gICAgQG1vZGVsIFsgKHByb3BlcnR5ICh2YWxpZC1hY2NvdW50IGFjY291bnQpKSBdXFxuXFxuICAgICh2YWxpZGF0ZS1hY2NvdW50IGFjY291bnQpXFxuXFxuICAgICh3aXRoLXJlYWQgYWxsb2NhdGlvbi10YWJsZSBhY2NvdW50XFxuICAgICAgeyBcXFwiYmFsYW5jZVxcXCIgOj0gYmFsYW5jZVxcbiAgICAgICwgXFxcImRhdGVcXFwiIDo9IHJlbGVhc2UtdGltZVxcbiAgICAgICwgXFxcInJlZGVlbWVkXFxcIiA6PSByZWRlZW1lZFxcbiAgICAgICwgXFxcImd1YXJkXFxcIiA6PSBndWFyZFxcbiAgICAgIH1cXG5cXG4gICAgICAobGV0ICgoY3Vyci10aW1lOnRpbWUgKGF0ICdibG9jay10aW1lIChjaGFpbi1kYXRhKSkpKVxcblxcbiAgICAgICAgKGVuZm9yY2UgKG5vdCByZWRlZW1lZClcXG4gICAgICAgICAgXFxcImFsbG9jYXRpb24gZnVuZHMgaGF2ZSBhbHJlYWR5IGJlZW4gcmVkZWVtZWRcXFwiKVxcblxcbiAgICAgICAgKGVuZm9yY2VcXG4gICAgICAgICAgKD49IGN1cnItdGltZSByZWxlYXNlLXRpbWUpXFxuICAgICAgICAgIChmb3JtYXQgXFxcImZ1bmRzIGxvY2tlZCB1bnRpbCB7fS4gY3VycmVudCB0aW1lOiB7fVxcXCIgW3JlbGVhc2UtdGltZSBjdXJyLXRpbWVdKSlcXG5cXG4gICAgICAgICh3aXRoLWNhcGFiaWxpdHkgKFJFTEVBU0VfQUxMT0NBVElPTiBhY2NvdW50IGJhbGFuY2UpXFxuXFxuICAgICAgICAoZW5mb3JjZS1ndWFyZCBndWFyZClcXG5cXG4gICAgICAgICh3aXRoLWNhcGFiaWxpdHkgKENSRURJVCBhY2NvdW50KVxcbiAgICAgICAgICAoZW1pdC1ldmVudCAoVFJBTlNGRVIgXFxcIlxcXCIgYWNjb3VudCBiYWxhbmNlKSlcXG4gICAgICAgICAgKGNyZWRpdCBhY2NvdW50IGd1YXJkIGJhbGFuY2UpXFxuXFxuICAgICAgICAgICh1cGRhdGUgYWxsb2NhdGlvbi10YWJsZSBhY2NvdW50XFxuICAgICAgICAgICAgeyBcXFwicmVkZWVtZWRcXFwiIDogdHJ1ZVxcbiAgICAgICAgICAgICwgXFxcImJhbGFuY2VcXFwiIDogMC4wXFxuICAgICAgICAgICAgfSlcXG5cXG4gICAgICAgICAgXFxcIkFsbG9jYXRpb24gc3VjY2Vzc2Z1bGx5IHJlbGVhc2VkIHRvIG1haW4gbGVkZ2VyXFxcIikpXFxuICAgICkpKVxcblxcbilcXG5cXG4oY3JlYXRlLXRhYmxlIGNvaW4tdGFibGUpXFxuKGNyZWF0ZS10YWJsZSBhbGxvY2F0aW9uLXRhYmxlKVxcblwifX0sXCJzaWduZXJzXCI6W10sXCJtZXRhXCI6e1wiY3JlYXRpb25UaW1lXCI6MCxcInR0bFwiOjE3MjgwMCxcImdhc0xpbWl0XCI6MCxcImNoYWluSWRcIjpcIlwiLFwiZ2FzUHJpY2VcIjowLFwic2VuZGVyXCI6XCJcIn0sXCJub25jZVwiOlwiY29pbi1jb250cmFjdC12Ni1pbnN0YWxsXCJ9In0", unsafeFromText "eyJnYXMiOjEsInJlc3VsdCI6eyJzdGF0dXMiOiJzdWNjZXNzIiwiZGF0YSI6IlRhYmxlQ3JlYXRlZCJ9LCJyZXFLZXkiOiJHUklRdTRoQUtrMElEOUY4el8tMHlYeUFLSjMzTVB5VFlNWE9qbFBKbXBJIiwibG9ncyI6IkxKWlA1V2ZFN1VfNGZINWltQm56dE94ZndyWWN0enQtdmNoSkRvUXN2T1EiLCJtZXRhRGF0YSI6bnVsbCwiY29udGludWF0aW9uIjpudWxsLCJ0eElkIjozfQ") - , (unsafeFromText "eyJoYXNoIjoiU0IzVzVFTGl6azl4elNWWk9MX3dsem5VNjh5aUhPQzlwWUhreHBVXzBnbyIsInNpZ3MiOltdLCJjbWQiOiJ7XCJuZXR3b3JrSWRcIjpudWxsLFwicGF5bG9hZFwiOntcImV4ZWNcIjp7XCJkYXRhXCI6bnVsbCxcImNvZGVcIjpcIihpbnRlcmZhY2UgZ2FzLXBheWVyLXYxXFxuXFxuICAoZGVmY2FwIEdBU19QQVlFUjpib29sXFxuICAgICggdXNlcjpzdHJpbmdcXG4gICAgICBsaW1pdDppbnRlZ2VyXFxuICAgICAgcHJpY2U6ZGVjaW1hbFxcbiAgICApXFxuICAgIEBkb2NcXG4gICAgXFxcIiBQcm92aWRlIGEgY2FwYWJpbGl0eSBpbmRpY2F0aW5nIHRoYXQgZGVjbGFyaW5nIG1vZHVsZSBzdXBwb3J0cyBcXFxcXFxuICAgIFxcXFwgZ2FzIHBheW1lbnQgZm9yIFVTRVIgZm9yIGdhcyBMSU1JVCBhbmQgUFJJQ0UuIEZ1bmN0aW9uYWxpdHkgXFxcXFxcbiAgICBcXFxcIHNob3VsZCByZXF1aXJlIGNhcGFiaWxpdHkgKGNvaW4uRlVORF9UWCksIGFuZCBzaG91bGQgdmFsaWRhdGUgXFxcXFxcbiAgICBcXFxcIHRoZSBzcGVuZCBvZiAobGltaXQgKiBwcmljZSksIHBvc3NpYmx5IHVwZGF0aW5nIHNvbWUgZGF0YWJhc2UgXFxcXFxcbiAgICBcXFxcIGVudHJ5LiBcXFxcXFxuICAgIFxcXFwgU2hvdWxkIGNvbXBvc2UgY2FwYWJpbGl0eSByZXF1aXJlZCBmb3IgJ2NyZWF0ZS1nYXMtcGF5ZXItZ3VhcmQnLlxcXCJcXG4gICAgQG1vZGVsXFxuICAgIFsgKHByb3BlcnR5ICh1c2VyICE9IFxcXCJcXFwiKSlcXG4gICAgICAocHJvcGVydHkgKGxpbWl0ID4gMCkpXFxuICAgICAgKHByb3BlcnR5IChwcmljZSA-IDAuMCkpXFxuICAgIF1cXG4gIClcXG5cXG4gIChkZWZ1biBjcmVhdGUtZ2FzLXBheWVyLWd1YXJkOmd1YXJkICgpXFxuICAgIEBkb2NcXG4gICAgXFxcIiBQcm92aWRlIGEgZ3VhcmQgc3VpdGFibGUgZm9yIGNvbnRyb2xsaW5nIGEgY29pbiBhY2NvdW50IHRoYXQgY2FuIFxcXFxcXG4gICAgXFxcXCBwYXkgZ2FzIHZpYSBHQVNfUEFZRVIgbWVjaGFuaWNzLiBHZW5lcmFsbHkgdGhpcyBpcyBhY2NvbXBsaXNoZWQgXFxcXFxcbiAgICBcXFxcIGJ5IGhhdmluZyBHQVNfUEFZRVIgY29tcG9zZSBhbiB1bnBhcmFtZXRlcml6ZWQsIHVubWFuYWdlZCBjYXBhYmlsaXR5IFxcXFxcXG4gICAgXFxcXCB0aGF0IGlzIHJlcXVpcmVkIGluIHRoaXMgZ3VhcmQuIFRodXMsIGlmIGNvaW4gY29udHJhY3QgaXMgYWJsZSB0byBcXFxcXFxuICAgIFxcXFwgc3VjY2Vzc2Z1bGx5IGFjcXVpcmUgR0FTX1BBWUVSLCB0aGUgY29tcG9zZWQgJ2Fub255bW91cycgY2FwIHJlcXVpcmVkIFxcXFxcXG4gICAgXFxcXCBoZXJlIHdpbGwgYmUgaW4gc2NvcGUsIGFuZCBnYXMgYnV5IHdpbGwgc3VjY2VlZC5cXFwiXFxuICApXFxuXFxuKVxcblwifX0sXCJzaWduZXJzXCI6W10sXCJtZXRhXCI6e1wiY3JlYXRpb25UaW1lXCI6MCxcInR0bFwiOjE3MjgwMCxcImdhc0xpbWl0XCI6MCxcImNoYWluSWRcIjpcIlwiLFwiZ2FzUHJpY2VcIjowLFwic2VuZGVyXCI6XCJcIn0sXCJub25jZVwiOlwiZ2VuZXNpcy0wMVwifSJ9", unsafeFromText "eyJnYXMiOjEsInJlc3VsdCI6eyJzdGF0dXMiOiJzdWNjZXNzIiwiZGF0YSI6IkxvYWRlZCBpbnRlcmZhY2UgZ2FzLXBheWVyLXYxLCBoYXNoIGlJV0FQMW9lbl9rcFhqRmJuUU04N0FKUlpJZ3RzZlpjQXdZckV5MjFSV1EifSwicmVxS2V5IjoiU0IzVzVFTGl6azl4elNWWk9MX3dsem5VNjh5aUhPQzlwWUhreHBVXzBnbyIsImxvZ3MiOiJ3TXdXV3hkSFVuU1VOWXJ1RXlISEtTTzUyeGtkVXU0TXBmbE1FcHYyT05FIiwibWV0YURhdGEiOm51bGwsImNvbnRpbnVhdGlvbiI6bnVsbCwidHhJZCI6NH0") - , (unsafeFromText "eyJoYXNoIjoiQ1pteWxXZmllUk1CTXU1dzJFT21wRndLLXQ3YmNPVHM0bUsyYVQzM3VSNCIsInNpZ3MiOltdLCJjbWQiOiJ7XCJuZXR3b3JrSWRcIjpudWxsLFwicGF5bG9hZFwiOntcImV4ZWNcIjp7XCJkYXRhXCI6e1wibnMtYWRtaW4ta2V5c2V0XCI6W1wiMzY4ODIwZjgwYzMyNGJiYzdjMmIwNjEwNjg4YTdkYTQzZTM5ZjkxZDExODczMjY3MWNkOWM3NTAwZmY0M2NjYVwiXSxcIm5zLW9wZXJhdGUta2V5c2V0XCI6W1wiMzY4ODIwZjgwYzMyNGJiYzdjMmIwNjEwNjg4YTdkYTQzZTM5ZjkxZDExODczMjY3MWNkOWM3NTAwZmY0M2NjYVwiXSxcIm5zLWdlbmVzaXMta2V5c2V0XCI6e1wicHJlZFwiOlwiPVwiLFwia2V5c1wiOltdfX0sXCJjb2RlXCI6XCIoZGVmaW5lLWtleXNldCAnbnMtYWRtaW4ta2V5c2V0IChyZWFkLWtleXNldCAnbnMtYWRtaW4ta2V5c2V0KSlcXG4oZGVmaW5lLWtleXNldCAnbnMtb3BlcmF0ZS1rZXlzZXQgKHJlYWQta2V5c2V0ICducy1nZW5lc2lzLWtleXNldCkpXFxuXFxuKG1vZHVsZSBucyBHT1ZFUk5BTkNFXFxuICBcXFwiQWRtaW5pc3RlcnMgZGVmaW5pdGlvbiBvZiBuZXcgbmFtZXNwYWNlcyBpbiBDaGFpbndlYi5cXFwiXFxuXFxuICAoZGVmc2NoZW1hIHJlZy1lbnRyeVxcbiAgICBhZG1pbi1ndWFyZDpndWFyZFxcbiAgICBhY3RpdmU6Ym9vbClcXG5cXG4gIChkZWZ0YWJsZSByZWdpc3RyeTp7cmVnLWVudHJ5fSlcXG5cXG4gIChkZWZjYXAgR09WRVJOQU5DRSAoKVxcbiAgICAoZW5mb3JjZS1rZXlzZXQgJ25zLWFkbWluLWtleXNldCkpXFxuXFxuICAoZGVmY2FwIE9QRVJBVEUgKClcXG4gICAgKGVuZm9yY2Uta2V5c2V0ICducy1vcGVyYXRlLWtleXNldCkpXFxuXFxuICAoZGVmY29uc3QgR1VBUkRfU1VDQ0VTUyAoY3JlYXRlLXVzZXItZ3VhcmQgKHN1Y2Nlc3MpKSlcXG4gIChkZWZjb25zdCBHVUFSRF9GQUlMVVJFIChjcmVhdGUtdXNlci1ndWFyZCAoZmFpbHVyZSkpKVxcblxcbiAgKGRlZnVuIHN1Y2Nlc3MgKClcXG4gICAgdHJ1ZSlcXG4gIChkZWZ1biBmYWlsdXJlICgpXFxuICAgIChlbmZvcmNlIGZhbHNlIFxcXCJEaXNhYmxlZFxcXCIpKVxcblxcbiAgKGRlZnVuIHZhbGlkYXRlLW5hbWUgKG5hbWUpXFxuICAgIChlbmZvcmNlICghPSBcXFwiXFxcIiBuYW1lKSBcXFwiRW1wdHkgbmFtZSBub3QgYWxsb3dlZFxcXCIpXFxuICAgIChlbmZvcmNlICg8IChsZW5ndGggbmFtZSkgNjQpIFxcXCJOYW1lIG11c3QgYmUgbGVzcyB0aGFuIDY0IGNoYXJhY3RlcnMgbG9uZ1xcXCIpXFxuICAgIChlbmZvcmNlIChpcy1jaGFyc2V0IENIQVJTRVRfTEFUSU4xIG5hbWUpXFxuICAgICAgICAgICAgIFxcXCJOYW1lIG11c3QgYmUgaW4gbGF0aW4xIGNoYXJzZXRcXFwiKSlcXG5cXG4gIChkZWZ1biBjcmVhdGUtcHJpbmNpcGFsLW5hbWVzcGFjZTpzdHJpbmdcXG4gICAgICAoIGc6Z3VhcmRcXG4gICAgICAgIClcXG4gICAgXFxcIiBGb3JtYXQgcHJpbmNpcGFsIG5hbWVzcGFjZSBhcyBQYWN0IGhhc2ggKEJMQUtFMmIyNTYpIG9mIHByaW5jaXBhbCBcXFxcXFxuICAgIFxcXFwgaW4gaGV4IHRydW5jYXRlZCB0byAxNjAgYml0cyAoNDAgY2hhcmFjdGVycyksIHByZXBlbmRlZCB3aXRoICduXycuXFxcXFxcbiAgICBcXFxcIE9ubHkgdzogYW5kIGs6IGFjY291bnQgcHJvdG9jb2xzIGFyZSBzdXBwb3J0ZWQuIFxcXCJcXG5cXG4gICAgKGxldFxcbiAgICAgICgodHkgKHR5cGVvZi1wcmluY2lwYWwgKGNyZWF0ZS1wcmluY2lwYWwgZykpKSlcXG5cXG4gICAgICA7OyBvbmx5IHc6IGFuZCBrOiBjdXJyZW50bHkgc3VwcG9ydGVkXFxuICAgICAgKGlmIChvciAoPSB0eSBcXFwiazpcXFwiKSAoPSB0eSBcXFwidzpcXFwiKSlcXG4gICAgICAgICgrIFxcXCJuX1xcXCIgKHRha2UgNDAgKGludC10by1zdHIgMTYgKHN0ci10by1pbnQgNjQgKGhhc2ggZykpKSkpXFxuICAgICAgICAoZW5mb3JjZSBmYWxzZVxcbiAgICAgICAgICAoZm9ybWF0IFxcXCJVbnN1cHBvcnRlZCBndWFyZCBwcm90b2NvbDoge31cXFwiIFt0eV0pKVxcbiAgICAgICAgKSlcXG4gIClcXG5cXG4gIChkZWZ1biB2YWxpZGF0ZTpib29sXFxuICAgICAgKCBucy1uYW1lOnN0cmluZ1xcbiAgICAgICAgbnMtYWRtaW46Z3VhcmRcXG4gICAgICAgIClcXG4gICAgXFxcIiBNYW5hZ2VzIG5hbWVzcGFjZSBpbnN0YWxsIGZvciBDaGFpbndlYi4gXFxcXFxcbiAgICBcXFxcIEFsbG93cyBwcmluY2lwYWwgbmFtZXNwYWNlcy4gXFxcXFxcbiAgICBcXFxcIE5vbi1wcmluY2lwYWwgbmFtZXNwYWNlcyByZXF1aXJlIGFjdGl2ZSByb3cgaW4gcmVnaXN0cnkgXFxcXFxcbiAgICBcXFxcIGZvciBOUy1OQU1FIHdpdGggZ3VhcmQgbWF0Y2hpbmcgTlMtQURNSU4uXFxcIlxcblxcbiAgICAoaWYgKD0gKGNyZWF0ZS1wcmluY2lwYWwtbmFtZXNwYWNlIG5zLWFkbWluKSBucy1uYW1lKVxcblxcbiAgICAgIHRydWUgOzsgYWxsb3cgcHJpbmNpcGFsIG5hbWVzcGFjZXNcXG5cXG4gICAgICAod2l0aC1kZWZhdWx0LXJlYWQgcmVnaXN0cnkgbnMtbmFtZSAgICAgICA7OyBvdGhlcndpc2UgZW5mb3JjZSByZWdpc3RyeVxcbiAgICAgICAgeyAnYWRtaW4tZ3VhcmQgOiBucy1hZG1pblxcbiAgICAgICAgLCAnYWN0aXZlIDogZmFsc2UgfVxcbiAgICAgICAgeyAnYWRtaW4tZ3VhcmQgOj0gYWdcXG4gICAgICAgICwgJ2FjdGl2ZSA6PSBpcy1hY3RpdmUgfVxcblxcbiAgICAgICAgKGVuZm9yY2UgaXMtYWN0aXZlIFxcXCJJbmFjdGl2ZSBvciB1bnJlZ2lzdGVyZWQgbmFtZXNwYWNlXFxcIilcXG4gICAgICAgIChlbmZvcmNlICg9IG5zLWFkbWluIGFnKSBcXFwiQWRtaW4gZ3VhcmQgbXVzdCBtYXRjaCBndWFyZCBpbiByZWdpc3RyeVxcXCIpXFxuXFxuICAgICAgICB0cnVlKVxcbiAgICAgICkpXFxuXFxuICAoZGVmdW4gd3JpdGUtcmVnaXN0cnk6c3RyaW5nXFxuICAgICAgKCBucy1uYW1lOnN0cmluZ1xcbiAgICAgICAgZ3VhcmQ6Z3VhcmRcXG4gICAgICAgIGFjdGl2ZTpib29sXFxuICAgICAgICApXFxuICAgIFxcXCIgV3JpdGUgZW50cnkgd2l0aCBHVUFSRCBhbmQgQUNUSVZFIGludG8gcmVnaXN0cnkgZm9yIE5BTUUuIFxcXFxcXG4gICAgXFxcXCBHdWFyZGVkIGJ5IG9wZXJhdGUga2V5c2V0LiBcXFwiXFxuXFxuICAgICh3aXRoLWNhcGFiaWxpdHkgKE9QRVJBVEUpXFxuXFxuICAgICAgKHZhbGlkYXRlLW5hbWUgbnMtbmFtZSlcXG5cXG4gICAgICAod3JpdGUgcmVnaXN0cnkgbnMtbmFtZVxcbiAgICAgICAgeyAnYWRtaW4tZ3VhcmQ6IGd1YXJkXFxuICAgICAgICAsICdhY3RpdmU6IGFjdGl2ZSB9KVxcblxcbiAgICAgIFxcXCJSZWdpc3RlciBlbnRyeSB3cml0dGVuXFxcIikpXFxuXFxuICAoZGVmdW4gcXVlcnk6b2JqZWN0e3JlZy1lbnRyeX1cXG4gICAgICAoIG5zLW5hbWU6c3RyaW5nIClcXG4gICAgKHJlYWQgcmVnaXN0cnkgbnMtbmFtZSkpXFxuXFxuKVxcblxcbihjcmVhdGUtdGFibGUgcmVnaXN0cnkpXFxuXFxuKHdyaXRlLXJlZ2lzdHJ5IFxcXCJrYWRlbmFcXFwiXFxuICAoa2V5c2V0LXJlZi1ndWFyZCAnbnMtb3BlcmF0ZS1rZXlzZXQpIHRydWUpXFxuKHdyaXRlLXJlZ2lzdHJ5IFxcXCJ1c2VyXFxcIiBHVUFSRF9GQUlMVVJFIHRydWUpXFxuKHdyaXRlLXJlZ2lzdHJ5IFxcXCJmcmVlXFxcIiBHVUFSRF9GQUlMVVJFIHRydWUpXFxuXFxuKGRlZmluZS1uYW1lc3BhY2UgXFxcImthZGVuYVxcXCJcXG4gIChrZXlzZXQtcmVmLWd1YXJkICducy1vcGVyYXRlLWtleXNldClcXG4gIChrZXlzZXQtcmVmLWd1YXJkICducy1vcGVyYXRlLWtleXNldCkpXFxuXFxuKGRlZmluZS1uYW1lc3BhY2UgXFxcInVzZXJcXFwiIEdVQVJEX1NVQ0NFU1MgR1VBUkRfRkFJTFVSRSlcXG4oZGVmaW5lLW5hbWVzcGFjZSBcXFwiZnJlZVxcXCIgR1VBUkRfU1VDQ0VTUyBHVUFSRF9GQUlMVVJFKVxcbjs7cm90YXRlIHRvIHJlYWwgb3BlcmF0ZSBrZXlzZXRcXG4oZGVmaW5lLWtleXNldCAnbnMtb3BlcmF0ZS1rZXlzZXQgKHJlYWQta2V5c2V0ICducy1vcGVyYXRlLWtleXNldCkpXFxuXCJ9fSxcInNpZ25lcnNcIjpbXSxcIm1ldGFcIjp7XCJjcmVhdGlvblRpbWVcIjowLFwidHRsXCI6MTcyODAwLFwiZ2FzTGltaXRcIjowLFwiY2hhaW5JZFwiOlwiXCIsXCJnYXNQcmljZVwiOjAsXCJzZW5kZXJcIjpcIlwifSxcIm5vbmNlXCI6XCJsb2FkLW5zLWRldm5ldC1zZW5kZXIwMFwifSJ9", unsafeFromText "eyJnYXMiOjEsInJlc3VsdCI6eyJzdGF0dXMiOiJzdWNjZXNzIiwiZGF0YSI6IktleXNldCB3cml0ZSBzdWNjZXNzIn0sInJlcUtleSI6IkNabXlsV2ZpZVJNQk11NXcyRU9tcEZ3Sy10N2JjT1RzNG1LMmFUMzN1UjQiLCJsb2dzIjoidDdzQzg1Y1hlWFdSdG90M1lEb2pSejZibWtncEN6enJQQ0Z6QThzTkg3OCIsIm1ldGFEYXRhIjpudWxsLCJjb250aW51YXRpb24iOm51bGwsInR4SWQiOjV9") - , (unsafeFromText "eyJoYXNoIjoiWE5BNmxPSjFXLTdYWXY1WWI0QXFsNzRveFlJN09KcWpPUVQ1b1k0OHEtZyIsInNpZ3MiOltdLCJjbWQiOiJ7XCJuZXR3b3JrSWRcIjpudWxsLFwicGF5bG9hZFwiOntcImV4ZWNcIjp7XCJkYXRhXCI6e1wiYWxsb2NhdGlvbi10ZXN0MDFcIjpbXCI3MDExYzM3OTE0MGZmODk5ZjdlNjEzYWMwYTk3ODRhN2MwYTUxNWQzMGZlMGFiMmIwYzA3ZTVhYTE3NjM1ZTNlXCJdLFwiYWxsb2NhdGlvbjAyXCI6W1wiZTllNGU3MWJkMDYzZGNmN2UwNmJkNWIxYTE2Njg4ODk3ZDE1Y2E4YmQyZTUwOWM0NTNjNjE2MjE5YzE4NmNjNVwiXSxcImFsbG9jYXRpb24wMFwiOltcImQ4MmQwZGNkZTk4MjU1MDVkODZhZmI2ZGNjMTA0MTFkNmI2N2E0MjlhNzllMjFiZGE0YmIxMTliZjI4YWI4NzFcIl0sXCJhbGxvY2F0aW9uLXRlc3QwMlwiOltcIjA2NTQ0ZTIyYmZlZjIzMGQ2ZDIyZjk0ODZhYzZjYjc2YmYyNThlYmZiZjAxMzdlZTU4ZjY1NzQzZTFhNWI4YzRcIl0sXCJhbGxvY2F0aW9uMDFcIjpbXCJiNGM4YTNlYTkxZDMxNDZiMDU2MDk5NDc0MGYwZTNlZWQ5MWM1OWQyZWVjYTFkYzk5ZjBjMjg3Mjg0NWMyOTRkXCJdfSxcImNvZGVcIjpcIihkZWZpbmUta2V5c2V0IFxcXCJhbGxvY2F0aW9uMDBcXFwiIChyZWFkLWtleXNldCBcXFwiYWxsb2NhdGlvbjAwXFxcIikpXFxuKGRlZmluZS1rZXlzZXQgXFxcImFsbG9jYXRpb24wMVxcXCIgKHJlYWQta2V5c2V0IFxcXCJhbGxvY2F0aW9uMDFcXFwiKSlcXG4oZGVmaW5lLWtleXNldCBcXFwiYWxsb2NhdGlvbjAyXFxcIiAocmVhZC1rZXlzZXQgXFxcImFsbG9jYXRpb24wMlxcXCIpKVxcbihkZWZpbmUta2V5c2V0IFxcXCJhbGxvY2F0aW9uLXRlc3QwMVxcXCIgKHJlYWQta2V5c2V0IFxcXCJhbGxvY2F0aW9uLXRlc3QwMVxcXCIpKVxcbihkZWZpbmUta2V5c2V0IFxcXCJhbGxvY2F0aW9uLXRlc3QwMlxcXCIgKHJlYWQta2V5c2V0IFxcXCJhbGxvY2F0aW9uLXRlc3QwMlxcXCIpKVwifX0sXCJzaWduZXJzXCI6W10sXCJtZXRhXCI6e1wiY3JlYXRpb25UaW1lXCI6MCxcInR0bFwiOjE3MjgwMCxcImdhc0xpbWl0XCI6MCxcImNoYWluSWRcIjpcIlwiLFwiZ2FzUHJpY2VcIjowLFwic2VuZGVyXCI6XCJcIn0sXCJub25jZVwiOlwiZGV2bmV0LWtleXNldHNcIn0ifQ", unsafeFromText "eyJnYXMiOjEsInJlc3VsdCI6eyJzdGF0dXMiOiJzdWNjZXNzIiwiZGF0YSI6IktleXNldCB3cml0ZSBzdWNjZXNzIn0sInJlcUtleSI6IlhOQTZsT0oxVy03WFl2NVliNEFxbDc0b3hZSTdPSnFqT1FUNW9ZNDhxLWciLCJsb2dzIjoiYXJRSWpQVGRrcXhoQTNjWl9WaVE3OXM3Uk5XRTlGV2Rha0xWdXl4Nlc0YyIsIm1ldGFEYXRhIjpudWxsLCJjb250aW51YXRpb24iOm51bGwsInR4SWQiOjZ9") - , (unsafeFromText "eyJoYXNoIjoiNWtxZ0tzWWtwbjZCcS1KUnhNYnA1VG9jUWhRWGRJVVNiM1NGQm1Ba3VWcyIsInNpZ3MiOltdLCJjbWQiOiJ7XCJuZXR3b3JrSWRcIjpudWxsLFwicGF5bG9hZFwiOntcImV4ZWNcIjp7XCJkYXRhXCI6bnVsbCxcImNvZGVcIjpcIihjb2luLmNyZWF0ZS1hbGxvY2F0aW9uLWFjY291bnQgXFxcImFsbG9jYXRpb24wMFxcXCIgKHRpbWUgXFxcIjE5MDAtMTAtMTVUMTg6MDA6MDBaXFxcIikgXFxcImFsbG9jYXRpb24wMFxcXCIgMTAwMDAwMC4wKVxcbihjb2luLmNyZWF0ZS1hbGxvY2F0aW9uLWFjY291bnQgXFxcImFsbG9jYXRpb24wMVxcXCIgKHRpbWUgXFxcIjIxMDAtMTAtMzFUMTg6MDA6MDBaXFxcIikgXFxcImFsbG9jYXRpb24wMVxcXCIgMTAwMDAwMC4wKVxcbihjb2luLmNyZWF0ZS1hbGxvY2F0aW9uLWFjY291bnQgXFxcImFsbG9jYXRpb24wMlxcXCIgKHRpbWUgXFxcIjE5MDAtMTAtMzFUMTg6MDA6MDBaXFxcIikgXFxcImFsbG9jYXRpb24wMlxcXCIgMTAwMDAwMC4wKVxcbihjb2luLmNyZWF0ZS1hbGxvY2F0aW9uLWFjY291bnQgXFxcImFsbG9jYXRpb24tdGVzdDAxXFxcIiAodGltZSBcXFwiMTkwMC0xMC0zMVQxODowMDowMFpcXFwiKSBcXFwiYWxsb2NhdGlvbi10ZXN0MDFcXFwiIDEwMDAwMDAuMClcXG4oY29pbi5jcmVhdGUtYWxsb2NhdGlvbi1hY2NvdW50IFxcXCJhbGxvY2F0aW9uLXRlc3QwMlxcXCIgKHRpbWUgXFxcIjE5MDAtMTAtMzFUMTg6MDA6MDBaXFxcIikgXFxcImFsbG9jYXRpb24tdGVzdDAyXFxcIiAyMDAwMDAwLjApXCJ9fSxcInNpZ25lcnNcIjpbXSxcIm1ldGFcIjp7XCJjcmVhdGlvblRpbWVcIjowLFwidHRsXCI6MTcyODAwLFwiZ2FzTGltaXRcIjowLFwiY2hhaW5JZFwiOlwiXCIsXCJnYXNQcmljZVwiOjAsXCJzZW5kZXJcIjpcIlwifSxcIm5vbmNlXCI6XCJkZXZuZXQtYWxsb2NhdGlvbnNcIn0ifQ", unsafeFromText "eyJnYXMiOjEsInJlc3VsdCI6eyJzdGF0dXMiOiJzdWNjZXNzIiwiZGF0YSI6IldyaXRlIHN1Y2NlZWRlZCJ9LCJyZXFLZXkiOiI1a3FnS3NZa3BuNkJxLUpSeE1icDVUb2NRaFFYZElVU2IzU0ZCbUFrdVZzIiwibG9ncyI6IkhpX3ZfVEhFT2s2aEJFRU0yWmV2Vzh3eVJsQWpUZzNjVUQydXBlVkx0b1UiLCJtZXRhRGF0YSI6bnVsbCwiY29udGludWF0aW9uIjpudWxsLCJ0eElkIjo3fQ") - , (unsafeFromText "eyJoYXNoIjoiY2tiMmZnNWVJeXRoS3U5YVN3TkhIWllsWVY2V1R1NGlYaUZDamc5WFFLWSIsInNpZ3MiOltdLCJjbWQiOiJ7XCJuZXR3b3JrSWRcIjpudWxsLFwicGF5bG9hZFwiOntcImV4ZWNcIjp7XCJkYXRhXCI6e1wic2VuZGVyMDdcIjpbXCI0YzMxZGM5ZWU3ZjI0MTc3Zjc4YjZmNTE4MDEyYTIwODMyNmUyYWYxZjM3YmIwYTI0MDViNTA1NmQwY2FkNjI4XCJdLFwic2VuZGVyMDFcIjpbXCI2YmUyZjQ4NWE3YWY3NWZlZGI0YjdmMTUzYTkwM2Y3ZTYwMDBjYTRhYTUwMTE3OWM5MWEyNDUwYjc3N2JkMmE3XCJdLFwic2VuZGVyMDZcIjpbXCI1ZmZjMWY3ZmVmN2E0NDczODYyNTc2MmY3NWE0MjI5NDU0OTUxZTAzZjJhZmM2ZjgxMzA5YzBjMWJkZjllZTZmXCJdLFwic2VuZGVyMDBcIjpbXCIzNjg4MjBmODBjMzI0YmJjN2MyYjA2MTA2ODhhN2RhNDNlMzlmOTFkMTE4NzMyNjcxY2Q5Yzc1MDBmZjQzY2NhXCJdLFwiZTdmN1wiOltcImU3Zjc2MzRlOTI1NTQxZjM2OGI4MjdhZDVjNzI0MjE5MDUxMDBmNjIwNTI4NWE3OGMxOWQ3YjRhMzg3MTE4MDVcIl0sXCJzZW5kZXIwNVwiOltcImYwOWQ4ZjYzOTRhZWE0MjVmZTY3ODNkODhjZDgxMzYzZDgwMTdmMTZhZmQzNzExYzU3NWJlMGY1Y2Q1YzliYjlcIl0sXCJzZW5kZXIwNFwiOltcIjJkNzBhYTRmNjk3YzNhM2I4ZGQ2ZDk3NzQ1YWMwNzRlZGNmZDBlYjY1YzM3Nzc0Y2RlMjUxMzU0ODNiZWE3MWVcIl0sXCJtdWx0aS0wMi0wMy0wNC1hbnlcIjp7XCJwcmVkXCI6XCJrZXlzLWFueVwiLFwia2V5c1wiOltcIjNhOWRkNTMyZDczZGFjZTE5NWRiYjY0ZDFkYmE2NTcyZmI3ODNkMGZkZDMyNDY4NWUzMmZiZGEyZjg5Zjk5YTZcIixcIjQzZjJhZGIxZGUxOTIwMDBjYjM3NzdiYWNjN2Y5ODNiNjYxNGZkOWMxNzE1Y2Q0NGNkNDg0YjZkM2EwZDM0YzhcIixcIjJkNzBhYTRmNjk3YzNhM2I4ZGQ2ZDk3NzQ1YWMwNzRlZGNmZDBlYjY1YzM3Nzc0Y2RlMjUxMzU0ODNiZWE3MWVcIl19LFwic2VuZGVyMDlcIjpbXCJjNTlkOTg0MGIwYjY2MDkwODM2NTQ2YjdlYjRhNzM2MDYyNTc1MjdlYzhjMmI0ODIzMDBmZDIyOTI2NGIwN2U2XCJdLFwic2VuZGVyMDNcIjpbXCI0M2YyYWRiMWRlMTkyMDAwY2IzNzc3YmFjYzdmOTgzYjY2MTRmZDljMTcxNWNkNDRjZDQ4NGI2ZDNhMGQzNGM4XCJdLFwibXVsdGktMDAtMDFcIjpbXCIzNjg4MjBmODBjMzI0YmJjN2MyYjA2MTA2ODhhN2RhNDNlMzlmOTFkMTE4NzMyNjcxY2Q5Yzc1MDBmZjQzY2NhXCIsXCI2YmUyZjQ4NWE3YWY3NWZlZGI0YjdmMTUzYTkwM2Y3ZTYwMDBjYTRhYTUwMTE3OWM5MWEyNDUwYjc3N2JkMmE3XCJdLFwic2VuZGVyMDhcIjpbXCI2M2IyZWJhNGVkNzBkNDYxMmQzZTdiYzkwZGIyZmJmNGM3NmY3YjA3NDM2M2U4NmQ3M2YwYmM2MTdmOGU4YjgxXCJdLFwic2VuZGVyMDJcIjpbXCIzYTlkZDUzMmQ3M2RhY2UxOTVkYmI2NGQxZGJhNjU3MmZiNzgzZDBmZGQzMjQ2ODVlMzJmYmRhMmY4OWY5OWE2XCJdfSxcImNvZGVcIjpcIihjb2luLmNvaW5iYXNlIFxcXCJzZW5kZXIwMFxcXCIgKHJlYWQta2V5c2V0IFxcXCJzZW5kZXIwMFxcXCIpIDEwMDAwMDAwMC4wKVxcbihjb2luLmNvaW5iYXNlIFxcXCJzZW5kZXIwMVxcXCIgKHJlYWQta2V5c2V0IFxcXCJzZW5kZXIwMVxcXCIpIDExMDAwMDAwMC4wKVxcbihjb2luLmNvaW5iYXNlIFxcXCJzZW5kZXIwMlxcXCIgKHJlYWQta2V5c2V0IFxcXCJzZW5kZXIwMlxcXCIpIDEyMDAwMDAwMC4wKVxcbihjb2luLmNvaW5iYXNlIFxcXCJzZW5kZXIwM1xcXCIgKHJlYWQta2V5c2V0IFxcXCJzZW5kZXIwM1xcXCIpIDEzMDAwMDAwMC4wKVxcbihjb2luLmNvaW5iYXNlIFxcXCJzZW5kZXIwNFxcXCIgKHJlYWQta2V5c2V0IFxcXCJzZW5kZXIwNFxcXCIpIDE0MDAwMDAwMC4wKVxcbihjb2luLmNvaW5iYXNlIFxcXCJzZW5kZXIwNVxcXCIgKHJlYWQta2V5c2V0IFxcXCJzZW5kZXIwNVxcXCIpIDE1MDAwMDAwMC4wKVxcbihjb2luLmNvaW5iYXNlIFxcXCJzZW5kZXIwNlxcXCIgKHJlYWQta2V5c2V0IFxcXCJzZW5kZXIwNlxcXCIpIDE2MDAwMDAwMC4wKVxcbihjb2luLmNvaW5iYXNlIFxcXCJzZW5kZXIwN1xcXCIgKHJlYWQta2V5c2V0IFxcXCJzZW5kZXIwN1xcXCIpIDE3MDAwMDAwMC4wKVxcbihjb2luLmNvaW5iYXNlIFxcXCJzZW5kZXIwOFxcXCIgKHJlYWQta2V5c2V0IFxcXCJzZW5kZXIwOFxcXCIpIDE4MDAwMDAwMC4wKVxcbihjb2luLmNvaW5iYXNlIFxcXCJzZW5kZXIwOVxcXCIgKHJlYWQta2V5c2V0IFxcXCJzZW5kZXIwOVxcXCIpIDE5MDAwMDAwMC4wKVxcbihjb2luLmNvaW5iYXNlIFxcXCJtdWx0aS0wMC0wMVxcXCIgKHJlYWQta2V5c2V0IFxcXCJtdWx0aS0wMC0wMVxcXCIpIDEwMTAwMDAwMC4wKVxcbihjb2luLmNvaW5iYXNlIFxcXCJtdWx0aS0wMi0wMy0wNC1hbnlcXFwiIChyZWFkLWtleXNldCBcXFwibXVsdGktMDItMDMtMDQtYW55XFxcIikgMTIzNDAwMDAwLjApXFxuXFxuKGNvaW4uY29pbmJhc2UgXFxcImU3Zjc2MzRlOTI1NTQxZjM2OGI4MjdhZDVjNzI0MjE5MDUxMDBmNjIwNTI4NWE3OGMxOWQ3YjRhMzg3MTE4MDVcXFwiIChyZWFkLWtleXNldCBcXFwiZTdmN1xcXCIpIDE1MC4wKVxcblxcbjsgZW5vdWdoIHRvIGNvdmVyIHRoZSBnYXMgY29zdHMgZm9yIGFsbG9jYXRpb24gcmVsZWFzZVxcbihjb2luLmNvaW5iYXNlIFxcXCJhbGxvY2F0aW9uMDBcXFwiIChrZXlzZXQtcmVmLWd1YXJkIFxcXCJhbGxvY2F0aW9uMDBcXFwiKSAxMDAwMDAuMClcXG4oY29pbi5jb2luYmFzZSBcXFwiYWxsb2NhdGlvbjAxXFxcIiAoa2V5c2V0LXJlZi1ndWFyZCBcXFwiYWxsb2NhdGlvbjAxXFxcIikgMTAwMDAwLjApXFxuKGNvaW4uY29pbmJhc2UgXFxcImFsbG9jYXRpb24wMlxcXCIgKGtleXNldC1yZWYtZ3VhcmQgXFxcImFsbG9jYXRpb24wMlxcXCIpIDEwMDAwMC4wKVwifX0sXCJzaWduZXJzXCI6W10sXCJtZXRhXCI6e1wiY3JlYXRpb25UaW1lXCI6MCxcInR0bFwiOjE3MjgwMCxcImdhc0xpbWl0XCI6MCxcImNoYWluSWRcIjpcIlwiLFwiZ2FzUHJpY2VcIjowLFwic2VuZGVyXCI6XCJcIn0sXCJub25jZVwiOlwiZGV2bmV0LWdyYW50czBcIn0ifQ", unsafeFromText "eyJnYXMiOjEsInJlc3VsdCI6eyJzdGF0dXMiOiJzdWNjZXNzIiwiZGF0YSI6IldyaXRlIHN1Y2NlZWRlZCJ9LCJyZXFLZXkiOiJja2IyZmc1ZUl5dGhLdTlhU3dOSEhaWWxZVjZXVHU0aVhpRkNqZzlYUUtZIiwibG9ncyI6ImFCUXM2aDJGVUN1a00tM0pjQmdLZGFvRU1Ta3p2OTJkM0VmT2t5MXNrMmciLCJldmVudHMiOlt7InBhcmFtcyI6WyIiLCJzZW5kZXIwMCIsMTAwMDAwMDAwXSwibmFtZSI6IlRSQU5TRkVSIiwibW9kdWxlIjp7Im5hbWVzcGFjZSI6bnVsbCwibmFtZSI6ImNvaW4ifSwibW9kdWxlSGFzaCI6IjNpSUJRZEpuc3Q0NFoyWmdYb0hQa0FhdXliSjBoODVsX2VuX1NHSE5pYkUifSx7InBhcmFtcyI6WyIiLCJzZW5kZXIwMSIsMTEwMDAwMDAwXSwibmFtZSI6IlRSQU5TRkVSIiwibW9kdWxlIjp7Im5hbWVzcGFjZSI6bnVsbCwibmFtZSI6ImNvaW4ifSwibW9kdWxlSGFzaCI6IjNpSUJRZEpuc3Q0NFoyWmdYb0hQa0FhdXliSjBoODVsX2VuX1NHSE5pYkUifSx7InBhcmFtcyI6WyIiLCJzZW5kZXIwMiIsMTIwMDAwMDAwXSwibmFtZSI6IlRSQU5TRkVSIiwibW9kdWxlIjp7Im5hbWVzcGFjZSI6bnVsbCwibmFtZSI6ImNvaW4ifSwibW9kdWxlSGFzaCI6IjNpSUJRZEpuc3Q0NFoyWmdYb0hQa0FhdXliSjBoODVsX2VuX1NHSE5pYkUifSx7InBhcmFtcyI6WyIiLCJzZW5kZXIwMyIsMTMwMDAwMDAwXSwibmFtZSI6IlRSQU5TRkVSIiwibW9kdWxlIjp7Im5hbWVzcGFjZSI6bnVsbCwibmFtZSI6ImNvaW4ifSwibW9kdWxlSGFzaCI6IjNpSUJRZEpuc3Q0NFoyWmdYb0hQa0FhdXliSjBoODVsX2VuX1NHSE5pYkUifSx7InBhcmFtcyI6WyIiLCJzZW5kZXIwNCIsMTQwMDAwMDAwXSwibmFtZSI6IlRSQU5TRkVSIiwibW9kdWxlIjp7Im5hbWVzcGFjZSI6bnVsbCwibmFtZSI6ImNvaW4ifSwibW9kdWxlSGFzaCI6IjNpSUJRZEpuc3Q0NFoyWmdYb0hQa0FhdXliSjBoODVsX2VuX1NHSE5pYkUifSx7InBhcmFtcyI6WyIiLCJzZW5kZXIwNSIsMTUwMDAwMDAwXSwibmFtZSI6IlRSQU5TRkVSIiwibW9kdWxlIjp7Im5hbWVzcGFjZSI6bnVsbCwibmFtZSI6ImNvaW4ifSwibW9kdWxlSGFzaCI6IjNpSUJRZEpuc3Q0NFoyWmdYb0hQa0FhdXliSjBoODVsX2VuX1NHSE5pYkUifSx7InBhcmFtcyI6WyIiLCJzZW5kZXIwNiIsMTYwMDAwMDAwXSwibmFtZSI6IlRSQU5TRkVSIiwibW9kdWxlIjp7Im5hbWVzcGFjZSI6bnVsbCwibmFtZSI6ImNvaW4ifSwibW9kdWxlSGFzaCI6IjNpSUJRZEpuc3Q0NFoyWmdYb0hQa0FhdXliSjBoODVsX2VuX1NHSE5pYkUifSx7InBhcmFtcyI6WyIiLCJzZW5kZXIwNyIsMTcwMDAwMDAwXSwibmFtZSI6IlRSQU5TRkVSIiwibW9kdWxlIjp7Im5hbWVzcGFjZSI6bnVsbCwibmFtZSI6ImNvaW4ifSwibW9kdWxlSGFzaCI6IjNpSUJRZEpuc3Q0NFoyWmdYb0hQa0FhdXliSjBoODVsX2VuX1NHSE5pYkUifSx7InBhcmFtcyI6WyIiLCJzZW5kZXIwOCIsMTgwMDAwMDAwXSwibmFtZSI6IlRSQU5TRkVSIiwibW9kdWxlIjp7Im5hbWVzcGFjZSI6bnVsbCwibmFtZSI6ImNvaW4ifSwibW9kdWxlSGFzaCI6IjNpSUJRZEpuc3Q0NFoyWmdYb0hQa0FhdXliSjBoODVsX2VuX1NHSE5pYkUifSx7InBhcmFtcyI6WyIiLCJzZW5kZXIwOSIsMTkwMDAwMDAwXSwibmFtZSI6IlRSQU5TRkVSIiwibW9kdWxlIjp7Im5hbWVzcGFjZSI6bnVsbCwibmFtZSI6ImNvaW4ifSwibW9kdWxlSGFzaCI6IjNpSUJRZEpuc3Q0NFoyWmdYb0hQa0FhdXliSjBoODVsX2VuX1NHSE5pYkUifSx7InBhcmFtcyI6WyIiLCJtdWx0aS0wMC0wMSIsMTAxMDAwMDAwXSwibmFtZSI6IlRSQU5TRkVSIiwibW9kdWxlIjp7Im5hbWVzcGFjZSI6bnVsbCwibmFtZSI6ImNvaW4ifSwibW9kdWxlSGFzaCI6IjNpSUJRZEpuc3Q0NFoyWmdYb0hQa0FhdXliSjBoODVsX2VuX1NHSE5pYkUifSx7InBhcmFtcyI6WyIiLCJtdWx0aS0wMi0wMy0wNC1hbnkiLDEyMzQwMDAwMF0sIm5hbWUiOiJUUkFOU0ZFUiIsIm1vZHVsZSI6eyJuYW1lc3BhY2UiOm51bGwsIm5hbWUiOiJjb2luIn0sIm1vZHVsZUhhc2giOiIzaUlCUWRKbnN0NDRaMlpnWG9IUGtBYXV5YkowaDg1bF9lbl9TR0hOaWJFIn0seyJwYXJhbXMiOlsiIiwiZTdmNzYzNGU5MjU1NDFmMzY4YjgyN2FkNWM3MjQyMTkwNTEwMGY2MjA1Mjg1YTc4YzE5ZDdiNGEzODcxMTgwNSIsMTUwXSwibmFtZSI6IlRSQU5TRkVSIiwibW9kdWxlIjp7Im5hbWVzcGFjZSI6bnVsbCwibmFtZSI6ImNvaW4ifSwibW9kdWxlSGFzaCI6IjNpSUJRZEpuc3Q0NFoyWmdYb0hQa0FhdXliSjBoODVsX2VuX1NHSE5pYkUifSx7InBhcmFtcyI6WyIiLCJhbGxvY2F0aW9uMDAiLDEwMDAwMF0sIm5hbWUiOiJUUkFOU0ZFUiIsIm1vZHVsZSI6eyJuYW1lc3BhY2UiOm51bGwsIm5hbWUiOiJjb2luIn0sIm1vZHVsZUhhc2giOiIzaUlCUWRKbnN0NDRaMlpnWG9IUGtBYXV5YkowaDg1bF9lbl9TR0hOaWJFIn0seyJwYXJhbXMiOlsiIiwiYWxsb2NhdGlvbjAxIiwxMDAwMDBdLCJuYW1lIjoiVFJBTlNGRVIiLCJtb2R1bGUiOnsibmFtZXNwYWNlIjpudWxsLCJuYW1lIjoiY29pbiJ9LCJtb2R1bGVIYXNoIjoiM2lJQlFkSm5zdDQ0WjJaZ1hvSFBrQWF1eWJKMGg4NWxfZW5fU0dITmliRSJ9LHsicGFyYW1zIjpbIiIsImFsbG9jYXRpb24wMiIsMTAwMDAwXSwibmFtZSI6IlRSQU5TRkVSIiwibW9kdWxlIjp7Im5hbWVzcGFjZSI6bnVsbCwibmFtZSI6ImNvaW4ifSwibW9kdWxlSGFzaCI6IjNpSUJRZEpuc3Q0NFoyWmdYb0hQa0FhdXliSjBoODVsX2VuX1NHSE5pYkUifV0sIm1ldGFEYXRhIjpudWxsLCJjb250aW51YXRpb24iOm51bGwsInR4SWQiOjh9") + [ (unsafeFromText "eyJoYXNoIjoiNDhUMExqQW5TRnBGV3h2dmFQVi1fNkUtQ2pEQVBoV1lVRldidnlmMmxGcyIsInNpZ3MiOltdLCJjbWQiOiJ7XCJuZXR3b3JrSWRcIjpudWxsLFwicGF5bG9hZFwiOntcImV4ZWNcIjp7XCJkYXRhXCI6bnVsbCxcImNvZGVcIjpcIihpbnRlcmZhY2UgZnVuZ2libGUtdjFcXG5cXG4gIFxcXCIgU3RhbmRhcmQgZm9yIGZ1bmdpYmxlIGNvaW5zIGFuZCB0b2tlbnMgYXMgc3BlY2lmaWVkIGluIEtJUC0wMDAyLiBcXFwiXFxuXFxuICAgOyAtLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tXFxuICAgOyBTY2hlbWFcXG5cXG4gICAoZGVmc2NoZW1hIGFjY291bnQtZGV0YWlsc1xcbiAgICBAZG9jIFxcXCJTY2hlbWEgZm9yIHJlc3VsdHMgb2YgJ2FjY291bnQnIG9wZXJhdGlvbi5cXFwiXFxuICAgIEBtb2RlbCBbIChpbnZhcmlhbnQgKCE9IFxcXCJcXFwiIHNlbmRlcikpIF1cXG5cXG4gICAgYWNjb3VudDpzdHJpbmdcXG4gICAgYmFsYW5jZTpkZWNpbWFsXFxuICAgIGd1YXJkOmd1YXJkKVxcblxcblxcbiAgIDsgLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLVxcbiAgIDsgQ2Fwc1xcblxcbiAgIChkZWZjYXAgVFJBTlNGRVI6Ym9vbFxcbiAgICAgKCBzZW5kZXI6c3RyaW5nXFxuICAgICAgIHJlY2VpdmVyOnN0cmluZ1xcbiAgICAgICBhbW91bnQ6ZGVjaW1hbFxcbiAgICAgKVxcbiAgICAgQGRvYyBcXFwiIE1hbmFnZWQgY2FwYWJpbGl0eSBzZWFsaW5nIEFNT1VOVCBmb3IgdHJhbnNmZXIgZnJvbSBTRU5ERVIgdG8gXFxcXFxcbiAgICAgICAgICBcXFxcIFJFQ0VJVkVSLiBQZXJtaXRzIGFueSBudW1iZXIgb2YgdHJhbnNmZXJzIHVwIHRvIEFNT1VOVC5cXFwiXFxuICAgICBAbWFuYWdlZCBhbW91bnQgVFJBTlNGRVItbWdyXFxuICAgICApXFxuXFxuICAgKGRlZnVuIFRSQU5TRkVSLW1ncjpkZWNpbWFsXFxuICAgICAoIG1hbmFnZWQ6ZGVjaW1hbFxcbiAgICAgICByZXF1ZXN0ZWQ6ZGVjaW1hbFxcbiAgICAgKVxcbiAgICAgQGRvYyBcXFwiIE1hbmFnZXMgVFJBTlNGRVIgQU1PVU5UIGxpbmVhcmx5LCBcXFxcXFxuICAgICAgICAgIFxcXFwgc3VjaCB0aGF0IGEgcmVxdWVzdCBmb3IgMS4wIGFtb3VudCBvbiBhIDMuMCBcXFxcXFxuICAgICAgICAgIFxcXFwgbWFuYWdlZCBxdWFudGl0eSBlbWl0cyB1cGRhdGVkIGFtb3VudCAyLjAuXFxcIlxcbiAgICAgKVxcblxcbiAgIDsgLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLVxcbiAgIDsgRnVuY3Rpb25hbGl0eVxcblxcbiAgIChkZWZ1biB0cmFuc2Zlci1jcmVhdGU6c3RyaW5nXFxuICAgICAoIHNlbmRlcjpzdHJpbmdcXG4gICAgICAgcmVjZWl2ZXI6c3RyaW5nXFxuICAgICAgIHJlY2VpdmVyLWd1YXJkOmd1YXJkXFxuICAgICAgIGFtb3VudDpkZWNpbWFsXFxuICAgICApXFxuICAgICBAZG9jIFxcXCIgVHJhbnNmZXIgQU1PVU5UIGJldHdlZW4gYWNjb3VudHMgU0VOREVSIGFuZCBSRUNFSVZFUi4gXFxcXFxcbiAgICAgICAgICBcXFxcIEZhaWxzIGlmIFNFTkRFUiBkb2VzIG5vdCBleGlzdC4gSWYgUkVDRUlWRVIgZXhpc3RzLCBndWFyZCBcXFxcXFxuICAgICAgICAgIFxcXFwgbXVzdCBtYXRjaCBleGlzdGluZyB2YWx1ZS4gSWYgUkVDRUlWRVIgZG9lcyBub3QgZXhpc3QsIFxcXFxcXG4gICAgICAgICAgXFxcXCBSRUNFSVZFUiBhY2NvdW50IGlzIGNyZWF0ZWQgdXNpbmcgUkVDRUlWRVItR1VBUkQuIFxcXFxcXG4gICAgICAgICAgXFxcXCBTdWJqZWN0IHRvIG1hbmFnZW1lbnQgYnkgVFJBTlNGRVIgY2FwYWJpbGl0eS5cXFwiXFxuICAgICBAbW9kZWwgWyAocHJvcGVydHkgKD4gYW1vdW50IDAuMCkpXFxuICAgICAgICAgICAgICAocHJvcGVydHkgKCE9IHNlbmRlciBcXFwiXFxcIikpXFxuICAgICAgICAgICAgICAocHJvcGVydHkgKCE9IHJlY2VpdmVyIFxcXCJcXFwiKSlcXG4gICAgICAgICAgICAgIChwcm9wZXJ0eSAoIT0gc2VuZGVyIHJlY2VpdmVyKSlcXG4gICAgICAgICAgICBdXFxuICAgICApXFxuXFxuICAgKGRlZnBhY3QgdHJhbnNmZXItY3Jvc3NjaGFpbjpzdHJpbmdcXG4gICAgICggc2VuZGVyOnN0cmluZ1xcbiAgICAgICByZWNlaXZlcjpzdHJpbmdcXG4gICAgICAgcmVjZWl2ZXItZ3VhcmQ6Z3VhcmRcXG4gICAgICAgdGFyZ2V0LWNoYWluOnN0cmluZ1xcbiAgICAgICBhbW91bnQ6ZGVjaW1hbFxcbiAgICAgKVxcbiAgICAgQGRvYyBcXFwiIDItc3RlcCBwYWN0IHRvIHRyYW5zZmVyIEFNT1VOVCBmcm9tIFNFTkRFUiBvbiBjdXJyZW50IGNoYWluIFxcXFxcXG4gICAgICAgICAgXFxcXCB0byBSRUNFSVZFUiBvbiBUQVJHRVQtQ0hBSU4gdmlhIFNQViBwcm9vZi4gXFxcXFxcbiAgICAgICAgICBcXFxcIFRBUkdFVC1DSEFJTiBtdXN0IGJlIGRpZmZlcmVudCB0aGFuIGN1cnJlbnQgY2hhaW4gaWQuIFxcXFxcXG4gICAgICAgICAgXFxcXCBGaXJzdCBzdGVwIGRlYml0cyBBTU9VTlQgY29pbnMgaW4gU0VOREVSIGFjY291bnQgYW5kIHlpZWxkcyBcXFxcXFxuICAgICAgICAgIFxcXFwgUkVDRUlWRVIsIFJFQ0VJVkVSX0dVQVJEIGFuZCBBTU9VTlQgdG8gVEFSR0VULUNIQUlOLiBcXFxcXFxuICAgICAgICAgIFxcXFwgU2Vjb25kIHN0ZXAgY29udGludWF0aW9uIGlzIHNlbnQgaW50byBUQVJHRVQtQ0hBSU4gd2l0aCBwcm9vZiBcXFxcXFxuICAgICAgICAgIFxcXFwgb2J0YWluZWQgZnJvbSB0aGUgc3B2ICdvdXRwdXQnIGVuZHBvaW50IG9mIENoYWlud2ViLiBcXFxcXFxuICAgICAgICAgIFxcXFwgUHJvb2YgaXMgdmFsaWRhdGVkIGFuZCBSRUNFSVZFUiBpcyBjcmVkaXRlZCB3aXRoIEFNT1VOVCBcXFxcXFxuICAgICAgICAgIFxcXFwgY3JlYXRpbmcgYWNjb3VudCB3aXRoIFJFQ0VJVkVSX0dVQVJEIGFzIG5lY2Vzc2FyeS5cXFwiXFxuICAgICBAbW9kZWwgWyAocHJvcGVydHkgKD4gYW1vdW50IDAuMCkpXFxuICAgICAgICAgICAgICAocHJvcGVydHkgKCE9IHNlbmRlciBcXFwiXFxcIikpXFxuICAgICAgICAgICAgICAocHJvcGVydHkgKCE9IHJlY2VpdmVyIFxcXCJcXFwiKSlcXG4gICAgICAgICAgICAgIChwcm9wZXJ0eSAoIT0gc2VuZGVyIHJlY2VpdmVyKSlcXG4gICAgICAgICAgICAgIChwcm9wZXJ0eSAoIT0gdGFyZ2V0LWNoYWluIFxcXCJcXFwiKSlcXG4gICAgICAgICAgICBdXFxuICAgICApXFxuXFxuICAgKGRlZnVuIGdldC1iYWxhbmNlOmRlY2ltYWxcXG4gICAgICggYWNjb3VudDpzdHJpbmcgKVxcbiAgICAgXFxcIiBHZXQgYmFsYW5jZSBmb3IgQUNDT1VOVC4gRmFpbHMgaWYgYWNjb3VudCBkb2VzIG5vdCBleGlzdC5cXFwiXFxuICAgICApXFxuXFxuICAgKGRlZnVuIGRldGFpbHM6b2JqZWN0e2FjY291bnQtZGV0YWlsc31cXG4gICAgICggYWNjb3VudDogc3RyaW5nIClcXG4gICAgIFxcXCIgR2V0IGFuIG9iamVjdCB3aXRoIGRldGFpbHMgb2YgQUNDT1VOVC4gXFxcXFxcbiAgICAgXFxcXCBGYWlscyBpZiBhY2NvdW50IGRvZXMgbm90IGV4aXN0LlxcXCJcXG4gICAgIClcXG5cXG4gICAoZGVmdW4gcHJlY2lzaW9uOmludGVnZXJcXG4gICAgICgpXFxuICAgICBcXFwiUmV0dXJuIHRoZSBtYXhpbXVtIGFsbG93ZWQgZGVjaW1hbCBwcmVjaXNpb24uXFxcIlxcbiAgICAgKVxcblxcbiAgIChkZWZ1biBlbmZvcmNlLXVuaXQ6Ym9vbFxcbiAgICAgKCBhbW91bnQ6ZGVjaW1hbCApXFxuICAgICBcXFwiIEVuZm9yY2UgbWluaW11bSBwcmVjaXNpb24gYWxsb3dlZCBmb3IgdHJhbnNhY3Rpb25zLlxcXCJcXG4gICAgIClcXG5cXG4gICAoZGVmdW4gY3JlYXRlLWFjY291bnQ6c3RyaW5nXFxuICAgICAoIGFjY291bnQ6c3RyaW5nXFxuICAgICAgIGd1YXJkOmd1YXJkXFxuICAgICApXFxuICAgICBcXFwiIENyZWF0ZSBBQ0NPVU5UIHdpdGggMC4wIGJhbGFuY2UsIHdpdGggR1VBUkQgY29udHJvbGxpbmcgYWNjZXNzLlxcXCJcXG4gICAgIClcXG5cXG4gICAoZGVmdW4gcm90YXRlOnN0cmluZ1xcbiAgICAgKCBhY2NvdW50OnN0cmluZ1xcbiAgICAgICBuZXctZ3VhcmQ6Z3VhcmRcXG4gICAgIClcXG4gICAgIFxcXCIgUm90YXRlIGd1YXJkIGZvciBBQ0NPVU5ULiBUcmFuc2FjdGlvbiBpcyB2YWxpZGF0ZWQgYWdhaW5zdCBcXFxcXFxuICAgICBcXFxcIGV4aXN0aW5nIGd1YXJkIGJlZm9yZSBpbnN0YWxsaW5nIG5ldyBndWFyZC4gXFxcIlxcbiAgICAgKVxcblxcbilcXG5cIn19LFwic2lnbmVyc1wiOltdLFwibWV0YVwiOntcImNyZWF0aW9uVGltZVwiOjAsXCJ0dGxcIjoxNzI4MDAsXCJnYXNMaW1pdFwiOjAsXCJjaGFpbklkXCI6XCJcIixcImdhc1ByaWNlXCI6MCxcInNlbmRlclwiOlwiXCJ9LFwibm9uY2VcIjpcImdlbmVzaXMtMDFcIn0ifQ", unsafeFromText "eyJnYXMiOjAsInJlc3VsdCI6eyJzdGF0dXMiOiJzdWNjZXNzIiwiZGF0YSI6IkxvYWRlZCBpbnRlcmZhY2UgZnVuZ2libGUtdjEsIGhhc2ggTm1kUnRzekN3YWNqSEd5eUU5Tl9mbFFNUlJCaGNIVkZQNE9qaGlQZWoxRSJ9LCJyZXFLZXkiOiI0OFQwTGpBblNGcEZXeHZ2YVBWLV82RS1DakRBUGhXWVVGV2J2eWYybEZzIiwibG9ncyI6IlB3eDlycG9kS2prSGNPUlh2WFVRSUpjRVZRZDhPSXRNM0FlakNFRExMVXMiLCJtZXRhRGF0YSI6bnVsbCwiY29udGludWF0aW9uIjpudWxsLCJ0eElkIjowfQ") + , (unsafeFromText "eyJoYXNoIjoieW5ucDFYVVNSTjJrMUYwYTZ2dXM3RFp0SDZjcHN6MVhmX0d3V0xnTFhTTSIsInNpZ3MiOltdLCJjbWQiOiJ7XCJuZXR3b3JrSWRcIjpudWxsLFwicGF5bG9hZFwiOntcImV4ZWNcIjp7XCJkYXRhXCI6bnVsbCxcImNvZGVcIjpcIihpbnRlcmZhY2UgZnVuZ2libGUteGNoYWluLXYxXFxuXFxuICBcXFwiIFRoaXMgaW50ZXJmYWNlIG9mZmVycyBhIHN0YW5kYXJkIGNhcGFiaWxpdHkgZm9yIGNyb3NzLWNoYWluIFxcXFxcXG4gIFxcXFwgdHJhbnNmZXJzIGFuZCBhc3NvY2lhdGVkIGV2ZW50cy4gXFxcIlxcblxcbiAgKGRlZmNhcCBUUkFOU0ZFUl9YQ0hBSU46Ym9vbFxcbiAgICAoIHNlbmRlcjpzdHJpbmdcXG4gICAgICByZWNlaXZlcjpzdHJpbmdcXG4gICAgICBhbW91bnQ6ZGVjaW1hbFxcbiAgICAgIHRhcmdldC1jaGFpbjpzdHJpbmdcXG4gICAgKVxcbiAgICBAZG9jIFxcXCIgTWFuYWdlZCBjYXBhYmlsaXR5IHNlYWxpbmcgQU1PVU5UIGZvciB0cmFuc2ZlciBcXFxcXFxuICAgICAgICAgXFxcXCBmcm9tIFNFTkRFUiB0byBSRUNFSVZFUiBvbiBUQVJHRVQtQ0hBSU4uIFBlcm1pdHMgXFxcXFxcbiAgICAgICAgIFxcXFwgYW55IG51bWJlciBvZiBjcm9zcy1jaGFpbiB0cmFuc2ZlcnMgdXAgdG8gQU1PVU5ULlxcXCJcXG5cXG4gICAgQG1hbmFnZWQgYW1vdW50IFRSQU5TRkVSX1hDSEFJTi1tZ3JcXG4gICAgKVxcblxcbiAgKGRlZnVuIFRSQU5TRkVSX1hDSEFJTi1tZ3I6ZGVjaW1hbFxcbiAgICAoIG1hbmFnZWQ6ZGVjaW1hbFxcbiAgICAgIHJlcXVlc3RlZDpkZWNpbWFsXFxuICAgIClcXG4gICAgQGRvYyBcXFwiIEFsbG93cyBUUkFOU0ZFUi1YQ0hBSU4gQU1PVU5UIHRvIGJlIGxlc3MgdGhhbiBvciBcXFxcXFxuICAgICAgICAgXFxcXCBlcXVhbCBtYW5hZ2VkIHF1YW50aXR5IGFzIGEgb25lLXNob3QsIHJldHVybmluZyAwLjAuXFxcIlxcbiAgKVxcblxcbiAgKGRlZmNhcCBUUkFOU0ZFUl9YQ0hBSU5fUkVDRDpib29sXFxuICAgICggc2VuZGVyOnN0cmluZ1xcbiAgICAgIHJlY2VpdmVyOnN0cmluZ1xcbiAgICAgIGFtb3VudDpkZWNpbWFsXFxuICAgICAgc291cmNlLWNoYWluOnN0cmluZ1xcbiAgICApXFxuICAgIEBkb2MgXFxcIkV2ZW50IGVtaXR0ZWQgb24gcmVjZWlwdCBvZiBjcm9zcy1jaGFpbiB0cmFuc2Zlci5cXFwiXFxuICAgIEBldmVudFxcbiAgKVxcbilcXG5cIn19LFwic2lnbmVyc1wiOltdLFwibWV0YVwiOntcImNyZWF0aW9uVGltZVwiOjAsXCJ0dGxcIjoxNzI4MDAsXCJnYXNMaW1pdFwiOjAsXCJjaGFpbklkXCI6XCJcIixcImdhc1ByaWNlXCI6MCxcInNlbmRlclwiOlwiXCJ9LFwibm9uY2VcIjpcImdlbmVzaXMteGNoYWluXCJ9In0", unsafeFromText "eyJnYXMiOjAsInJlc3VsdCI6eyJzdGF0dXMiOiJzdWNjZXNzIiwiZGF0YSI6IkxvYWRlZCBpbnRlcmZhY2UgZnVuZ2libGUteGNoYWluLXYxLCBoYXNoIGg4OWljM2doejIzUmprMHBITkt0Rk93cnZTczdtYm11cWxvVlhPaGwyR0kifSwicmVxS2V5IjoieW5ucDFYVVNSTjJrMUYwYTZ2dXM3RFp0SDZjcHN6MVhmX0d3V0xnTFhTTSIsImxvZ3MiOiJSUDhnMUJrZnkyQjN1bHE0WWU4amF1VlRZcGpqRXlaLWtydGJ5SVg2STRnIiwibWV0YURhdGEiOm51bGwsImNvbnRpbnVhdGlvbiI6bnVsbCwidHhJZCI6MX0") + , (unsafeFromText "eyJoYXNoIjoiMDVCdGo3ZUJaQlc3by1TYUxvVmhBaWNNVVBaVUJiRzZRVDhfTEFrQ3hIcyIsInNpZ3MiOltdLCJjbWQiOiJ7XCJuZXR3b3JrSWRcIjpudWxsLFwicGF5bG9hZFwiOntcImV4ZWNcIjp7XCJkYXRhXCI6bnVsbCxcImNvZGVcIjpcIihpbnRlcmZhY2UgZnVuZ2libGUtdjJcXG5cXG4gIFxcXCIgU3RhbmRhcmQgZm9yIGZ1bmdpYmxlIGNvaW5zIGFuZCB0b2tlbnMgYXMgc3BlY2lmaWVkIGluIEtJUC0wMDAyLiBcXFwiXFxuXFxuICAgOyAtLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tXFxuICAgOyBTY2hlbWFcXG5cXG4gICAoZGVmc2NoZW1hIGFjY291bnQtZGV0YWlsc1xcbiAgICBAZG9jIFxcXCJTY2hlbWEgZm9yIHJlc3VsdHMgb2YgJ2FjY291bnQnIG9wZXJhdGlvbi5cXFwiXFxuICAgIEBtb2RlbCBbIChpbnZhcmlhbnQgKCE9IFxcXCJcXFwiIHNlbmRlcikpIF1cXG5cXG4gICAgYWNjb3VudDpzdHJpbmdcXG4gICAgYmFsYW5jZTpkZWNpbWFsXFxuICAgIGd1YXJkOmd1YXJkKVxcblxcblxcbiAgIDsgLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLVxcbiAgIDsgQ2Fwc1xcblxcbiAgIChkZWZjYXAgVFJBTlNGRVI6Ym9vbFxcbiAgICAgKCBzZW5kZXI6c3RyaW5nXFxuICAgICAgIHJlY2VpdmVyOnN0cmluZ1xcbiAgICAgICBhbW91bnQ6ZGVjaW1hbFxcbiAgICAgKVxcbiAgICAgQGRvYyBcXFwiIE1hbmFnZWQgY2FwYWJpbGl0eSBzZWFsaW5nIEFNT1VOVCBmb3IgdHJhbnNmZXIgZnJvbSBTRU5ERVIgdG8gXFxcXFxcbiAgICAgICAgICBcXFxcIFJFQ0VJVkVSLiBQZXJtaXRzIGFueSBudW1iZXIgb2YgdHJhbnNmZXJzIHVwIHRvIEFNT1VOVC5cXFwiXFxuICAgICBAbWFuYWdlZCBhbW91bnQgVFJBTlNGRVItbWdyXFxuICAgICApXFxuXFxuICAgKGRlZnVuIFRSQU5TRkVSLW1ncjpkZWNpbWFsXFxuICAgICAoIG1hbmFnZWQ6ZGVjaW1hbFxcbiAgICAgICByZXF1ZXN0ZWQ6ZGVjaW1hbFxcbiAgICAgKVxcbiAgICAgQGRvYyBcXFwiIE1hbmFnZXMgVFJBTlNGRVIgQU1PVU5UIGxpbmVhcmx5LCBcXFxcXFxuICAgICAgICAgIFxcXFwgc3VjaCB0aGF0IGEgcmVxdWVzdCBmb3IgMS4wIGFtb3VudCBvbiBhIDMuMCBcXFxcXFxuICAgICAgICAgIFxcXFwgbWFuYWdlZCBxdWFudGl0eSBlbWl0cyB1cGRhdGVkIGFtb3VudCAyLjAuXFxcIlxcbiAgICAgKVxcblxcbiAgIDsgLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLVxcbiAgIDsgRnVuY3Rpb25hbGl0eVxcblxcblxcbiAgKGRlZnVuIHRyYW5zZmVyOnN0cmluZ1xcbiAgICAoIHNlbmRlcjpzdHJpbmdcXG4gICAgICByZWNlaXZlcjpzdHJpbmdcXG4gICAgICBhbW91bnQ6ZGVjaW1hbFxcbiAgICApXFxuICAgIEBkb2MgXFxcIiBUcmFuc2ZlciBBTU9VTlQgYmV0d2VlbiBhY2NvdW50cyBTRU5ERVIgYW5kIFJFQ0VJVkVSLiBcXFxcXFxuICAgICAgICAgXFxcXCBGYWlscyBpZiBlaXRoZXIgU0VOREVSIG9yIFJFQ0VJVkVSIGRvZXMgbm90IGV4aXN0LlxcXCJcXG4gICAgQG1vZGVsIFsgKHByb3BlcnR5ICg-IGFtb3VudCAwLjApKVxcbiAgICAgICAgICAgICAocHJvcGVydHkgKCE9IHNlbmRlciBcXFwiXFxcIikpXFxuICAgICAgICAgICAgIChwcm9wZXJ0eSAoIT0gcmVjZWl2ZXIgXFxcIlxcXCIpKVxcbiAgICAgICAgICAgICAocHJvcGVydHkgKCE9IHNlbmRlciByZWNlaXZlcikpXFxuICAgICAgICAgICBdXFxuICAgIClcXG5cXG4gICAoZGVmdW4gdHJhbnNmZXItY3JlYXRlOnN0cmluZ1xcbiAgICAgKCBzZW5kZXI6c3RyaW5nXFxuICAgICAgIHJlY2VpdmVyOnN0cmluZ1xcbiAgICAgICByZWNlaXZlci1ndWFyZDpndWFyZFxcbiAgICAgICBhbW91bnQ6ZGVjaW1hbFxcbiAgICAgKVxcbiAgICAgQGRvYyBcXFwiIFRyYW5zZmVyIEFNT1VOVCBiZXR3ZWVuIGFjY291bnRzIFNFTkRFUiBhbmQgUkVDRUlWRVIuIFxcXFxcXG4gICAgICAgICAgXFxcXCBGYWlscyBpZiBTRU5ERVIgZG9lcyBub3QgZXhpc3QuIElmIFJFQ0VJVkVSIGV4aXN0cywgZ3VhcmQgXFxcXFxcbiAgICAgICAgICBcXFxcIG11c3QgbWF0Y2ggZXhpc3RpbmcgdmFsdWUuIElmIFJFQ0VJVkVSIGRvZXMgbm90IGV4aXN0LCBcXFxcXFxuICAgICAgICAgIFxcXFwgUkVDRUlWRVIgYWNjb3VudCBpcyBjcmVhdGVkIHVzaW5nIFJFQ0VJVkVSLUdVQVJELiBcXFxcXFxuICAgICAgICAgIFxcXFwgU3ViamVjdCB0byBtYW5hZ2VtZW50IGJ5IFRSQU5TRkVSIGNhcGFiaWxpdHkuXFxcIlxcbiAgICAgQG1vZGVsIFsgKHByb3BlcnR5ICg-IGFtb3VudCAwLjApKVxcbiAgICAgICAgICAgICAgKHByb3BlcnR5ICghPSBzZW5kZXIgXFxcIlxcXCIpKVxcbiAgICAgICAgICAgICAgKHByb3BlcnR5ICghPSByZWNlaXZlciBcXFwiXFxcIikpXFxuICAgICAgICAgICAgICAocHJvcGVydHkgKCE9IHNlbmRlciByZWNlaXZlcikpXFxuICAgICAgICAgICAgXVxcbiAgICAgKVxcblxcbiAgIChkZWZwYWN0IHRyYW5zZmVyLWNyb3NzY2hhaW46c3RyaW5nXFxuICAgICAoIHNlbmRlcjpzdHJpbmdcXG4gICAgICAgcmVjZWl2ZXI6c3RyaW5nXFxuICAgICAgIHJlY2VpdmVyLWd1YXJkOmd1YXJkXFxuICAgICAgIHRhcmdldC1jaGFpbjpzdHJpbmdcXG4gICAgICAgYW1vdW50OmRlY2ltYWxcXG4gICAgIClcXG4gICAgIEBkb2MgXFxcIiAyLXN0ZXAgcGFjdCB0byB0cmFuc2ZlciBBTU9VTlQgZnJvbSBTRU5ERVIgb24gY3VycmVudCBjaGFpbiBcXFxcXFxuICAgICAgICAgIFxcXFwgdG8gUkVDRUlWRVIgb24gVEFSR0VULUNIQUlOIHZpYSBTUFYgcHJvb2YuIFxcXFxcXG4gICAgICAgICAgXFxcXCBUQVJHRVQtQ0hBSU4gbXVzdCBiZSBkaWZmZXJlbnQgdGhhbiBjdXJyZW50IGNoYWluIGlkLiBcXFxcXFxuICAgICAgICAgIFxcXFwgRmlyc3Qgc3RlcCBkZWJpdHMgQU1PVU5UIGNvaW5zIGluIFNFTkRFUiBhY2NvdW50IGFuZCB5aWVsZHMgXFxcXFxcbiAgICAgICAgICBcXFxcIFJFQ0VJVkVSLCBSRUNFSVZFUl9HVUFSRCBhbmQgQU1PVU5UIHRvIFRBUkdFVC1DSEFJTi4gXFxcXFxcbiAgICAgICAgICBcXFxcIFNlY29uZCBzdGVwIGNvbnRpbnVhdGlvbiBpcyBzZW50IGludG8gVEFSR0VULUNIQUlOIHdpdGggcHJvb2YgXFxcXFxcbiAgICAgICAgICBcXFxcIG9idGFpbmVkIGZyb20gdGhlIHNwdiAnb3V0cHV0JyBlbmRwb2ludCBvZiBDaGFpbndlYi4gXFxcXFxcbiAgICAgICAgICBcXFxcIFByb29mIGlzIHZhbGlkYXRlZCBhbmQgUkVDRUlWRVIgaXMgY3JlZGl0ZWQgd2l0aCBBTU9VTlQgXFxcXFxcbiAgICAgICAgICBcXFxcIGNyZWF0aW5nIGFjY291bnQgd2l0aCBSRUNFSVZFUl9HVUFSRCBhcyBuZWNlc3NhcnkuXFxcIlxcbiAgICAgQG1vZGVsIFsgKHByb3BlcnR5ICg-IGFtb3VudCAwLjApKVxcbiAgICAgICAgICAgICAgKHByb3BlcnR5ICghPSBzZW5kZXIgXFxcIlxcXCIpKVxcbiAgICAgICAgICAgICAgKHByb3BlcnR5ICghPSByZWNlaXZlciBcXFwiXFxcIikpXFxuICAgICAgICAgICAgICAocHJvcGVydHkgKCE9IHNlbmRlciByZWNlaXZlcikpXFxuICAgICAgICAgICAgICAocHJvcGVydHkgKCE9IHRhcmdldC1jaGFpbiBcXFwiXFxcIikpXFxuICAgICAgICAgICAgXVxcbiAgICAgKVxcblxcbiAgIChkZWZ1biBnZXQtYmFsYW5jZTpkZWNpbWFsXFxuICAgICAoIGFjY291bnQ6c3RyaW5nIClcXG4gICAgIFxcXCIgR2V0IGJhbGFuY2UgZm9yIEFDQ09VTlQuIEZhaWxzIGlmIGFjY291bnQgZG9lcyBub3QgZXhpc3QuXFxcIlxcbiAgICAgKVxcblxcbiAgIChkZWZ1biBkZXRhaWxzOm9iamVjdHthY2NvdW50LWRldGFpbHN9XFxuICAgICAoIGFjY291bnQ6IHN0cmluZyApXFxuICAgICBcXFwiIEdldCBhbiBvYmplY3Qgd2l0aCBkZXRhaWxzIG9mIEFDQ09VTlQuIFxcXFxcXG4gICAgIFxcXFwgRmFpbHMgaWYgYWNjb3VudCBkb2VzIG5vdCBleGlzdC5cXFwiXFxuICAgICApXFxuXFxuICAgKGRlZnVuIHByZWNpc2lvbjppbnRlZ2VyXFxuICAgICAoKVxcbiAgICAgXFxcIlJldHVybiB0aGUgbWF4aW11bSBhbGxvd2VkIGRlY2ltYWwgcHJlY2lzaW9uLlxcXCJcXG4gICAgIClcXG5cXG4gICAoZGVmdW4gZW5mb3JjZS11bml0OmJvb2xcXG4gICAgICggYW1vdW50OmRlY2ltYWwgKVxcbiAgICAgXFxcIiBFbmZvcmNlIG1pbmltdW0gcHJlY2lzaW9uIGFsbG93ZWQgZm9yIHRyYW5zYWN0aW9ucy5cXFwiXFxuICAgICApXFxuXFxuICAgKGRlZnVuIGNyZWF0ZS1hY2NvdW50OnN0cmluZ1xcbiAgICAgKCBhY2NvdW50OnN0cmluZ1xcbiAgICAgICBndWFyZDpndWFyZFxcbiAgICAgKVxcbiAgICAgXFxcIiBDcmVhdGUgQUNDT1VOVCB3aXRoIDAuMCBiYWxhbmNlLCB3aXRoIEdVQVJEIGNvbnRyb2xsaW5nIGFjY2Vzcy5cXFwiXFxuICAgICApXFxuXFxuICAgKGRlZnVuIHJvdGF0ZTpzdHJpbmdcXG4gICAgICggYWNjb3VudDpzdHJpbmdcXG4gICAgICAgbmV3LWd1YXJkOmd1YXJkXFxuICAgICApXFxuICAgICBcXFwiIFJvdGF0ZSBndWFyZCBmb3IgQUNDT1VOVC4gVHJhbnNhY3Rpb24gaXMgdmFsaWRhdGVkIGFnYWluc3QgXFxcXFxcbiAgICAgXFxcXCBleGlzdGluZyBndWFyZCBiZWZvcmUgaW5zdGFsbGluZyBuZXcgZ3VhcmQuIFxcXCJcXG4gICAgIClcXG5cXG4pXFxuXCJ9fSxcInNpZ25lcnNcIjpbXSxcIm1ldGFcIjp7XCJjcmVhdGlvblRpbWVcIjowLFwidHRsXCI6MTcyODAwLFwiZ2FzTGltaXRcIjowLFwiY2hhaW5JZFwiOlwiXCIsXCJnYXNQcmljZVwiOjAsXCJzZW5kZXJcIjpcIlwifSxcIm5vbmNlXCI6XCJmdW5naWJsZS1hc3NldC12MlwifSJ9", unsafeFromText "eyJnYXMiOjAsInJlc3VsdCI6eyJzdGF0dXMiOiJzdWNjZXNzIiwiZGF0YSI6IkxvYWRlZCBpbnRlcmZhY2UgZnVuZ2libGUtdjIsIGhhc2ggWXhFLUtnQzZKbUttQ2NnS1RKbWxFbl9JNThJNEVYbWhmcnZ6WDdiZXJZayJ9LCJyZXFLZXkiOiIwNUJ0ajdlQlpCVzdvLVNhTG9WaEFpY01VUFpVQmJHNlFUOF9MQWtDeEhzIiwibG9ncyI6IjFTQmJBNHVzS0E5OFNlX09WRUdkcVk5WjJoSW1jVmcydWpISDJkM1ZmeEkiLCJtZXRhRGF0YSI6bnVsbCwiY29udGludWF0aW9uIjpudWxsLCJ0eElkIjoyfQ") + , (unsafeFromText "eyJoYXNoIjoiR1JJUXU0aEFLazBJRDlGOHpfLTB5WHlBS0ozM01QeVRZTVhPamxQSm1wSSIsInNpZ3MiOltdLCJjbWQiOiJ7XCJuZXR3b3JrSWRcIjpudWxsLFwicGF5bG9hZFwiOntcImV4ZWNcIjp7XCJkYXRhXCI6bnVsbCxcImNvZGVcIjpcIlxcbihtb2R1bGUgY29pbiBHT1ZFUk5BTkNFXFxuXFxuICBAZG9jIFxcXCInY29pbicgcmVwcmVzZW50cyB0aGUgS2FkZW5hIENvaW4gQ29udHJhY3QuIFRoaXMgY29udHJhY3QgcHJvdmlkZXMgYm90aCB0aGUgXFxcXFxcbiAgXFxcXGJ1eS9yZWRlZW0gZ2FzIHN1cHBvcnQgaW4gdGhlIGZvcm0gb2YgJ2Z1bmQtdHgnLCBhcyB3ZWxsIGFzIHRyYW5zZmVyLCAgICAgICBcXFxcXFxuICBcXFxcY3JlZGl0LCBkZWJpdCwgY29pbmJhc2UsIGFjY291bnQgY3JlYXRpb24gYW5kIHF1ZXJ5LCBhcyB3ZWxsIGFzIFNQViBidXJuICAgIFxcXFxcXG4gIFxcXFxjcmVhdGUuIFRvIGFjY2VzcyB0aGUgY29pbiBjb250cmFjdCwgeW91IG1heSB1c2UgaXRzIGZ1bGx5LXF1YWxpZmllZCBuYW1lLCAgXFxcXFxcbiAgXFxcXG9yIGlzc3VlIHRoZSAnKHVzZSBjb2luKScgY29tbWFuZCBpbiB0aGUgYm9keSBvZiBhIG1vZHVsZSBkZWNsYXJhdGlvbi5cXFwiXFxuXFxuICBAbW9kZWxcXG4gICAgWyAoZGVmcHJvcGVydHkgY29uc2VydmVzLW1hc3NcXG4gICAgICAgICg9IChjb2x1bW4tZGVsdGEgY29pbi10YWJsZSAnYmFsYW5jZSkgMC4wKSlcXG5cXG4gICAgICAoZGVmcHJvcGVydHkgdmFsaWQtYWNjb3VudCAoYWNjb3VudDpzdHJpbmcpXFxuICAgICAgICAoYW5kXFxuICAgICAgICAgICg-PSAobGVuZ3RoIGFjY291bnQpIDMpXFxuICAgICAgICAgICg8PSAobGVuZ3RoIGFjY291bnQpIDI1NikpKVxcbiAgICBdXFxuXFxuICAoaW1wbGVtZW50cyBmdW5naWJsZS12MilcXG4gIChpbXBsZW1lbnRzIGZ1bmdpYmxlLXhjaGFpbi12MSlcXG5cXG4gIDs7IGNvaW4tdjJcXG4gIChibGVzcyBcXFwidXRfSl9aTmtveWFQVUVKaGl3VmVXbmtTUW45SlQ5c1FDV0tkampWVnJXb1xcXCIpXFxuXFxuICA7OyBjb2luIHYzXFxuICAoYmxlc3MgXFxcIjFvc19zTEFVWXZCenNwbjVqamF3dFJwSldpSDFXUGZoeU5yYWVWdlNJd1VcXFwiKVxcblxcbiAgOzsgY29pbiB2NFxcbiAgKGJsZXNzIFxcXCJCalpXMFQyYWM2cUVfSTVYOEdFNGZhbDZ0VHFqaExUQzdteTB5dFFTeExVXFxcIilcXG5cXG4gIDs7IGNvaW4gdjVcXG4gIChibGVzcyBcXFwickU3RFU4amxRTDl4X01QWXVuaVpKZjVJQ0JUQUVIQUlGUUNCNGJsb2ZQNFxcXCIpXFxuXFxuICA7IC0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tXFxuICA7IFNjaGVtYXMgYW5kIFRhYmxlc1xcblxcbiAgKGRlZnNjaGVtYSBjb2luLXNjaGVtYVxcbiAgICBAZG9jIFxcXCJUaGUgY29pbiBjb250cmFjdCB0b2tlbiBzY2hlbWFcXFwiXFxuICAgIEBtb2RlbCBbIChpbnZhcmlhbnQgKD49IGJhbGFuY2UgMC4wKSkgXVxcblxcbiAgICBiYWxhbmNlOmRlY2ltYWxcXG4gICAgZ3VhcmQ6Z3VhcmQpXFxuXFxuICAoZGVmdGFibGUgY29pbi10YWJsZTp7Y29pbi1zY2hlbWF9KVxcblxcbiAgOyAtLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLVxcbiAgOyBDYXBhYmlsaXRpZXNcXG5cXG4gIChkZWZjYXAgR09WRVJOQU5DRSAoKVxcbiAgICAoZW5mb3JjZSBmYWxzZSBcXFwiRW5mb3JjZSBub24tdXBncmFkZWFiaWxpdHlcXFwiKSlcXG5cXG4gIChkZWZjYXAgR0FTICgpXFxuICAgIFxcXCJNYWdpYyBjYXBhYmlsaXR5IHRvIHByb3RlY3QgZ2FzIGJ1eSBhbmQgcmVkZWVtXFxcIlxcbiAgICB0cnVlKVxcblxcbiAgKGRlZmNhcCBDT0lOQkFTRSAoKVxcbiAgICBcXFwiTWFnaWMgY2FwYWJpbGl0eSB0byBwcm90ZWN0IG1pbmVyIHJld2FyZFxcXCJcXG4gICAgdHJ1ZSlcXG5cXG4gIChkZWZjYXAgR0VORVNJUyAoKVxcbiAgICBcXFwiTWFnaWMgY2FwYWJpbGl0eSBjb25zdHJhaW5pbmcgZ2VuZXNpcyB0cmFuc2FjdGlvbnNcXFwiXFxuICAgIHRydWUpXFxuXFxuICAoZGVmY2FwIFJFTUVESUFURSAoKVxcbiAgICBcXFwiTWFnaWMgY2FwYWJpbGl0eSBmb3IgcmVtZWRpYXRpb24gdHJhbnNhY3Rpb25zXFxcIlxcbiAgICB0cnVlKVxcblxcbiAgKGRlZmNhcCBERUJJVCAoc2VuZGVyOnN0cmluZylcXG4gICAgXFxcIkNhcGFiaWxpdHkgZm9yIG1hbmFnaW5nIGRlYml0aW5nIG9wZXJhdGlvbnNcXFwiXFxuICAgIChlbmZvcmNlLWd1YXJkIChhdCAnZ3VhcmQgKHJlYWQgY29pbi10YWJsZSBzZW5kZXIpKSlcXG4gICAgKGVuZm9yY2UgKCE9IHNlbmRlciBcXFwiXFxcIikgXFxcInZhbGlkIHNlbmRlclxcXCIpKVxcblxcbiAgKGRlZmNhcCBDUkVESVQgKHJlY2VpdmVyOnN0cmluZylcXG4gICAgXFxcIkNhcGFiaWxpdHkgZm9yIG1hbmFnaW5nIGNyZWRpdGluZyBvcGVyYXRpb25zXFxcIlxcbiAgICAoZW5mb3JjZSAoIT0gcmVjZWl2ZXIgXFxcIlxcXCIpIFxcXCJ2YWxpZCByZWNlaXZlclxcXCIpKVxcblxcbiAgKGRlZmNhcCBST1RBVEUgKGFjY291bnQ6c3RyaW5nKVxcbiAgICBAZG9jIFxcXCJBdXRvbm9tb3VzbHkgbWFuYWdlZCBjYXBhYmlsaXR5IGZvciBndWFyZCByb3RhdGlvblxcXCJcXG4gICAgQG1hbmFnZWRcXG4gICAgdHJ1ZSlcXG5cXG4gIChkZWZjYXAgVFJBTlNGRVI6Ym9vbFxcbiAgICAoIHNlbmRlcjpzdHJpbmdcXG4gICAgICByZWNlaXZlcjpzdHJpbmdcXG4gICAgICBhbW91bnQ6ZGVjaW1hbFxcbiAgICApXFxuICAgIEBtYW5hZ2VkIGFtb3VudCBUUkFOU0ZFUi1tZ3JcXG4gICAgKGVuZm9yY2UgKCE9IHNlbmRlciByZWNlaXZlcikgXFxcInNhbWUgc2VuZGVyIGFuZCByZWNlaXZlclxcXCIpXFxuICAgIChlbmZvcmNlLXVuaXQgYW1vdW50KVxcbiAgICAoZW5mb3JjZSAoPiBhbW91bnQgMC4wKSBcXFwiUG9zaXRpdmUgYW1vdW50XFxcIilcXG4gICAgKGNvbXBvc2UtY2FwYWJpbGl0eSAoREVCSVQgc2VuZGVyKSlcXG4gICAgKGNvbXBvc2UtY2FwYWJpbGl0eSAoQ1JFRElUIHJlY2VpdmVyKSlcXG4gIClcXG5cXG4gIChkZWZ1biBUUkFOU0ZFUi1tZ3I6ZGVjaW1hbFxcbiAgICAoIG1hbmFnZWQ6ZGVjaW1hbFxcbiAgICAgIHJlcXVlc3RlZDpkZWNpbWFsXFxuICAgIClcXG5cXG4gICAgKGxldCAoKG5ld2JhbCAoLSBtYW5hZ2VkIHJlcXVlc3RlZCkpKVxcbiAgICAgIChlbmZvcmNlICg-PSBuZXdiYWwgMC4wKVxcbiAgICAgICAgKGZvcm1hdCBcXFwiVFJBTlNGRVIgZXhjZWVkZWQgZm9yIGJhbGFuY2Uge31cXFwiIFttYW5hZ2VkXSkpXFxuICAgICAgbmV3YmFsKVxcbiAgKVxcblxcbiAgKGRlZmNhcCBUUkFOU0ZFUl9YQ0hBSU46Ym9vbFxcbiAgICAoIHNlbmRlcjpzdHJpbmdcXG4gICAgICByZWNlaXZlcjpzdHJpbmdcXG4gICAgICBhbW91bnQ6ZGVjaW1hbFxcbiAgICAgIHRhcmdldC1jaGFpbjpzdHJpbmdcXG4gICAgKVxcblxcbiAgICBAbWFuYWdlZCBhbW91bnQgVFJBTlNGRVJfWENIQUlOLW1nclxcbiAgICAoZW5mb3JjZS11bml0IGFtb3VudClcXG4gICAgKGVuZm9yY2UgKD4gYW1vdW50IDAuMCkgXFxcIkNyb3NzLWNoYWluIHRyYW5zZmVycyByZXF1aXJlIGEgcG9zaXRpdmUgYW1vdW50XFxcIilcXG4gICAgKGNvbXBvc2UtY2FwYWJpbGl0eSAoREVCSVQgc2VuZGVyKSlcXG4gIClcXG5cXG4gIChkZWZ1biBUUkFOU0ZFUl9YQ0hBSU4tbWdyOmRlY2ltYWxcXG4gICAgKCBtYW5hZ2VkOmRlY2ltYWxcXG4gICAgICByZXF1ZXN0ZWQ6ZGVjaW1hbFxcbiAgICApXFxuXFxuICAgIChlbmZvcmNlICg-PSBtYW5hZ2VkIHJlcXVlc3RlZClcXG4gICAgICAoZm9ybWF0IFxcXCJUUkFOU0ZFUl9YQ0hBSU4gZXhjZWVkZWQgZm9yIGJhbGFuY2Uge31cXFwiIFttYW5hZ2VkXSkpXFxuICAgIDAuMFxcbiAgKVxcblxcbiAgKGRlZmNhcCBUUkFOU0ZFUl9YQ0hBSU5fUkVDRDpib29sXFxuICAgICggc2VuZGVyOnN0cmluZ1xcbiAgICAgIHJlY2VpdmVyOnN0cmluZ1xcbiAgICAgIGFtb3VudDpkZWNpbWFsXFxuICAgICAgc291cmNlLWNoYWluOnN0cmluZ1xcbiAgICApXFxuICAgIEBldmVudCB0cnVlXFxuICApXFxuXFxuICA7IHYzIGNhcGFiaWxpdGllc1xcbiAgKGRlZmNhcCBSRUxFQVNFX0FMTE9DQVRJT05cXG4gICAgKCBhY2NvdW50OnN0cmluZ1xcbiAgICAgIGFtb3VudDpkZWNpbWFsXFxuICAgIClcXG4gICAgQGRvYyBcXFwiRXZlbnQgZm9yIGFsbG9jYXRpb24gcmVsZWFzZSwgY2FuIGJlIHVzZWQgZm9yIHNpZyBzY29waW5nLlxcXCJcXG4gICAgQGV2ZW50IHRydWVcXG4gIClcXG5cXG4gIDsgLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS1cXG4gIDsgQ29uc3RhbnRzXFxuXFxuICAoZGVmY29uc3QgQ09JTl9DSEFSU0VUIENIQVJTRVRfTEFUSU4xXFxuICAgIFxcXCJUaGUgZGVmYXVsdCBjb2luIGNvbnRyYWN0IGNoYXJhY3RlciBzZXRcXFwiKVxcblxcbiAgKGRlZmNvbnN0IE1JTklNVU1fUFJFQ0lTSU9OIDEyXFxuICAgIFxcXCJNaW5pbXVtIGFsbG93ZWQgcHJlY2lzaW9uIGZvciBjb2luIHRyYW5zYWN0aW9uc1xcXCIpXFxuXFxuICAoZGVmY29uc3QgTUlOSU1VTV9BQ0NPVU5UX0xFTkdUSCAzXFxuICAgIFxcXCJNaW5pbXVtIGFjY291bnQgbGVuZ3RoIGFkbWlzc2libGUgZm9yIGNvaW4gYWNjb3VudHNcXFwiKVxcblxcbiAgKGRlZmNvbnN0IE1BWElNVU1fQUNDT1VOVF9MRU5HVEggMjU2XFxuICAgIFxcXCJNYXhpbXVtIGFjY291bnQgbmFtZSBsZW5ndGggYWRtaXNzaWJsZSBmb3IgY29pbiBhY2NvdW50c1xcXCIpXFxuXFxuICAoZGVmY29uc3QgVkFMSURfQ0hBSU5fSURTIChtYXAgKGludC10by1zdHIgMTApIChlbnVtZXJhdGUgMCAxOSkpXFxuICAgIFxcXCJMaXN0IG9mIGFsbCB2YWxpZCBDaGFpbndlYiBjaGFpbiBpZHNcXFwiKVxcblxcbiAgOyAtLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLVxcbiAgOyBVdGlsaXRpZXNcXG5cXG4gIChkZWZ1biBlbmZvcmNlLXVuaXQ6Ym9vbCAoYW1vdW50OmRlY2ltYWwpXFxuICAgIEBkb2MgXFxcIkVuZm9yY2UgbWluaW11bSBwcmVjaXNpb24gYWxsb3dlZCBmb3IgY29pbiB0cmFuc2FjdGlvbnNcXFwiXFxuXFxuICAgIChlbmZvcmNlXFxuICAgICAgKD0gKGZsb29yIGFtb3VudCBNSU5JTVVNX1BSRUNJU0lPTilcXG4gICAgICAgICBhbW91bnQpXFxuICAgICAgKGZvcm1hdCBcXFwiQW1vdW50IHZpb2xhdGVzIG1pbmltdW0gcHJlY2lzaW9uOiB7fVxcXCIgW2Ftb3VudF0pKVxcbiAgICApXFxuXFxuICAoZGVmdW4gdmFsaWRhdGUtYWNjb3VudCAoYWNjb3VudDpzdHJpbmcpXFxuICAgIEBkb2MgXFxcIkVuZm9yY2UgdGhhdCBhbiBhY2NvdW50IG5hbWUgY29uZm9ybXMgdG8gdGhlIGNvaW4gY29udHJhY3QgXFxcXFxcbiAgICAgICAgIFxcXFxtaW5pbXVtIGFuZCBtYXhpbXVtIGxlbmd0aCByZXF1aXJlbWVudHMsIGFzIHdlbGwgYXMgdGhlICAgIFxcXFxcXG4gICAgICAgICBcXFxcbGF0aW4tMSBjaGFyYWN0ZXIgc2V0LlxcXCJcXG5cXG4gICAgKGVuZm9yY2VcXG4gICAgICAoaXMtY2hhcnNldCBDT0lOX0NIQVJTRVQgYWNjb3VudClcXG4gICAgICAoZm9ybWF0XFxuICAgICAgICBcXFwiQWNjb3VudCBkb2VzIG5vdCBjb25mb3JtIHRvIHRoZSBjb2luIGNvbnRyYWN0IGNoYXJzZXQ6IHt9XFxcIlxcbiAgICAgICAgW2FjY291bnRdKSlcXG5cXG4gICAgKGxldCAoKGFjY291bnQtbGVuZ3RoIChsZW5ndGggYWNjb3VudCkpKVxcblxcbiAgICAgIChlbmZvcmNlXFxuICAgICAgICAoPj0gYWNjb3VudC1sZW5ndGggTUlOSU1VTV9BQ0NPVU5UX0xFTkdUSClcXG4gICAgICAgIChmb3JtYXRcXG4gICAgICAgICAgXFxcIkFjY291bnQgbmFtZSBkb2VzIG5vdCBjb25mb3JtIHRvIHRoZSBtaW4gbGVuZ3RoIHJlcXVpcmVtZW50OiB7fVxcXCJcXG4gICAgICAgICAgW2FjY291bnRdKSlcXG5cXG4gICAgICAoZW5mb3JjZVxcbiAgICAgICAgKDw9IGFjY291bnQtbGVuZ3RoIE1BWElNVU1fQUNDT1VOVF9MRU5HVEgpXFxuICAgICAgICAoZm9ybWF0XFxuICAgICAgICAgIFxcXCJBY2NvdW50IG5hbWUgZG9lcyBub3QgY29uZm9ybSB0byB0aGUgbWF4IGxlbmd0aCByZXF1aXJlbWVudDoge31cXFwiXFxuICAgICAgICAgIFthY2NvdW50XSkpXFxuICAgICAgKVxcbiAgKVxcblxcbiAgOyAtLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLVxcbiAgOyBDb2luIENvbnRyYWN0XFxuXFxuICAoZGVmdW4gZ2FzLW9ubHkgKClcXG4gICAgXFxcIlByZWRpY2F0ZSBmb3IgZ2FzLW9ubHkgdXNlciBndWFyZHMuXFxcIlxcbiAgICAocmVxdWlyZS1jYXBhYmlsaXR5IChHQVMpKSlcXG5cXG4gIChkZWZ1biBnYXMtZ3VhcmQgKGd1YXJkOmd1YXJkKVxcbiAgICBcXFwiUHJlZGljYXRlIGZvciBnYXMgKyBzaW5nbGUga2V5IHVzZXIgZ3VhcmRzXFxcIlxcbiAgICAoZW5mb3JjZS1vbmVcXG4gICAgICBcXFwiRW5mb3JjZSBlaXRoZXIgdGhlIHByZXNlbmNlIG9mIGEgR0FTIGNhcCBvciBrZXlzZXRcXFwiXFxuICAgICAgWyAoZ2FzLW9ubHkpXFxuICAgICAgICAoZW5mb3JjZS1ndWFyZCBndWFyZClcXG4gICAgICBdKSlcXG5cXG4gIChkZWZ1biBidXktZ2FzOnN0cmluZyAoc2VuZGVyOnN0cmluZyB0b3RhbDpkZWNpbWFsKVxcbiAgICBAZG9jIFxcXCJUaGlzIGZ1bmN0aW9uIGRlc2NyaWJlcyB0aGUgbWFpbiAnZ2FzIGJ1eScgb3BlcmF0aW9uLiBBdCB0aGlzIHBvaW50IFxcXFxcXG4gICAgXFxcXE1JTkVSIGhhcyBiZWVuIGNob3NlbiBmcm9tIHRoZSBwb29sLCBhbmQgd2lsbCBiZSB2YWxpZGF0ZWQuIFRoZSBTRU5ERVIgICBcXFxcXFxuICAgIFxcXFxvZiB0aGlzIHRyYW5zYWN0aW9uIGhhcyBzcGVjaWZpZWQgYSBnYXMgbGltaXQgTElNSVQgKG1heGltdW0gZ2FzKSBmb3IgICAgXFxcXFxcbiAgICBcXFxcdGhlIHRyYW5zYWN0aW9uLCBhbmQgdGhlIHByaWNlIGlzIHRoZSBzcG90IHByaWNlIG9mIGdhcyBhdCB0aGF0IHRpbWUuICAgIFxcXFxcXG4gICAgXFxcXFRoZSBnYXMgYnV5IHdpbGwgYmUgZXhlY3V0ZWQgcHJpb3IgdG8gZXhlY3V0aW5nIFNFTkRFUidzIGNvZGUuXFxcIlxcblxcbiAgICBAbW9kZWwgWyAocHJvcGVydHkgKD4gdG90YWwgMC4wKSlcXG4gICAgICAgICAgICAgKHByb3BlcnR5ICh2YWxpZC1hY2NvdW50IHNlbmRlcikpXFxuICAgICAgICAgICBdXFxuXFxuICAgICh2YWxpZGF0ZS1hY2NvdW50IHNlbmRlcilcXG5cXG4gICAgKGVuZm9yY2UtdW5pdCB0b3RhbClcXG4gICAgKGVuZm9yY2UgKD4gdG90YWwgMC4wKSBcXFwiZ2FzIHN1cHBseSBtdXN0IGJlIGEgcG9zaXRpdmUgcXVhbnRpdHlcXFwiKVxcblxcbiAgICAocmVxdWlyZS1jYXBhYmlsaXR5IChHQVMpKVxcbiAgICAod2l0aC1jYXBhYmlsaXR5IChERUJJVCBzZW5kZXIpXFxuICAgICAgKGRlYml0IHNlbmRlciB0b3RhbCkpXFxuICAgIClcXG5cXG4gIChkZWZ1biByZWRlZW0tZ2FzOnN0cmluZyAobWluZXI6c3RyaW5nIG1pbmVyLWd1YXJkOmd1YXJkIHNlbmRlcjpzdHJpbmcgdG90YWw6ZGVjaW1hbClcXG4gICAgQGRvYyBcXFwiVGhpcyBmdW5jdGlvbiBkZXNjcmliZXMgdGhlIG1haW4gJ3JlZGVlbSBnYXMnIG9wZXJhdGlvbi4gQXQgdGhpcyAgICBcXFxcXFxuICAgIFxcXFxwb2ludCwgdGhlIFNFTkRFUidzIHRyYW5zYWN0aW9uIGhhcyBiZWVuIGV4ZWN1dGVkLCBhbmQgdGhlIGdhcyB0aGF0ICAgICAgXFxcXFxcbiAgICBcXFxcd2FzIGNoYXJnZWQgaGFzIGJlZW4gY2FsY3VsYXRlZC4gTUlORVIgd2lsbCBiZSBjcmVkaXRlZCB0aGUgZ2FzIGNvc3QsICAgIFxcXFxcXG4gICAgXFxcXGFuZCBTRU5ERVIgd2lsbCByZWNlaXZlIHRoZSByZW1haW5kZXIgdXAgdG8gdGhlIGxpbWl0XFxcIlxcblxcbiAgICBAbW9kZWwgWyAocHJvcGVydHkgKD4gdG90YWwgMC4wKSlcXG4gICAgICAgICAgICAgKHByb3BlcnR5ICh2YWxpZC1hY2NvdW50IHNlbmRlcikpXFxuICAgICAgICAgICAgIChwcm9wZXJ0eSAodmFsaWQtYWNjb3VudCBtaW5lcikpXFxuICAgICAgICAgICBdXFxuXFxuICAgICh2YWxpZGF0ZS1hY2NvdW50IHNlbmRlcilcXG4gICAgKHZhbGlkYXRlLWFjY291bnQgbWluZXIpXFxuICAgIChlbmZvcmNlLXVuaXQgdG90YWwpXFxuXFxuICAgIChyZXF1aXJlLWNhcGFiaWxpdHkgKEdBUykpXFxuICAgIChsZXQqXFxuICAgICAgKChmZWUgKHJlYWQtZGVjaW1hbCBcXFwiZmVlXFxcIikpXFxuICAgICAgIChyZWZ1bmQgKC0gdG90YWwgZmVlKSkpXFxuXFxuICAgICAgKGVuZm9yY2UtdW5pdCBmZWUpXFxuICAgICAgKGVuZm9yY2UgKD49IGZlZSAwLjApXFxuICAgICAgICBcXFwiZmVlIG11c3QgYmUgYSBub24tbmVnYXRpdmUgcXVhbnRpdHlcXFwiKVxcblxcbiAgICAgIChlbmZvcmNlICg-PSByZWZ1bmQgMC4wKVxcbiAgICAgICAgXFxcInJlZnVuZCBtdXN0IGJlIGEgbm9uLW5lZ2F0aXZlIHF1YW50aXR5XFxcIilcXG5cXG4gICAgICAoZW1pdC1ldmVudCAoVFJBTlNGRVIgc2VuZGVyIG1pbmVyIGZlZSkpIDt2M1xcblxcbiAgICAgICAgOyBkaXJlY3RseSB1cGRhdGUgaW5zdGVhZCBvZiBjcmVkaXRcXG4gICAgICAod2l0aC1jYXBhYmlsaXR5IChDUkVESVQgc2VuZGVyKVxcbiAgICAgICAgKGlmICg-IHJlZnVuZCAwLjApXFxuICAgICAgICAgICh3aXRoLXJlYWQgY29pbi10YWJsZSBzZW5kZXJcXG4gICAgICAgICAgICB7IFxcXCJiYWxhbmNlXFxcIiA6PSBiYWxhbmNlIH1cXG4gICAgICAgICAgICAodXBkYXRlIGNvaW4tdGFibGUgc2VuZGVyXFxuICAgICAgICAgICAgICB7IFxcXCJiYWxhbmNlXFxcIjogKCsgYmFsYW5jZSByZWZ1bmQpIH0pKVxcblxcbiAgICAgICAgICBcXFwibm9vcFxcXCIpKVxcblxcbiAgICAgICh3aXRoLWNhcGFiaWxpdHkgKENSRURJVCBtaW5lcilcXG4gICAgICAgIChpZiAoPiBmZWUgMC4wKVxcbiAgICAgICAgICAoY3JlZGl0IG1pbmVyIG1pbmVyLWd1YXJkIGZlZSlcXG4gICAgICAgICAgXFxcIm5vb3BcXFwiKSlcXG4gICAgICApXFxuXFxuICAgIClcXG5cXG4gIChkZWZ1biBjcmVhdGUtYWNjb3VudDpzdHJpbmcgKGFjY291bnQ6c3RyaW5nIGd1YXJkOmd1YXJkKVxcbiAgICBAbW9kZWwgWyAocHJvcGVydHkgKHZhbGlkLWFjY291bnQgYWNjb3VudCkpIF1cXG5cXG4gICAgKHZhbGlkYXRlLWFjY291bnQgYWNjb3VudClcXG4gICAgKGVuZm9yY2UtcmVzZXJ2ZWQgYWNjb3VudCBndWFyZClcXG5cXG4gICAgKGluc2VydCBjb2luLXRhYmxlIGFjY291bnRcXG4gICAgICB7IFxcXCJiYWxhbmNlXFxcIiA6IDAuMFxcbiAgICAgICwgXFxcImd1YXJkXFxcIiAgIDogZ3VhcmRcXG4gICAgICB9KVxcbiAgICApXFxuXFxuICAoZGVmdW4gZ2V0LWJhbGFuY2U6ZGVjaW1hbCAoYWNjb3VudDpzdHJpbmcpXFxuICAgICh3aXRoLXJlYWQgY29pbi10YWJsZSBhY2NvdW50XFxuICAgICAgeyBcXFwiYmFsYW5jZVxcXCIgOj0gYmFsYW5jZSB9XFxuICAgICAgYmFsYW5jZVxcbiAgICAgIClcXG4gICAgKVxcblxcbiAgKGRlZnVuIGRldGFpbHM6b2JqZWN0e2Z1bmdpYmxlLXYyLmFjY291bnQtZGV0YWlsc31cXG4gICAgKCBhY2NvdW50OnN0cmluZyApXFxuICAgICh3aXRoLXJlYWQgY29pbi10YWJsZSBhY2NvdW50XFxuICAgICAgeyBcXFwiYmFsYW5jZVxcXCIgOj0gYmFsXFxuICAgICAgLCBcXFwiZ3VhcmRcXFwiIDo9IGcgfVxcbiAgICAgIHsgXFxcImFjY291bnRcXFwiIDogYWNjb3VudFxcbiAgICAgICwgXFxcImJhbGFuY2VcXFwiIDogYmFsXFxuICAgICAgLCBcXFwiZ3VhcmRcXFwiOiBnIH0pXFxuICAgIClcXG5cXG4gIChkZWZ1biByb3RhdGU6c3RyaW5nIChhY2NvdW50OnN0cmluZyBuZXctZ3VhcmQ6Z3VhcmQpXFxuICAgICh3aXRoLWNhcGFiaWxpdHkgKFJPVEFURSBhY2NvdW50KVxcblxcbiAgICAgIDsgQWxsb3cgcm90YXRpb24gb25seSBmb3IgdmFuaXR5IGFjY291bnRzLCBvclxcbiAgICAgIDsgcmUtcm90YXRpbmcgYSBwcmluY2lwYWwgYWNjb3VudCBiYWNrIHRvIGl0cyBwcm9wZXIgZ3VhcmRcXG4gICAgICAoZW5mb3JjZSAob3IgKG5vdCAoaXMtcHJpbmNpcGFsIGFjY291bnQpKVxcbiAgICAgICAgICAgICAgICAgICh2YWxpZGF0ZS1wcmluY2lwYWwgbmV3LWd1YXJkIGFjY291bnQpKVxcbiAgICAgICAgXFxcIkl0IGlzIHVuc2FmZSBmb3IgcHJpbmNpcGFsIGFjY291bnRzIHRvIHJvdGF0ZSB0aGVpciBndWFyZFxcXCIpXFxuXFxuICAgICAgKHdpdGgtcmVhZCBjb2luLXRhYmxlIGFjY291bnRcXG4gICAgICAgIHsgXFxcImd1YXJkXFxcIiA6PSBvbGQtZ3VhcmQgfVxcbiAgICAgICAgKGVuZm9yY2UtZ3VhcmQgb2xkLWd1YXJkKVxcbiAgICAgICAgKHVwZGF0ZSBjb2luLXRhYmxlIGFjY291bnRcXG4gICAgICAgICAgeyBcXFwiZ3VhcmRcXFwiIDogbmV3LWd1YXJkIH1cXG4gICAgICAgICAgKSkpXFxuICAgIClcXG5cXG5cXG4gIChkZWZ1biBwcmVjaXNpb246aW50ZWdlclxcbiAgICAoKVxcbiAgICBNSU5JTVVNX1BSRUNJU0lPTilcXG5cXG4gIChkZWZ1biB0cmFuc2ZlcjpzdHJpbmcgKHNlbmRlcjpzdHJpbmcgcmVjZWl2ZXI6c3RyaW5nIGFtb3VudDpkZWNpbWFsKVxcbiAgICBAbW9kZWwgWyAocHJvcGVydHkgY29uc2VydmVzLW1hc3MpXFxuICAgICAgICAgICAgIChwcm9wZXJ0eSAoPiBhbW91bnQgMC4wKSlcXG4gICAgICAgICAgICAgKHByb3BlcnR5ICh2YWxpZC1hY2NvdW50IHNlbmRlcikpXFxuICAgICAgICAgICAgIChwcm9wZXJ0eSAodmFsaWQtYWNjb3VudCByZWNlaXZlcikpXFxuICAgICAgICAgICAgIChwcm9wZXJ0eSAoIT0gc2VuZGVyIHJlY2VpdmVyKSkgXVxcblxcbiAgICAoZW5mb3JjZSAoIT0gc2VuZGVyIHJlY2VpdmVyKVxcbiAgICAgIFxcXCJzZW5kZXIgY2Fubm90IGJlIHRoZSByZWNlaXZlciBvZiBhIHRyYW5zZmVyXFxcIilcXG5cXG4gICAgKHZhbGlkYXRlLWFjY291bnQgc2VuZGVyKVxcbiAgICAodmFsaWRhdGUtYWNjb3VudCByZWNlaXZlcilcXG5cXG4gICAgKGVuZm9yY2UgKD4gYW1vdW50IDAuMClcXG4gICAgICBcXFwidHJhbnNmZXIgYW1vdW50IG11c3QgYmUgcG9zaXRpdmVcXFwiKVxcblxcbiAgICAoZW5mb3JjZS11bml0IGFtb3VudClcXG5cXG4gICAgKHdpdGgtY2FwYWJpbGl0eSAoVFJBTlNGRVIgc2VuZGVyIHJlY2VpdmVyIGFtb3VudClcXG4gICAgICAoZGViaXQgc2VuZGVyIGFtb3VudClcXG4gICAgICAod2l0aC1yZWFkIGNvaW4tdGFibGUgcmVjZWl2ZXJcXG4gICAgICAgIHsgXFxcImd1YXJkXFxcIiA6PSBnIH1cXG5cXG4gICAgICAgIChjcmVkaXQgcmVjZWl2ZXIgZyBhbW91bnQpKVxcbiAgICAgIClcXG4gICAgKVxcblxcbiAgKGRlZnVuIHRyYW5zZmVyLWNyZWF0ZTpzdHJpbmdcXG4gICAgKCBzZW5kZXI6c3RyaW5nXFxuICAgICAgcmVjZWl2ZXI6c3RyaW5nXFxuICAgICAgcmVjZWl2ZXItZ3VhcmQ6Z3VhcmRcXG4gICAgICBhbW91bnQ6ZGVjaW1hbCApXFxuXFxuICAgIEBtb2RlbCBbIChwcm9wZXJ0eSBjb25zZXJ2ZXMtbWFzcykgXVxcblxcbiAgICAoZW5mb3JjZSAoIT0gc2VuZGVyIHJlY2VpdmVyKVxcbiAgICAgIFxcXCJzZW5kZXIgY2Fubm90IGJlIHRoZSByZWNlaXZlciBvZiBhIHRyYW5zZmVyXFxcIilcXG5cXG4gICAgKHZhbGlkYXRlLWFjY291bnQgc2VuZGVyKVxcbiAgICAodmFsaWRhdGUtYWNjb3VudCByZWNlaXZlcilcXG5cXG4gICAgKGVuZm9yY2UgKD4gYW1vdW50IDAuMClcXG4gICAgICBcXFwidHJhbnNmZXIgYW1vdW50IG11c3QgYmUgcG9zaXRpdmVcXFwiKVxcblxcbiAgICAoZW5mb3JjZS11bml0IGFtb3VudClcXG5cXG4gICAgKHdpdGgtY2FwYWJpbGl0eSAoVFJBTlNGRVIgc2VuZGVyIHJlY2VpdmVyIGFtb3VudClcXG4gICAgICAoZGViaXQgc2VuZGVyIGFtb3VudClcXG4gICAgICAoY3JlZGl0IHJlY2VpdmVyIHJlY2VpdmVyLWd1YXJkIGFtb3VudCkpXFxuICAgIClcXG5cXG4gIChkZWZ1biBjb2luYmFzZTpzdHJpbmcgKGFjY291bnQ6c3RyaW5nIGFjY291bnQtZ3VhcmQ6Z3VhcmQgYW1vdW50OmRlY2ltYWwpXFxuICAgIEBkb2MgXFxcIkludGVybmFsIGZ1bmN0aW9uIGZvciB0aGUgaW5pdGlhbCBjcmVhdGlvbiBvZiBjb2lucy4gIFRoaXMgZnVuY3Rpb24gXFxcXFxcbiAgICBcXFxcY2Fubm90IGJlIHVzZWQgb3V0c2lkZSBvZiB0aGUgY29pbiBjb250cmFjdC5cXFwiXFxuXFxuICAgIEBtb2RlbCBbIChwcm9wZXJ0eSAodmFsaWQtYWNjb3VudCBhY2NvdW50KSlcXG4gICAgICAgICAgICAgKHByb3BlcnR5ICg-IGFtb3VudCAwLjApKVxcbiAgICAgICAgICAgXVxcblxcbiAgICAodmFsaWRhdGUtYWNjb3VudCBhY2NvdW50KVxcbiAgICAoZW5mb3JjZS11bml0IGFtb3VudClcXG5cXG4gICAgKHJlcXVpcmUtY2FwYWJpbGl0eSAoQ09JTkJBU0UpKVxcbiAgICAoZW1pdC1ldmVudCAoVFJBTlNGRVIgXFxcIlxcXCIgYWNjb3VudCBhbW91bnQpKSA7djNcXG4gICAgKHdpdGgtY2FwYWJpbGl0eSAoQ1JFRElUIGFjY291bnQpXFxuICAgICAgKGNyZWRpdCBhY2NvdW50IGFjY291bnQtZ3VhcmQgYW1vdW50KSlcXG4gICAgKVxcblxcbiAgKGRlZnVuIHJlbWVkaWF0ZTpzdHJpbmcgKGFjY291bnQ6c3RyaW5nIGFtb3VudDpkZWNpbWFsKVxcbiAgICBAZG9jIFxcXCJBbGxvd3MgZm9yIHJlbWVkaWF0aW9uIHRyYW5zYWN0aW9ucy4gVGhpcyBmdW5jdGlvbiBcXFxcXFxuICAgICAgICAgXFxcXGlzIHByb3RlY3RlZCBieSB0aGUgUkVNRURJQVRFIGNhcGFiaWxpdHlcXFwiXFxuICAgIEBtb2RlbCBbIChwcm9wZXJ0eSAodmFsaWQtYWNjb3VudCBhY2NvdW50KSlcXG4gICAgICAgICAgICAgKHByb3BlcnR5ICg-IGFtb3VudCAwLjApKVxcbiAgICAgICAgICAgXVxcblxcbiAgICAodmFsaWRhdGUtYWNjb3VudCBhY2NvdW50KVxcblxcbiAgICAoZW5mb3JjZSAoPiBhbW91bnQgMC4wKVxcbiAgICAgIFxcXCJSZW1lZGlhdGlvbiBhbW91bnQgbXVzdCBiZSBwb3NpdGl2ZVxcXCIpXFxuXFxuICAgIChlbmZvcmNlLXVuaXQgYW1vdW50KVxcblxcbiAgICAocmVxdWlyZS1jYXBhYmlsaXR5IChSRU1FRElBVEUpKVxcbiAgICAoZW1pdC1ldmVudCAoVFJBTlNGRVIgXFxcIlxcXCIgYWNjb3VudCBhbW91bnQpKSA7djNcXG4gICAgKHdpdGgtcmVhZCBjb2luLXRhYmxlIGFjY291bnRcXG4gICAgICB7IFxcXCJiYWxhbmNlXFxcIiA6PSBiYWxhbmNlIH1cXG5cXG4gICAgICAoZW5mb3JjZSAoPD0gYW1vdW50IGJhbGFuY2UpIFxcXCJJbnN1ZmZpY2llbnQgZnVuZHNcXFwiKVxcblxcbiAgICAgICh1cGRhdGUgY29pbi10YWJsZSBhY2NvdW50XFxuICAgICAgICB7IFxcXCJiYWxhbmNlXFxcIiA6ICgtIGJhbGFuY2UgYW1vdW50KSB9XFxuICAgICAgICApKVxcbiAgICApXFxuXFxuICAoZGVmcGFjdCBmdW5kLXR4IChzZW5kZXI6c3RyaW5nIG1pbmVyOnN0cmluZyBtaW5lci1ndWFyZDpndWFyZCB0b3RhbDpkZWNpbWFsKVxcbiAgICBAZG9jIFxcXCInZnVuZC10eCcgaXMgYSBzcGVjaWFsIHBhY3QgdG8gZnVuZCBhIHRyYW5zYWN0aW9uIGluIHR3byBzdGVwcywgICAgIFxcXFxcXG4gICAgXFxcXHdpdGggdGhlIGFjdHVhbCB0cmFuc2FjdGlvbiB0cmFuc3BpcmluZyBpbiB0aGUgbWlkZGxlOiAgICAgICAgICAgICAgICAgICBcXFxcXFxuICAgIFxcXFwgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgXFxcXFxcbiAgICBcXFxcICAxKSBBIGJ1eWluZyBwaGFzZSwgZGViaXRpbmcgdGhlIHNlbmRlciBmb3IgdG90YWwgZ2FzIGFuZCBmZWUsIHlpZWxkaW5nIFxcXFxcXG4gICAgXFxcXCAgICAgVFhfTUFYX0NIQVJHRS4gICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICBcXFxcXFxuICAgIFxcXFwgIDIpIEEgc2V0dGxlbWVudCBwaGFzZSwgcmVzdW1pbmcgVFhfTUFYX0NIQVJHRSwgYW5kIGFsbG9jYXRpbmcgdG8gdGhlICAgXFxcXFxcbiAgICBcXFxcICAgICBjb2luYmFzZSBhY2NvdW50IGZvciB1c2VkIGdhcyBhbmQgZmVlLCBhbmQgc2VuZGVyIGFjY291bnQgZm9yIGJhbC0gIFxcXFxcXG4gICAgXFxcXCAgICAgYW5jZSAodW51c2VkIGdhcywgaWYgYW55KS5cXFwiXFxuXFxuICAgIEBtb2RlbCBbIChwcm9wZXJ0eSAoPiB0b3RhbCAwLjApKVxcbiAgICAgICAgICAgICAocHJvcGVydHkgKHZhbGlkLWFjY291bnQgc2VuZGVyKSlcXG4gICAgICAgICAgICAgKHByb3BlcnR5ICh2YWxpZC1hY2NvdW50IG1pbmVyKSlcXG4gICAgICAgICAgICAgOyhwcm9wZXJ0eSBjb25zZXJ2ZXMtbWFzcykgbm90IHN1cHBvcnRlZCB5ZXRcXG4gICAgICAgICAgIF1cXG5cXG4gICAgKHN0ZXAgKGJ1eS1nYXMgc2VuZGVyIHRvdGFsKSlcXG4gICAgKHN0ZXAgKHJlZGVlbS1nYXMgbWluZXIgbWluZXItZ3VhcmQgc2VuZGVyIHRvdGFsKSlcXG4gICAgKVxcblxcbiAgKGRlZnVuIGRlYml0OnN0cmluZyAoYWNjb3VudDpzdHJpbmcgYW1vdW50OmRlY2ltYWwpXFxuICAgIEBkb2MgXFxcIkRlYml0IEFNT1VOVCBmcm9tIEFDQ09VTlQgYmFsYW5jZVxcXCJcXG5cXG4gICAgQG1vZGVsIFsgKHByb3BlcnR5ICg-IGFtb3VudCAwLjApKVxcbiAgICAgICAgICAgICAocHJvcGVydHkgKHZhbGlkLWFjY291bnQgYWNjb3VudCkpXFxuICAgICAgICAgICBdXFxuXFxuICAgICh2YWxpZGF0ZS1hY2NvdW50IGFjY291bnQpXFxuXFxuICAgIChlbmZvcmNlICg-IGFtb3VudCAwLjApXFxuICAgICAgXFxcImRlYml0IGFtb3VudCBtdXN0IGJlIHBvc2l0aXZlXFxcIilcXG5cXG4gICAgKGVuZm9yY2UtdW5pdCBhbW91bnQpXFxuXFxuICAgIChyZXF1aXJlLWNhcGFiaWxpdHkgKERFQklUIGFjY291bnQpKVxcbiAgICAod2l0aC1yZWFkIGNvaW4tdGFibGUgYWNjb3VudFxcbiAgICAgIHsgXFxcImJhbGFuY2VcXFwiIDo9IGJhbGFuY2UgfVxcblxcbiAgICAgIChlbmZvcmNlICg8PSBhbW91bnQgYmFsYW5jZSkgXFxcIkluc3VmZmljaWVudCBmdW5kc1xcXCIpXFxuXFxuICAgICAgKHVwZGF0ZSBjb2luLXRhYmxlIGFjY291bnRcXG4gICAgICAgIHsgXFxcImJhbGFuY2VcXFwiIDogKC0gYmFsYW5jZSBhbW91bnQpIH1cXG4gICAgICAgICkpXFxuICAgIClcXG5cXG5cXG4gIChkZWZ1biBjcmVkaXQ6c3RyaW5nIChhY2NvdW50OnN0cmluZyBndWFyZDpndWFyZCBhbW91bnQ6ZGVjaW1hbClcXG4gICAgQGRvYyBcXFwiQ3JlZGl0IEFNT1VOVCB0byBBQ0NPVU5UIGJhbGFuY2VcXFwiXFxuXFxuICAgIEBtb2RlbCBbIChwcm9wZXJ0eSAoPiBhbW91bnQgMC4wKSlcXG4gICAgICAgICAgICAgKHByb3BlcnR5ICh2YWxpZC1hY2NvdW50IGFjY291bnQpKVxcbiAgICAgICAgICAgXVxcblxcbiAgICAodmFsaWRhdGUtYWNjb3VudCBhY2NvdW50KVxcblxcbiAgICAoZW5mb3JjZSAoPiBhbW91bnQgMC4wKSBcXFwiY3JlZGl0IGFtb3VudCBtdXN0IGJlIHBvc2l0aXZlXFxcIilcXG4gICAgKGVuZm9yY2UtdW5pdCBhbW91bnQpXFxuXFxuICAgIChyZXF1aXJlLWNhcGFiaWxpdHkgKENSRURJVCBhY2NvdW50KSlcXG4gICAgKHdpdGgtZGVmYXVsdC1yZWFkIGNvaW4tdGFibGUgYWNjb3VudFxcbiAgICAgIHsgXFxcImJhbGFuY2VcXFwiIDogLTEuMCwgXFxcImd1YXJkXFxcIiA6IGd1YXJkIH1cXG4gICAgICB7IFxcXCJiYWxhbmNlXFxcIiA6PSBiYWxhbmNlLCBcXFwiZ3VhcmRcXFwiIDo9IHJldGcgfVxcbiAgICAgIDsgd2UgZG9uJ3Qgd2FudCB0byBvdmVyd3JpdGUgYW4gZXhpc3RpbmcgZ3VhcmQgd2l0aCB0aGUgdXNlci1zdXBwbGllZCBvbmVcXG4gICAgICAoZW5mb3JjZSAoPSByZXRnIGd1YXJkKVxcbiAgICAgICAgXFxcImFjY291bnQgZ3VhcmRzIGRvIG5vdCBtYXRjaFxcXCIpXFxuXFxuICAgICAgKGxldCAoKGlzLW5ld1xcbiAgICAgICAgICAgICAoaWYgKD0gYmFsYW5jZSAtMS4wKVxcbiAgICAgICAgICAgICAgICAgKGVuZm9yY2UtcmVzZXJ2ZWQgYWNjb3VudCBndWFyZClcXG4gICAgICAgICAgICAgICBmYWxzZSkpKVxcblxcbiAgICAgICAgKHdyaXRlIGNvaW4tdGFibGUgYWNjb3VudFxcbiAgICAgICAgICB7IFxcXCJiYWxhbmNlXFxcIiA6IChpZiBpcy1uZXcgYW1vdW50ICgrIGJhbGFuY2UgYW1vdW50KSlcXG4gICAgICAgICAgLCBcXFwiZ3VhcmRcXFwiICAgOiByZXRnXFxuICAgICAgICAgIH0pKVxcbiAgICAgICkpXFxuXFxuICAoZGVmdW4gY2hlY2stcmVzZXJ2ZWQ6c3RyaW5nIChhY2NvdW50OnN0cmluZylcXG4gICAgXFxcIiBDaGVja3MgQUNDT1VOVCBmb3IgcmVzZXJ2ZWQgbmFtZSBhbmQgcmV0dXJucyB0eXBlIGlmIFxcXFxcXG4gICAgXFxcXCBmb3VuZCBvciBlbXB0eSBzdHJpbmcuIFJlc2VydmVkIG5hbWVzIHN0YXJ0IHdpdGggYSBcXFxcXFxuICAgIFxcXFwgc2luZ2xlIGNoYXIgYW5kIGNvbG9uLCBlLmcuICdjOmZvbycsIHdoaWNoIHdvdWxkIHJldHVybiAnYycgYXMgdHlwZS5cXFwiXFxuICAgIChsZXQgKChwZnggKHRha2UgMiBhY2NvdW50KSkpXFxuICAgICAgKGlmICg9IFxcXCI6XFxcIiAodGFrZSAtMSBwZngpKSAodGFrZSAxIHBmeCkgXFxcIlxcXCIpKSlcXG5cXG4gIChkZWZ1biBlbmZvcmNlLXJlc2VydmVkOmJvb2wgKGFjY291bnQ6c3RyaW5nIGd1YXJkOmd1YXJkKVxcbiAgICBAZG9jIFxcXCJFbmZvcmNlIHJlc2VydmVkIGFjY291bnQgbmFtZSBwcm90b2NvbHMuXFxcIlxcbiAgICAoaWYgKHZhbGlkYXRlLXByaW5jaXBhbCBndWFyZCBhY2NvdW50KVxcbiAgICAgIHRydWVcXG4gICAgICAobGV0ICgociAoY2hlY2stcmVzZXJ2ZWQgYWNjb3VudCkpKVxcbiAgICAgICAgKGlmICg9IHIgXFxcIlxcXCIpXFxuICAgICAgICAgIHRydWVcXG4gICAgICAgICAgKGlmICg9IHIgXFxcImtcXFwiKVxcbiAgICAgICAgICAgIChlbmZvcmNlIGZhbHNlIFxcXCJTaW5nbGUta2V5IGFjY291bnQgcHJvdG9jb2wgdmlvbGF0aW9uXFxcIilcXG4gICAgICAgICAgICAoZW5mb3JjZSBmYWxzZVxcbiAgICAgICAgICAgICAgKGZvcm1hdCBcXFwiUmVzZXJ2ZWQgcHJvdG9jb2wgZ3VhcmQgdmlvbGF0aW9uOiB7fVxcXCIgW3JdKSlcXG4gICAgICAgICAgICApKSkpKVxcblxcblxcbiAgKGRlZnNjaGVtYSBjcm9zc2NoYWluLXNjaGVtYVxcbiAgICBAZG9jIFxcXCJTY2hlbWEgZm9yIHlpZWxkZWQgdmFsdWUgaW4gY3Jvc3MtY2hhaW4gdHJhbnNmZXJzXFxcIlxcbiAgICByZWNlaXZlcjpzdHJpbmdcXG4gICAgcmVjZWl2ZXItZ3VhcmQ6Z3VhcmRcXG4gICAgYW1vdW50OmRlY2ltYWxcXG4gICAgc291cmNlLWNoYWluOnN0cmluZylcXG5cXG4gIChkZWZwYWN0IHRyYW5zZmVyLWNyb3NzY2hhaW46c3RyaW5nXFxuICAgICggc2VuZGVyOnN0cmluZ1xcbiAgICAgIHJlY2VpdmVyOnN0cmluZ1xcbiAgICAgIHJlY2VpdmVyLWd1YXJkOmd1YXJkXFxuICAgICAgdGFyZ2V0LWNoYWluOnN0cmluZ1xcbiAgICAgIGFtb3VudDpkZWNpbWFsIClcXG5cXG4gICAgQG1vZGVsIFsgKHByb3BlcnR5ICg-IGFtb3VudCAwLjApKVxcbiAgICAgICAgICAgICAocHJvcGVydHkgKHZhbGlkLWFjY291bnQgc2VuZGVyKSlcXG4gICAgICAgICAgICAgKHByb3BlcnR5ICh2YWxpZC1hY2NvdW50IHJlY2VpdmVyKSlcXG4gICAgICAgICAgIF1cXG5cXG4gICAgKHN0ZXBcXG4gICAgICAod2l0aC1jYXBhYmlsaXR5XFxuICAgICAgICAoVFJBTlNGRVJfWENIQUlOIHNlbmRlciByZWNlaXZlciBhbW91bnQgdGFyZ2V0LWNoYWluKVxcblxcbiAgICAgICAgKHZhbGlkYXRlLWFjY291bnQgc2VuZGVyKVxcbiAgICAgICAgKHZhbGlkYXRlLWFjY291bnQgcmVjZWl2ZXIpXFxuXFxuICAgICAgICAoZW5mb3JjZSAoIT0gXFxcIlxcXCIgdGFyZ2V0LWNoYWluKSBcXFwiZW1wdHkgdGFyZ2V0LWNoYWluXFxcIilcXG4gICAgICAgIChlbmZvcmNlICghPSAoYXQgJ2NoYWluLWlkIChjaGFpbi1kYXRhKSkgdGFyZ2V0LWNoYWluKVxcbiAgICAgICAgICBcXFwiY2Fubm90IHJ1biBjcm9zcy1jaGFpbiB0cmFuc2ZlcnMgdG8gdGhlIHNhbWUgY2hhaW5cXFwiKVxcblxcbiAgICAgICAgKGVuZm9yY2UgKD4gYW1vdW50IDAuMClcXG4gICAgICAgICAgXFxcInRyYW5zZmVyIHF1YW50aXR5IG11c3QgYmUgcG9zaXRpdmVcXFwiKVxcblxcbiAgICAgICAgKGVuZm9yY2UtdW5pdCBhbW91bnQpXFxuXFxuICAgICAgICAoZW5mb3JjZSAoY29udGFpbnMgdGFyZ2V0LWNoYWluIFZBTElEX0NIQUlOX0lEUylcXG4gICAgICAgICAgXFxcInRhcmdldCBjaGFpbiBpcyBub3QgYSB2YWxpZCBjaGFpbndlYiBjaGFpbiBpZFxcXCIpXFxuXFxuICAgICAgICA7OyBzdGVwIDEgLSBkZWJpdCBkZWxldGUtYWNjb3VudCBvbiBjdXJyZW50IGNoYWluXFxuICAgICAgICAoZGViaXQgc2VuZGVyIGFtb3VudClcXG4gICAgICAgIChlbWl0LWV2ZW50IChUUkFOU0ZFUiBzZW5kZXIgXFxcIlxcXCIgYW1vdW50KSlcXG5cXG4gICAgICAgIChsZXRcXG4gICAgICAgICAgKChjcm9zc2NoYWluLWRldGFpbHM6b2JqZWN0e2Nyb3NzY2hhaW4tc2NoZW1hfVxcbiAgICAgICAgICAgIHsgXFxcInJlY2VpdmVyXFxcIiA6IHJlY2VpdmVyXFxuICAgICAgICAgICAgLCBcXFwicmVjZWl2ZXItZ3VhcmRcXFwiIDogcmVjZWl2ZXItZ3VhcmRcXG4gICAgICAgICAgICAsIFxcXCJhbW91bnRcXFwiIDogYW1vdW50XFxuICAgICAgICAgICAgLCBcXFwic291cmNlLWNoYWluXFxcIiA6IChhdCAnY2hhaW4taWQgKGNoYWluLWRhdGEpKVxcbiAgICAgICAgICAgIH0pKVxcbiAgICAgICAgICAoeWllbGQgY3Jvc3NjaGFpbi1kZXRhaWxzIHRhcmdldC1jaGFpbilcXG4gICAgICAgICAgKSkpXFxuXFxuICAgIChzdGVwXFxuICAgICAgKHJlc3VtZVxcbiAgICAgICAgeyBcXFwicmVjZWl2ZXJcXFwiIDo9IHJlY2VpdmVyXFxuICAgICAgICAsIFxcXCJyZWNlaXZlci1ndWFyZFxcXCIgOj0gcmVjZWl2ZXItZ3VhcmRcXG4gICAgICAgICwgXFxcImFtb3VudFxcXCIgOj0gYW1vdW50XFxuICAgICAgICAsIFxcXCJzb3VyY2UtY2hhaW5cXFwiIDo9IHNvdXJjZS1jaGFpblxcbiAgICAgICAgfVxcblxcbiAgICAgICAgKGVtaXQtZXZlbnQgKFRSQU5TRkVSIFxcXCJcXFwiIHJlY2VpdmVyIGFtb3VudCkpXFxuICAgICAgICAoZW1pdC1ldmVudCAoVFJBTlNGRVJfWENIQUlOX1JFQ0QgXFxcIlxcXCIgcmVjZWl2ZXIgYW1vdW50IHNvdXJjZS1jaGFpbikpXFxuXFxuICAgICAgICA7OyBzdGVwIDIgLSBjcmVkaXQgY3JlYXRlIGFjY291bnQgb24gdGFyZ2V0IGNoYWluXFxuICAgICAgICAod2l0aC1jYXBhYmlsaXR5IChDUkVESVQgcmVjZWl2ZXIpXFxuICAgICAgICAgIChjcmVkaXQgcmVjZWl2ZXIgcmVjZWl2ZXItZ3VhcmQgYW1vdW50KSlcXG4gICAgICAgICkpXFxuICAgIClcXG5cXG5cXG4gIDsgLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS1cXG4gIDsgQ29pbiBhbGxvY2F0aW9uc1xcblxcbiAgKGRlZnNjaGVtYSBhbGxvY2F0aW9uLXNjaGVtYVxcbiAgICBAZG9jIFxcXCJHZW5lc2lzIGFsbG9jYXRpb24gcmVnaXN0cnlcXFwiXFxuICAgIDtAbW9kZWwgWyAoaW52YXJpYW50ICg-PSBiYWxhbmNlIDAuMCkpIF1cXG5cXG4gICAgYmFsYW5jZTpkZWNpbWFsXFxuICAgIGRhdGU6dGltZVxcbiAgICBndWFyZDpndWFyZFxcbiAgICByZWRlZW1lZDpib29sKVxcblxcbiAgKGRlZnRhYmxlIGFsbG9jYXRpb24tdGFibGU6e2FsbG9jYXRpb24tc2NoZW1hfSlcXG5cXG4gIChkZWZ1biBjcmVhdGUtYWxsb2NhdGlvbi1hY2NvdW50XFxuICAgICggYWNjb3VudDpzdHJpbmdcXG4gICAgICBkYXRlOnRpbWVcXG4gICAgICBrZXlzZXQtcmVmOnN0cmluZ1xcbiAgICAgIGFtb3VudDpkZWNpbWFsXFxuICAgIClcXG5cXG4gICAgQGRvYyBcXFwiQWRkIGFuIGVudHJ5IHRvIHRoZSBjb2luIGFsbG9jYXRpb24gdGFibGUuIFRoaXMgZnVuY3Rpb24gXFxcXFxcbiAgICAgICAgIFxcXFxhbHNvIGNyZWF0ZXMgYSBjb3JyZXNwb25kaW5nIGVtcHR5IGNvaW4gY29udHJhY3QgYWNjb3VudCBcXFxcXFxuICAgICAgICAgXFxcXG9mIHRoZSBzYW1lIG5hbWUgYW5kIGd1YXJkLiBSZXF1aXJlcyBHRU5FU0lTIGNhcGFiaWxpdHkuIFxcXCJcXG5cXG4gICAgQG1vZGVsIFsgKHByb3BlcnR5ICh2YWxpZC1hY2NvdW50IGFjY291bnQpKSBdXFxuXFxuICAgIChyZXF1aXJlLWNhcGFiaWxpdHkgKEdFTkVTSVMpKVxcblxcbiAgICAodmFsaWRhdGUtYWNjb3VudCBhY2NvdW50KVxcbiAgICAoZW5mb3JjZSAoPj0gYW1vdW50IDAuMClcXG4gICAgICBcXFwiYWxsb2NhdGlvbiBhbW91bnQgbXVzdCBiZSBub24tbmVnYXRpdmVcXFwiKVxcblxcbiAgICAoZW5mb3JjZS11bml0IGFtb3VudClcXG5cXG4gICAgKGxldFxcbiAgICAgICgoZ3VhcmQ6Z3VhcmQgKGtleXNldC1yZWYtZ3VhcmQga2V5c2V0LXJlZikpKVxcblxcbiAgICAgIChjcmVhdGUtYWNjb3VudCBhY2NvdW50IGd1YXJkKVxcblxcbiAgICAgIChpbnNlcnQgYWxsb2NhdGlvbi10YWJsZSBhY2NvdW50XFxuICAgICAgICB7IFxcXCJiYWxhbmNlXFxcIiA6IGFtb3VudFxcbiAgICAgICAgLCBcXFwiZGF0ZVxcXCIgOiBkYXRlXFxuICAgICAgICAsIFxcXCJndWFyZFxcXCIgOiBndWFyZFxcbiAgICAgICAgLCBcXFwicmVkZWVtZWRcXFwiIDogZmFsc2VcXG4gICAgICAgIH0pKSlcXG5cXG4gIChkZWZ1biByZWxlYXNlLWFsbG9jYXRpb25cXG4gICAgKCBhY2NvdW50OnN0cmluZyApXFxuXFxuICAgIEBkb2MgXFxcIlJlbGVhc2UgZnVuZHMgYXNzb2NpYXRlZCB3aXRoIGFsbG9jYXRpb24gQUNDT1VOVCBpbnRvIG1haW4gbGVkZ2VyLiAgIFxcXFxcXG4gICAgICAgICBcXFxcQUNDT1VOVCBtdXN0IGFscmVhZHkgZXhpc3QgaW4gbWFpbiBsZWRnZXIuIEFsbG9jYXRpb24gaXMgZGVhY3RpdmF0ZWQgXFxcXFxcbiAgICAgICAgIFxcXFxhZnRlciByZWxlYXNlLlxcXCJcXG4gICAgQG1vZGVsIFsgKHByb3BlcnR5ICh2YWxpZC1hY2NvdW50IGFjY291bnQpKSBdXFxuXFxuICAgICh2YWxpZGF0ZS1hY2NvdW50IGFjY291bnQpXFxuXFxuICAgICh3aXRoLXJlYWQgYWxsb2NhdGlvbi10YWJsZSBhY2NvdW50XFxuICAgICAgeyBcXFwiYmFsYW5jZVxcXCIgOj0gYmFsYW5jZVxcbiAgICAgICwgXFxcImRhdGVcXFwiIDo9IHJlbGVhc2UtdGltZVxcbiAgICAgICwgXFxcInJlZGVlbWVkXFxcIiA6PSByZWRlZW1lZFxcbiAgICAgICwgXFxcImd1YXJkXFxcIiA6PSBndWFyZFxcbiAgICAgIH1cXG5cXG4gICAgICAobGV0ICgoY3Vyci10aW1lOnRpbWUgKGF0ICdibG9jay10aW1lIChjaGFpbi1kYXRhKSkpKVxcblxcbiAgICAgICAgKGVuZm9yY2UgKG5vdCByZWRlZW1lZClcXG4gICAgICAgICAgXFxcImFsbG9jYXRpb24gZnVuZHMgaGF2ZSBhbHJlYWR5IGJlZW4gcmVkZWVtZWRcXFwiKVxcblxcbiAgICAgICAgKGVuZm9yY2VcXG4gICAgICAgICAgKD49IGN1cnItdGltZSByZWxlYXNlLXRpbWUpXFxuICAgICAgICAgIChmb3JtYXQgXFxcImZ1bmRzIGxvY2tlZCB1bnRpbCB7fS4gY3VycmVudCB0aW1lOiB7fVxcXCIgW3JlbGVhc2UtdGltZSBjdXJyLXRpbWVdKSlcXG5cXG4gICAgICAgICh3aXRoLWNhcGFiaWxpdHkgKFJFTEVBU0VfQUxMT0NBVElPTiBhY2NvdW50IGJhbGFuY2UpXFxuXFxuICAgICAgICAoZW5mb3JjZS1ndWFyZCBndWFyZClcXG5cXG4gICAgICAgICh3aXRoLWNhcGFiaWxpdHkgKENSRURJVCBhY2NvdW50KVxcbiAgICAgICAgICAoZW1pdC1ldmVudCAoVFJBTlNGRVIgXFxcIlxcXCIgYWNjb3VudCBiYWxhbmNlKSlcXG4gICAgICAgICAgKGNyZWRpdCBhY2NvdW50IGd1YXJkIGJhbGFuY2UpXFxuXFxuICAgICAgICAgICh1cGRhdGUgYWxsb2NhdGlvbi10YWJsZSBhY2NvdW50XFxuICAgICAgICAgICAgeyBcXFwicmVkZWVtZWRcXFwiIDogdHJ1ZVxcbiAgICAgICAgICAgICwgXFxcImJhbGFuY2VcXFwiIDogMC4wXFxuICAgICAgICAgICAgfSlcXG5cXG4gICAgICAgICAgXFxcIkFsbG9jYXRpb24gc3VjY2Vzc2Z1bGx5IHJlbGVhc2VkIHRvIG1haW4gbGVkZ2VyXFxcIikpXFxuICAgICkpKVxcblxcbilcXG5cXG4oY3JlYXRlLXRhYmxlIGNvaW4tdGFibGUpXFxuKGNyZWF0ZS10YWJsZSBhbGxvY2F0aW9uLXRhYmxlKVxcblwifX0sXCJzaWduZXJzXCI6W10sXCJtZXRhXCI6e1wiY3JlYXRpb25UaW1lXCI6MCxcInR0bFwiOjE3MjgwMCxcImdhc0xpbWl0XCI6MCxcImNoYWluSWRcIjpcIlwiLFwiZ2FzUHJpY2VcIjowLFwic2VuZGVyXCI6XCJcIn0sXCJub25jZVwiOlwiY29pbi1jb250cmFjdC12Ni1pbnN0YWxsXCJ9In0", unsafeFromText "eyJnYXMiOjAsInJlc3VsdCI6eyJzdGF0dXMiOiJzdWNjZXNzIiwiZGF0YSI6IlRhYmxlQ3JlYXRlZCJ9LCJyZXFLZXkiOiJHUklRdTRoQUtrMElEOUY4el8tMHlYeUFLSjMzTVB5VFlNWE9qbFBKbXBJIiwibG9ncyI6IkxKWlA1V2ZFN1VfNGZINWltQm56dE94ZndyWWN0enQtdmNoSkRvUXN2T1EiLCJtZXRhRGF0YSI6bnVsbCwiY29udGludWF0aW9uIjpudWxsLCJ0eElkIjozfQ") + , (unsafeFromText "eyJoYXNoIjoiU0IzVzVFTGl6azl4elNWWk9MX3dsem5VNjh5aUhPQzlwWUhreHBVXzBnbyIsInNpZ3MiOltdLCJjbWQiOiJ7XCJuZXR3b3JrSWRcIjpudWxsLFwicGF5bG9hZFwiOntcImV4ZWNcIjp7XCJkYXRhXCI6bnVsbCxcImNvZGVcIjpcIihpbnRlcmZhY2UgZ2FzLXBheWVyLXYxXFxuXFxuICAoZGVmY2FwIEdBU19QQVlFUjpib29sXFxuICAgICggdXNlcjpzdHJpbmdcXG4gICAgICBsaW1pdDppbnRlZ2VyXFxuICAgICAgcHJpY2U6ZGVjaW1hbFxcbiAgICApXFxuICAgIEBkb2NcXG4gICAgXFxcIiBQcm92aWRlIGEgY2FwYWJpbGl0eSBpbmRpY2F0aW5nIHRoYXQgZGVjbGFyaW5nIG1vZHVsZSBzdXBwb3J0cyBcXFxcXFxuICAgIFxcXFwgZ2FzIHBheW1lbnQgZm9yIFVTRVIgZm9yIGdhcyBMSU1JVCBhbmQgUFJJQ0UuIEZ1bmN0aW9uYWxpdHkgXFxcXFxcbiAgICBcXFxcIHNob3VsZCByZXF1aXJlIGNhcGFiaWxpdHkgKGNvaW4uRlVORF9UWCksIGFuZCBzaG91bGQgdmFsaWRhdGUgXFxcXFxcbiAgICBcXFxcIHRoZSBzcGVuZCBvZiAobGltaXQgKiBwcmljZSksIHBvc3NpYmx5IHVwZGF0aW5nIHNvbWUgZGF0YWJhc2UgXFxcXFxcbiAgICBcXFxcIGVudHJ5LiBcXFxcXFxuICAgIFxcXFwgU2hvdWxkIGNvbXBvc2UgY2FwYWJpbGl0eSByZXF1aXJlZCBmb3IgJ2NyZWF0ZS1nYXMtcGF5ZXItZ3VhcmQnLlxcXCJcXG4gICAgQG1vZGVsXFxuICAgIFsgKHByb3BlcnR5ICh1c2VyICE9IFxcXCJcXFwiKSlcXG4gICAgICAocHJvcGVydHkgKGxpbWl0ID4gMCkpXFxuICAgICAgKHByb3BlcnR5IChwcmljZSA-IDAuMCkpXFxuICAgIF1cXG4gIClcXG5cXG4gIChkZWZ1biBjcmVhdGUtZ2FzLXBheWVyLWd1YXJkOmd1YXJkICgpXFxuICAgIEBkb2NcXG4gICAgXFxcIiBQcm92aWRlIGEgZ3VhcmQgc3VpdGFibGUgZm9yIGNvbnRyb2xsaW5nIGEgY29pbiBhY2NvdW50IHRoYXQgY2FuIFxcXFxcXG4gICAgXFxcXCBwYXkgZ2FzIHZpYSBHQVNfUEFZRVIgbWVjaGFuaWNzLiBHZW5lcmFsbHkgdGhpcyBpcyBhY2NvbXBsaXNoZWQgXFxcXFxcbiAgICBcXFxcIGJ5IGhhdmluZyBHQVNfUEFZRVIgY29tcG9zZSBhbiB1bnBhcmFtZXRlcml6ZWQsIHVubWFuYWdlZCBjYXBhYmlsaXR5IFxcXFxcXG4gICAgXFxcXCB0aGF0IGlzIHJlcXVpcmVkIGluIHRoaXMgZ3VhcmQuIFRodXMsIGlmIGNvaW4gY29udHJhY3QgaXMgYWJsZSB0byBcXFxcXFxuICAgIFxcXFwgc3VjY2Vzc2Z1bGx5IGFjcXVpcmUgR0FTX1BBWUVSLCB0aGUgY29tcG9zZWQgJ2Fub255bW91cycgY2FwIHJlcXVpcmVkIFxcXFxcXG4gICAgXFxcXCBoZXJlIHdpbGwgYmUgaW4gc2NvcGUsIGFuZCBnYXMgYnV5IHdpbGwgc3VjY2VlZC5cXFwiXFxuICApXFxuXFxuKVxcblwifX0sXCJzaWduZXJzXCI6W10sXCJtZXRhXCI6e1wiY3JlYXRpb25UaW1lXCI6MCxcInR0bFwiOjE3MjgwMCxcImdhc0xpbWl0XCI6MCxcImNoYWluSWRcIjpcIlwiLFwiZ2FzUHJpY2VcIjowLFwic2VuZGVyXCI6XCJcIn0sXCJub25jZVwiOlwiZ2VuZXNpcy0wMVwifSJ9", unsafeFromText "eyJnYXMiOjAsInJlc3VsdCI6eyJzdGF0dXMiOiJzdWNjZXNzIiwiZGF0YSI6IkxvYWRlZCBpbnRlcmZhY2UgZ2FzLXBheWVyLXYxLCBoYXNoIGlJV0FQMW9lbl9rcFhqRmJuUU04N0FKUlpJZ3RzZlpjQXdZckV5MjFSV1EifSwicmVxS2V5IjoiU0IzVzVFTGl6azl4elNWWk9MX3dsem5VNjh5aUhPQzlwWUhreHBVXzBnbyIsImxvZ3MiOiJ3TXdXV3hkSFVuU1VOWXJ1RXlISEtTTzUyeGtkVXU0TXBmbE1FcHYyT05FIiwibWV0YURhdGEiOm51bGwsImNvbnRpbnVhdGlvbiI6bnVsbCwidHhJZCI6NH0") + , (unsafeFromText "eyJoYXNoIjoiQ1pteWxXZmllUk1CTXU1dzJFT21wRndLLXQ3YmNPVHM0bUsyYVQzM3VSNCIsInNpZ3MiOltdLCJjbWQiOiJ7XCJuZXR3b3JrSWRcIjpudWxsLFwicGF5bG9hZFwiOntcImV4ZWNcIjp7XCJkYXRhXCI6e1wibnMtYWRtaW4ta2V5c2V0XCI6W1wiMzY4ODIwZjgwYzMyNGJiYzdjMmIwNjEwNjg4YTdkYTQzZTM5ZjkxZDExODczMjY3MWNkOWM3NTAwZmY0M2NjYVwiXSxcIm5zLW9wZXJhdGUta2V5c2V0XCI6W1wiMzY4ODIwZjgwYzMyNGJiYzdjMmIwNjEwNjg4YTdkYTQzZTM5ZjkxZDExODczMjY3MWNkOWM3NTAwZmY0M2NjYVwiXSxcIm5zLWdlbmVzaXMta2V5c2V0XCI6e1wicHJlZFwiOlwiPVwiLFwia2V5c1wiOltdfX0sXCJjb2RlXCI6XCIoZGVmaW5lLWtleXNldCAnbnMtYWRtaW4ta2V5c2V0IChyZWFkLWtleXNldCAnbnMtYWRtaW4ta2V5c2V0KSlcXG4oZGVmaW5lLWtleXNldCAnbnMtb3BlcmF0ZS1rZXlzZXQgKHJlYWQta2V5c2V0ICducy1nZW5lc2lzLWtleXNldCkpXFxuXFxuKG1vZHVsZSBucyBHT1ZFUk5BTkNFXFxuICBcXFwiQWRtaW5pc3RlcnMgZGVmaW5pdGlvbiBvZiBuZXcgbmFtZXNwYWNlcyBpbiBDaGFpbndlYi5cXFwiXFxuXFxuICAoZGVmc2NoZW1hIHJlZy1lbnRyeVxcbiAgICBhZG1pbi1ndWFyZDpndWFyZFxcbiAgICBhY3RpdmU6Ym9vbClcXG5cXG4gIChkZWZ0YWJsZSByZWdpc3RyeTp7cmVnLWVudHJ5fSlcXG5cXG4gIChkZWZjYXAgR09WRVJOQU5DRSAoKVxcbiAgICAoZW5mb3JjZS1rZXlzZXQgJ25zLWFkbWluLWtleXNldCkpXFxuXFxuICAoZGVmY2FwIE9QRVJBVEUgKClcXG4gICAgKGVuZm9yY2Uta2V5c2V0ICducy1vcGVyYXRlLWtleXNldCkpXFxuXFxuICAoZGVmY29uc3QgR1VBUkRfU1VDQ0VTUyAoY3JlYXRlLXVzZXItZ3VhcmQgKHN1Y2Nlc3MpKSlcXG4gIChkZWZjb25zdCBHVUFSRF9GQUlMVVJFIChjcmVhdGUtdXNlci1ndWFyZCAoZmFpbHVyZSkpKVxcblxcbiAgKGRlZnVuIHN1Y2Nlc3MgKClcXG4gICAgdHJ1ZSlcXG4gIChkZWZ1biBmYWlsdXJlICgpXFxuICAgIChlbmZvcmNlIGZhbHNlIFxcXCJEaXNhYmxlZFxcXCIpKVxcblxcbiAgKGRlZnVuIHZhbGlkYXRlLW5hbWUgKG5hbWUpXFxuICAgIChlbmZvcmNlICghPSBcXFwiXFxcIiBuYW1lKSBcXFwiRW1wdHkgbmFtZSBub3QgYWxsb3dlZFxcXCIpXFxuICAgIChlbmZvcmNlICg8IChsZW5ndGggbmFtZSkgNjQpIFxcXCJOYW1lIG11c3QgYmUgbGVzcyB0aGFuIDY0IGNoYXJhY3RlcnMgbG9uZ1xcXCIpXFxuICAgIChlbmZvcmNlIChpcy1jaGFyc2V0IENIQVJTRVRfTEFUSU4xIG5hbWUpXFxuICAgICAgICAgICAgIFxcXCJOYW1lIG11c3QgYmUgaW4gbGF0aW4xIGNoYXJzZXRcXFwiKSlcXG5cXG4gIChkZWZ1biBjcmVhdGUtcHJpbmNpcGFsLW5hbWVzcGFjZTpzdHJpbmdcXG4gICAgICAoIGc6Z3VhcmRcXG4gICAgICAgIClcXG4gICAgXFxcIiBGb3JtYXQgcHJpbmNpcGFsIG5hbWVzcGFjZSBhcyBQYWN0IGhhc2ggKEJMQUtFMmIyNTYpIG9mIHByaW5jaXBhbCBcXFxcXFxuICAgIFxcXFwgaW4gaGV4IHRydW5jYXRlZCB0byAxNjAgYml0cyAoNDAgY2hhcmFjdGVycyksIHByZXBlbmRlZCB3aXRoICduXycuXFxcXFxcbiAgICBcXFxcIE9ubHkgdzogYW5kIGs6IGFjY291bnQgcHJvdG9jb2xzIGFyZSBzdXBwb3J0ZWQuIFxcXCJcXG5cXG4gICAgKGxldFxcbiAgICAgICgodHkgKHR5cGVvZi1wcmluY2lwYWwgKGNyZWF0ZS1wcmluY2lwYWwgZykpKSlcXG5cXG4gICAgICA7OyBvbmx5IHc6IGFuZCBrOiBjdXJyZW50bHkgc3VwcG9ydGVkXFxuICAgICAgKGlmIChvciAoPSB0eSBcXFwiazpcXFwiKSAoPSB0eSBcXFwidzpcXFwiKSlcXG4gICAgICAgICgrIFxcXCJuX1xcXCIgKHRha2UgNDAgKGludC10by1zdHIgMTYgKHN0ci10by1pbnQgNjQgKGhhc2ggZykpKSkpXFxuICAgICAgICAoZW5mb3JjZSBmYWxzZVxcbiAgICAgICAgICAoZm9ybWF0IFxcXCJVbnN1cHBvcnRlZCBndWFyZCBwcm90b2NvbDoge31cXFwiIFt0eV0pKVxcbiAgICAgICAgKSlcXG4gIClcXG5cXG4gIChkZWZ1biB2YWxpZGF0ZTpib29sXFxuICAgICAgKCBucy1uYW1lOnN0cmluZ1xcbiAgICAgICAgbnMtYWRtaW46Z3VhcmRcXG4gICAgICAgIClcXG4gICAgXFxcIiBNYW5hZ2VzIG5hbWVzcGFjZSBpbnN0YWxsIGZvciBDaGFpbndlYi4gXFxcXFxcbiAgICBcXFxcIEFsbG93cyBwcmluY2lwYWwgbmFtZXNwYWNlcy4gXFxcXFxcbiAgICBcXFxcIE5vbi1wcmluY2lwYWwgbmFtZXNwYWNlcyByZXF1aXJlIGFjdGl2ZSByb3cgaW4gcmVnaXN0cnkgXFxcXFxcbiAgICBcXFxcIGZvciBOUy1OQU1FIHdpdGggZ3VhcmQgbWF0Y2hpbmcgTlMtQURNSU4uXFxcIlxcblxcbiAgICAoaWYgKD0gKGNyZWF0ZS1wcmluY2lwYWwtbmFtZXNwYWNlIG5zLWFkbWluKSBucy1uYW1lKVxcblxcbiAgICAgIHRydWUgOzsgYWxsb3cgcHJpbmNpcGFsIG5hbWVzcGFjZXNcXG5cXG4gICAgICAod2l0aC1kZWZhdWx0LXJlYWQgcmVnaXN0cnkgbnMtbmFtZSAgICAgICA7OyBvdGhlcndpc2UgZW5mb3JjZSByZWdpc3RyeVxcbiAgICAgICAgeyAnYWRtaW4tZ3VhcmQgOiBucy1hZG1pblxcbiAgICAgICAgLCAnYWN0aXZlIDogZmFsc2UgfVxcbiAgICAgICAgeyAnYWRtaW4tZ3VhcmQgOj0gYWdcXG4gICAgICAgICwgJ2FjdGl2ZSA6PSBpcy1hY3RpdmUgfVxcblxcbiAgICAgICAgKGVuZm9yY2UgaXMtYWN0aXZlIFxcXCJJbmFjdGl2ZSBvciB1bnJlZ2lzdGVyZWQgbmFtZXNwYWNlXFxcIilcXG4gICAgICAgIChlbmZvcmNlICg9IG5zLWFkbWluIGFnKSBcXFwiQWRtaW4gZ3VhcmQgbXVzdCBtYXRjaCBndWFyZCBpbiByZWdpc3RyeVxcXCIpXFxuXFxuICAgICAgICB0cnVlKVxcbiAgICAgICkpXFxuXFxuICAoZGVmdW4gd3JpdGUtcmVnaXN0cnk6c3RyaW5nXFxuICAgICAgKCBucy1uYW1lOnN0cmluZ1xcbiAgICAgICAgZ3VhcmQ6Z3VhcmRcXG4gICAgICAgIGFjdGl2ZTpib29sXFxuICAgICAgICApXFxuICAgIFxcXCIgV3JpdGUgZW50cnkgd2l0aCBHVUFSRCBhbmQgQUNUSVZFIGludG8gcmVnaXN0cnkgZm9yIE5BTUUuIFxcXFxcXG4gICAgXFxcXCBHdWFyZGVkIGJ5IG9wZXJhdGUga2V5c2V0LiBcXFwiXFxuXFxuICAgICh3aXRoLWNhcGFiaWxpdHkgKE9QRVJBVEUpXFxuXFxuICAgICAgKHZhbGlkYXRlLW5hbWUgbnMtbmFtZSlcXG5cXG4gICAgICAod3JpdGUgcmVnaXN0cnkgbnMtbmFtZVxcbiAgICAgICAgeyAnYWRtaW4tZ3VhcmQ6IGd1YXJkXFxuICAgICAgICAsICdhY3RpdmU6IGFjdGl2ZSB9KVxcblxcbiAgICAgIFxcXCJSZWdpc3RlciBlbnRyeSB3cml0dGVuXFxcIikpXFxuXFxuICAoZGVmdW4gcXVlcnk6b2JqZWN0e3JlZy1lbnRyeX1cXG4gICAgICAoIG5zLW5hbWU6c3RyaW5nIClcXG4gICAgKHJlYWQgcmVnaXN0cnkgbnMtbmFtZSkpXFxuXFxuKVxcblxcbihjcmVhdGUtdGFibGUgcmVnaXN0cnkpXFxuXFxuKHdyaXRlLXJlZ2lzdHJ5IFxcXCJrYWRlbmFcXFwiXFxuICAoa2V5c2V0LXJlZi1ndWFyZCAnbnMtb3BlcmF0ZS1rZXlzZXQpIHRydWUpXFxuKHdyaXRlLXJlZ2lzdHJ5IFxcXCJ1c2VyXFxcIiBHVUFSRF9GQUlMVVJFIHRydWUpXFxuKHdyaXRlLXJlZ2lzdHJ5IFxcXCJmcmVlXFxcIiBHVUFSRF9GQUlMVVJFIHRydWUpXFxuXFxuKGRlZmluZS1uYW1lc3BhY2UgXFxcImthZGVuYVxcXCJcXG4gIChrZXlzZXQtcmVmLWd1YXJkICducy1vcGVyYXRlLWtleXNldClcXG4gIChrZXlzZXQtcmVmLWd1YXJkICducy1vcGVyYXRlLWtleXNldCkpXFxuXFxuKGRlZmluZS1uYW1lc3BhY2UgXFxcInVzZXJcXFwiIEdVQVJEX1NVQ0NFU1MgR1VBUkRfRkFJTFVSRSlcXG4oZGVmaW5lLW5hbWVzcGFjZSBcXFwiZnJlZVxcXCIgR1VBUkRfU1VDQ0VTUyBHVUFSRF9GQUlMVVJFKVxcbjs7cm90YXRlIHRvIHJlYWwgb3BlcmF0ZSBrZXlzZXRcXG4oZGVmaW5lLWtleXNldCAnbnMtb3BlcmF0ZS1rZXlzZXQgKHJlYWQta2V5c2V0ICducy1vcGVyYXRlLWtleXNldCkpXFxuXCJ9fSxcInNpZ25lcnNcIjpbXSxcIm1ldGFcIjp7XCJjcmVhdGlvblRpbWVcIjowLFwidHRsXCI6MTcyODAwLFwiZ2FzTGltaXRcIjowLFwiY2hhaW5JZFwiOlwiXCIsXCJnYXNQcmljZVwiOjAsXCJzZW5kZXJcIjpcIlwifSxcIm5vbmNlXCI6XCJsb2FkLW5zLWRldm5ldC1zZW5kZXIwMFwifSJ9", unsafeFromText "eyJnYXMiOjAsInJlc3VsdCI6eyJzdGF0dXMiOiJzdWNjZXNzIiwiZGF0YSI6IktleXNldCB3cml0ZSBzdWNjZXNzIn0sInJlcUtleSI6IkNabXlsV2ZpZVJNQk11NXcyRU9tcEZ3Sy10N2JjT1RzNG1LMmFUMzN1UjQiLCJsb2dzIjoidDdzQzg1Y1hlWFdSdG90M1lEb2pSejZibWtncEN6enJQQ0Z6QThzTkg3OCIsIm1ldGFEYXRhIjpudWxsLCJjb250aW51YXRpb24iOm51bGwsInR4SWQiOjV9") + , (unsafeFromText "eyJoYXNoIjoiWE5BNmxPSjFXLTdYWXY1WWI0QXFsNzRveFlJN09KcWpPUVQ1b1k0OHEtZyIsInNpZ3MiOltdLCJjbWQiOiJ7XCJuZXR3b3JrSWRcIjpudWxsLFwicGF5bG9hZFwiOntcImV4ZWNcIjp7XCJkYXRhXCI6e1wiYWxsb2NhdGlvbi10ZXN0MDFcIjpbXCI3MDExYzM3OTE0MGZmODk5ZjdlNjEzYWMwYTk3ODRhN2MwYTUxNWQzMGZlMGFiMmIwYzA3ZTVhYTE3NjM1ZTNlXCJdLFwiYWxsb2NhdGlvbjAyXCI6W1wiZTllNGU3MWJkMDYzZGNmN2UwNmJkNWIxYTE2Njg4ODk3ZDE1Y2E4YmQyZTUwOWM0NTNjNjE2MjE5YzE4NmNjNVwiXSxcImFsbG9jYXRpb24wMFwiOltcImQ4MmQwZGNkZTk4MjU1MDVkODZhZmI2ZGNjMTA0MTFkNmI2N2E0MjlhNzllMjFiZGE0YmIxMTliZjI4YWI4NzFcIl0sXCJhbGxvY2F0aW9uLXRlc3QwMlwiOltcIjA2NTQ0ZTIyYmZlZjIzMGQ2ZDIyZjk0ODZhYzZjYjc2YmYyNThlYmZiZjAxMzdlZTU4ZjY1NzQzZTFhNWI4YzRcIl0sXCJhbGxvY2F0aW9uMDFcIjpbXCJiNGM4YTNlYTkxZDMxNDZiMDU2MDk5NDc0MGYwZTNlZWQ5MWM1OWQyZWVjYTFkYzk5ZjBjMjg3Mjg0NWMyOTRkXCJdfSxcImNvZGVcIjpcIihkZWZpbmUta2V5c2V0IFxcXCJhbGxvY2F0aW9uMDBcXFwiIChyZWFkLWtleXNldCBcXFwiYWxsb2NhdGlvbjAwXFxcIikpXFxuKGRlZmluZS1rZXlzZXQgXFxcImFsbG9jYXRpb24wMVxcXCIgKHJlYWQta2V5c2V0IFxcXCJhbGxvY2F0aW9uMDFcXFwiKSlcXG4oZGVmaW5lLWtleXNldCBcXFwiYWxsb2NhdGlvbjAyXFxcIiAocmVhZC1rZXlzZXQgXFxcImFsbG9jYXRpb24wMlxcXCIpKVxcbihkZWZpbmUta2V5c2V0IFxcXCJhbGxvY2F0aW9uLXRlc3QwMVxcXCIgKHJlYWQta2V5c2V0IFxcXCJhbGxvY2F0aW9uLXRlc3QwMVxcXCIpKVxcbihkZWZpbmUta2V5c2V0IFxcXCJhbGxvY2F0aW9uLXRlc3QwMlxcXCIgKHJlYWQta2V5c2V0IFxcXCJhbGxvY2F0aW9uLXRlc3QwMlxcXCIpKVwifX0sXCJzaWduZXJzXCI6W10sXCJtZXRhXCI6e1wiY3JlYXRpb25UaW1lXCI6MCxcInR0bFwiOjE3MjgwMCxcImdhc0xpbWl0XCI6MCxcImNoYWluSWRcIjpcIlwiLFwiZ2FzUHJpY2VcIjowLFwic2VuZGVyXCI6XCJcIn0sXCJub25jZVwiOlwiZGV2bmV0LWtleXNldHNcIn0ifQ", unsafeFromText "eyJnYXMiOjAsInJlc3VsdCI6eyJzdGF0dXMiOiJzdWNjZXNzIiwiZGF0YSI6IktleXNldCB3cml0ZSBzdWNjZXNzIn0sInJlcUtleSI6IlhOQTZsT0oxVy03WFl2NVliNEFxbDc0b3hZSTdPSnFqT1FUNW9ZNDhxLWciLCJsb2dzIjoiYXJRSWpQVGRrcXhoQTNjWl9WaVE3OXM3Uk5XRTlGV2Rha0xWdXl4Nlc0YyIsIm1ldGFEYXRhIjpudWxsLCJjb250aW51YXRpb24iOm51bGwsInR4SWQiOjZ9") + , (unsafeFromText "eyJoYXNoIjoiNWtxZ0tzWWtwbjZCcS1KUnhNYnA1VG9jUWhRWGRJVVNiM1NGQm1Ba3VWcyIsInNpZ3MiOltdLCJjbWQiOiJ7XCJuZXR3b3JrSWRcIjpudWxsLFwicGF5bG9hZFwiOntcImV4ZWNcIjp7XCJkYXRhXCI6bnVsbCxcImNvZGVcIjpcIihjb2luLmNyZWF0ZS1hbGxvY2F0aW9uLWFjY291bnQgXFxcImFsbG9jYXRpb24wMFxcXCIgKHRpbWUgXFxcIjE5MDAtMTAtMTVUMTg6MDA6MDBaXFxcIikgXFxcImFsbG9jYXRpb24wMFxcXCIgMTAwMDAwMC4wKVxcbihjb2luLmNyZWF0ZS1hbGxvY2F0aW9uLWFjY291bnQgXFxcImFsbG9jYXRpb24wMVxcXCIgKHRpbWUgXFxcIjIxMDAtMTAtMzFUMTg6MDA6MDBaXFxcIikgXFxcImFsbG9jYXRpb24wMVxcXCIgMTAwMDAwMC4wKVxcbihjb2luLmNyZWF0ZS1hbGxvY2F0aW9uLWFjY291bnQgXFxcImFsbG9jYXRpb24wMlxcXCIgKHRpbWUgXFxcIjE5MDAtMTAtMzFUMTg6MDA6MDBaXFxcIikgXFxcImFsbG9jYXRpb24wMlxcXCIgMTAwMDAwMC4wKVxcbihjb2luLmNyZWF0ZS1hbGxvY2F0aW9uLWFjY291bnQgXFxcImFsbG9jYXRpb24tdGVzdDAxXFxcIiAodGltZSBcXFwiMTkwMC0xMC0zMVQxODowMDowMFpcXFwiKSBcXFwiYWxsb2NhdGlvbi10ZXN0MDFcXFwiIDEwMDAwMDAuMClcXG4oY29pbi5jcmVhdGUtYWxsb2NhdGlvbi1hY2NvdW50IFxcXCJhbGxvY2F0aW9uLXRlc3QwMlxcXCIgKHRpbWUgXFxcIjE5MDAtMTAtMzFUMTg6MDA6MDBaXFxcIikgXFxcImFsbG9jYXRpb24tdGVzdDAyXFxcIiAyMDAwMDAwLjApXCJ9fSxcInNpZ25lcnNcIjpbXSxcIm1ldGFcIjp7XCJjcmVhdGlvblRpbWVcIjowLFwidHRsXCI6MTcyODAwLFwiZ2FzTGltaXRcIjowLFwiY2hhaW5JZFwiOlwiXCIsXCJnYXNQcmljZVwiOjAsXCJzZW5kZXJcIjpcIlwifSxcIm5vbmNlXCI6XCJkZXZuZXQtYWxsb2NhdGlvbnNcIn0ifQ", unsafeFromText "eyJnYXMiOjAsInJlc3VsdCI6eyJzdGF0dXMiOiJzdWNjZXNzIiwiZGF0YSI6IldyaXRlIHN1Y2NlZWRlZCJ9LCJyZXFLZXkiOiI1a3FnS3NZa3BuNkJxLUpSeE1icDVUb2NRaFFYZElVU2IzU0ZCbUFrdVZzIiwibG9ncyI6IkhpX3ZfVEhFT2s2aEJFRU0yWmV2Vzh3eVJsQWpUZzNjVUQydXBlVkx0b1UiLCJtZXRhRGF0YSI6bnVsbCwiY29udGludWF0aW9uIjpudWxsLCJ0eElkIjo3fQ") + , (unsafeFromText "eyJoYXNoIjoiejJtR1ZxektqeHp5bUdHLWNpWjBCSEpGM1EzeGtvOFYyNEE4ejBxcEl4ayIsInNpZ3MiOltdLCJjbWQiOiJ7XCJuZXR3b3JrSWRcIjpudWxsLFwicGF5bG9hZFwiOntcImV4ZWNcIjp7XCJkYXRhXCI6e1wic2VuZGVyMDdcIjpbXCI0YzMxZGM5ZWU3ZjI0MTc3Zjc4YjZmNTE4MDEyYTIwODMyNmUyYWYxZjM3YmIwYTI0MDViNTA1NmQwY2FkNjI4XCJdLFwic2VuZGVyMDFcIjpbXCI2YmUyZjQ4NWE3YWY3NWZlZGI0YjdmMTUzYTkwM2Y3ZTYwMDBjYTRhYTUwMTE3OWM5MWEyNDUwYjc3N2JkMmE3XCJdLFwic2VuZGVyMDZcIjpbXCI1ZmZjMWY3ZmVmN2E0NDczODYyNTc2MmY3NWE0MjI5NDU0OTUxZTAzZjJhZmM2ZjgxMzA5YzBjMWJkZjllZTZmXCJdLFwic2VuZGVyMDBcIjpbXCIzNjg4MjBmODBjMzI0YmJjN2MyYjA2MTA2ODhhN2RhNDNlMzlmOTFkMTE4NzMyNjcxY2Q5Yzc1MDBmZjQzY2NhXCJdLFwiZTdmN1wiOltcImU3Zjc2MzRlOTI1NTQxZjM2OGI4MjdhZDVjNzI0MjE5MDUxMDBmNjIwNTI4NWE3OGMxOWQ3YjRhMzg3MTE4MDVcIl0sXCJzZW5kZXIwNVwiOltcImYwOWQ4ZjYzOTRhZWE0MjVmZTY3ODNkODhjZDgxMzYzZDgwMTdmMTZhZmQzNzExYzU3NWJlMGY1Y2Q1YzliYjlcIl0sXCJzZW5kZXIwNFwiOltcIjJkNzBhYTRmNjk3YzNhM2I4ZGQ2ZDk3NzQ1YWMwNzRlZGNmZDBlYjY1YzM3Nzc0Y2RlMjUxMzU0ODNiZWE3MWVcIl0sXCJtdWx0aS0wMi0wMy0wNC1hbnlcIjp7XCJwcmVkXCI6XCJrZXlzLWFueVwiLFwia2V5c1wiOltcIjJkNzBhYTRmNjk3YzNhM2I4ZGQ2ZDk3NzQ1YWMwNzRlZGNmZDBlYjY1YzM3Nzc0Y2RlMjUxMzU0ODNiZWE3MWVcIixcIjNhOWRkNTMyZDczZGFjZTE5NWRiYjY0ZDFkYmE2NTcyZmI3ODNkMGZkZDMyNDY4NWUzMmZiZGEyZjg5Zjk5YTZcIixcIjQzZjJhZGIxZGUxOTIwMDBjYjM3NzdiYWNjN2Y5ODNiNjYxNGZkOWMxNzE1Y2Q0NGNkNDg0YjZkM2EwZDM0YzhcIl19LFwic2VuZGVyMDlcIjpbXCJjNTlkOTg0MGIwYjY2MDkwODM2NTQ2YjdlYjRhNzM2MDYyNTc1MjdlYzhjMmI0ODIzMDBmZDIyOTI2NGIwN2U2XCJdLFwic2VuZGVyMDNcIjpbXCI0M2YyYWRiMWRlMTkyMDAwY2IzNzc3YmFjYzdmOTgzYjY2MTRmZDljMTcxNWNkNDRjZDQ4NGI2ZDNhMGQzNGM4XCJdLFwibXVsdGktMDAtMDFcIjpbXCIzNjg4MjBmODBjMzI0YmJjN2MyYjA2MTA2ODhhN2RhNDNlMzlmOTFkMTE4NzMyNjcxY2Q5Yzc1MDBmZjQzY2NhXCIsXCI2YmUyZjQ4NWE3YWY3NWZlZGI0YjdmMTUzYTkwM2Y3ZTYwMDBjYTRhYTUwMTE3OWM5MWEyNDUwYjc3N2JkMmE3XCJdLFwic2VuZGVyMDhcIjpbXCI2M2IyZWJhNGVkNzBkNDYxMmQzZTdiYzkwZGIyZmJmNGM3NmY3YjA3NDM2M2U4NmQ3M2YwYmM2MTdmOGU4YjgxXCJdLFwic2VuZGVyMDJcIjpbXCIzYTlkZDUzMmQ3M2RhY2UxOTVkYmI2NGQxZGJhNjU3MmZiNzgzZDBmZGQzMjQ2ODVlMzJmYmRhMmY4OWY5OWE2XCJdfSxcImNvZGVcIjpcIihjb2luLmNvaW5iYXNlIFxcXCJzZW5kZXIwMFxcXCIgKHJlYWQta2V5c2V0IFxcXCJzZW5kZXIwMFxcXCIpIDEwMDAwMDAwMC4wKVxcbihjb2luLmNvaW5iYXNlIFxcXCJzZW5kZXIwMVxcXCIgKHJlYWQta2V5c2V0IFxcXCJzZW5kZXIwMVxcXCIpIDExMDAwMDAwMC4wKVxcbihjb2luLmNvaW5iYXNlIFxcXCJzZW5kZXIwMlxcXCIgKHJlYWQta2V5c2V0IFxcXCJzZW5kZXIwMlxcXCIpIDEyMDAwMDAwMC4wKVxcbihjb2luLmNvaW5iYXNlIFxcXCJzZW5kZXIwM1xcXCIgKHJlYWQta2V5c2V0IFxcXCJzZW5kZXIwM1xcXCIpIDEzMDAwMDAwMC4wKVxcbihjb2luLmNvaW5iYXNlIFxcXCJzZW5kZXIwNFxcXCIgKHJlYWQta2V5c2V0IFxcXCJzZW5kZXIwNFxcXCIpIDE0MDAwMDAwMC4wKVxcbihjb2luLmNvaW5iYXNlIFxcXCJzZW5kZXIwNVxcXCIgKHJlYWQta2V5c2V0IFxcXCJzZW5kZXIwNVxcXCIpIDE1MDAwMDAwMC4wKVxcbihjb2luLmNvaW5iYXNlIFxcXCJzZW5kZXIwNlxcXCIgKHJlYWQta2V5c2V0IFxcXCJzZW5kZXIwNlxcXCIpIDE2MDAwMDAwMC4wKVxcbihjb2luLmNvaW5iYXNlIFxcXCJzZW5kZXIwN1xcXCIgKHJlYWQta2V5c2V0IFxcXCJzZW5kZXIwN1xcXCIpIDE3MDAwMDAwMC4wKVxcbihjb2luLmNvaW5iYXNlIFxcXCJzZW5kZXIwOFxcXCIgKHJlYWQta2V5c2V0IFxcXCJzZW5kZXIwOFxcXCIpIDE4MDAwMDAwMC4wKVxcbihjb2luLmNvaW5iYXNlIFxcXCJzZW5kZXIwOVxcXCIgKHJlYWQta2V5c2V0IFxcXCJzZW5kZXIwOVxcXCIpIDE5MDAwMDAwMC4wKVxcbihjb2luLmNvaW5iYXNlIFxcXCJtdWx0aS0wMC0wMVxcXCIgKHJlYWQta2V5c2V0IFxcXCJtdWx0aS0wMC0wMVxcXCIpIDEwMTAwMDAwMC4wKVxcbihjb2luLmNvaW5iYXNlIFxcXCJtdWx0aS0wMi0wMy0wNC1hbnlcXFwiIChyZWFkLWtleXNldCBcXFwibXVsdGktMDItMDMtMDQtYW55XFxcIikgMTIzNDAwMDAwLjApXFxuXFxuKGNvaW4uY29pbmJhc2UgXFxcImU3Zjc2MzRlOTI1NTQxZjM2OGI4MjdhZDVjNzI0MjE5MDUxMDBmNjIwNTI4NWE3OGMxOWQ3YjRhMzg3MTE4MDVcXFwiIChyZWFkLWtleXNldCBcXFwiZTdmN1xcXCIpIDE1MC4wKVxcblxcbjsgZW5vdWdoIHRvIGNvdmVyIHRoZSBnYXMgY29zdHMgZm9yIGFsbG9jYXRpb24gcmVsZWFzZVxcbihjb2luLmNvaW5iYXNlIFxcXCJhbGxvY2F0aW9uMDBcXFwiIChrZXlzZXQtcmVmLWd1YXJkIFxcXCJhbGxvY2F0aW9uMDBcXFwiKSAxMDAwMDAuMClcXG4oY29pbi5jb2luYmFzZSBcXFwiYWxsb2NhdGlvbjAxXFxcIiAoa2V5c2V0LXJlZi1ndWFyZCBcXFwiYWxsb2NhdGlvbjAxXFxcIikgMTAwMDAwLjApXFxuKGNvaW4uY29pbmJhc2UgXFxcImFsbG9jYXRpb24wMlxcXCIgKGtleXNldC1yZWYtZ3VhcmQgXFxcImFsbG9jYXRpb24wMlxcXCIpIDEwMDAwMC4wKVwifX0sXCJzaWduZXJzXCI6W10sXCJtZXRhXCI6e1wiY3JlYXRpb25UaW1lXCI6MCxcInR0bFwiOjE3MjgwMCxcImdhc0xpbWl0XCI6MCxcImNoYWluSWRcIjpcIlwiLFwiZ2FzUHJpY2VcIjowLFwic2VuZGVyXCI6XCJcIn0sXCJub25jZVwiOlwiZGV2bmV0LWdyYW50czBcIn0ifQ", unsafeFromText "eyJnYXMiOjAsInJlc3VsdCI6eyJzdGF0dXMiOiJzdWNjZXNzIiwiZGF0YSI6IldyaXRlIHN1Y2NlZWRlZCJ9LCJyZXFLZXkiOiJ6Mm1HVnF6S2p4enltR0ctY2laMEJISkYzUTN4a284VjI0QTh6MHFwSXhrIiwibG9ncyI6ImFCUXM2aDJGVUN1a00tM0pjQmdLZGFvRU1Ta3p2OTJkM0VmT2t5MXNrMmciLCJldmVudHMiOlt7InBhcmFtcyI6WyIiLCJzZW5kZXIwMCIsMTAwMDAwMDAwXSwibmFtZSI6IlRSQU5TRkVSIiwibW9kdWxlIjp7Im5hbWVzcGFjZSI6bnVsbCwibmFtZSI6ImNvaW4ifSwibW9kdWxlSGFzaCI6IjNpSUJRZEpuc3Q0NFoyWmdYb0hQa0FhdXliSjBoODVsX2VuX1NHSE5pYkUifSx7InBhcmFtcyI6WyIiLCJzZW5kZXIwMSIsMTEwMDAwMDAwXSwibmFtZSI6IlRSQU5TRkVSIiwibW9kdWxlIjp7Im5hbWVzcGFjZSI6bnVsbCwibmFtZSI6ImNvaW4ifSwibW9kdWxlSGFzaCI6IjNpSUJRZEpuc3Q0NFoyWmdYb0hQa0FhdXliSjBoODVsX2VuX1NHSE5pYkUifSx7InBhcmFtcyI6WyIiLCJzZW5kZXIwMiIsMTIwMDAwMDAwXSwibmFtZSI6IlRSQU5TRkVSIiwibW9kdWxlIjp7Im5hbWVzcGFjZSI6bnVsbCwibmFtZSI6ImNvaW4ifSwibW9kdWxlSGFzaCI6IjNpSUJRZEpuc3Q0NFoyWmdYb0hQa0FhdXliSjBoODVsX2VuX1NHSE5pYkUifSx7InBhcmFtcyI6WyIiLCJzZW5kZXIwMyIsMTMwMDAwMDAwXSwibmFtZSI6IlRSQU5TRkVSIiwibW9kdWxlIjp7Im5hbWVzcGFjZSI6bnVsbCwibmFtZSI6ImNvaW4ifSwibW9kdWxlSGFzaCI6IjNpSUJRZEpuc3Q0NFoyWmdYb0hQa0FhdXliSjBoODVsX2VuX1NHSE5pYkUifSx7InBhcmFtcyI6WyIiLCJzZW5kZXIwNCIsMTQwMDAwMDAwXSwibmFtZSI6IlRSQU5TRkVSIiwibW9kdWxlIjp7Im5hbWVzcGFjZSI6bnVsbCwibmFtZSI6ImNvaW4ifSwibW9kdWxlSGFzaCI6IjNpSUJRZEpuc3Q0NFoyWmdYb0hQa0FhdXliSjBoODVsX2VuX1NHSE5pYkUifSx7InBhcmFtcyI6WyIiLCJzZW5kZXIwNSIsMTUwMDAwMDAwXSwibmFtZSI6IlRSQU5TRkVSIiwibW9kdWxlIjp7Im5hbWVzcGFjZSI6bnVsbCwibmFtZSI6ImNvaW4ifSwibW9kdWxlSGFzaCI6IjNpSUJRZEpuc3Q0NFoyWmdYb0hQa0FhdXliSjBoODVsX2VuX1NHSE5pYkUifSx7InBhcmFtcyI6WyIiLCJzZW5kZXIwNiIsMTYwMDAwMDAwXSwibmFtZSI6IlRSQU5TRkVSIiwibW9kdWxlIjp7Im5hbWVzcGFjZSI6bnVsbCwibmFtZSI6ImNvaW4ifSwibW9kdWxlSGFzaCI6IjNpSUJRZEpuc3Q0NFoyWmdYb0hQa0FhdXliSjBoODVsX2VuX1NHSE5pYkUifSx7InBhcmFtcyI6WyIiLCJzZW5kZXIwNyIsMTcwMDAwMDAwXSwibmFtZSI6IlRSQU5TRkVSIiwibW9kdWxlIjp7Im5hbWVzcGFjZSI6bnVsbCwibmFtZSI6ImNvaW4ifSwibW9kdWxlSGFzaCI6IjNpSUJRZEpuc3Q0NFoyWmdYb0hQa0FhdXliSjBoODVsX2VuX1NHSE5pYkUifSx7InBhcmFtcyI6WyIiLCJzZW5kZXIwOCIsMTgwMDAwMDAwXSwibmFtZSI6IlRSQU5TRkVSIiwibW9kdWxlIjp7Im5hbWVzcGFjZSI6bnVsbCwibmFtZSI6ImNvaW4ifSwibW9kdWxlSGFzaCI6IjNpSUJRZEpuc3Q0NFoyWmdYb0hQa0FhdXliSjBoODVsX2VuX1NHSE5pYkUifSx7InBhcmFtcyI6WyIiLCJzZW5kZXIwOSIsMTkwMDAwMDAwXSwibmFtZSI6IlRSQU5TRkVSIiwibW9kdWxlIjp7Im5hbWVzcGFjZSI6bnVsbCwibmFtZSI6ImNvaW4ifSwibW9kdWxlSGFzaCI6IjNpSUJRZEpuc3Q0NFoyWmdYb0hQa0FhdXliSjBoODVsX2VuX1NHSE5pYkUifSx7InBhcmFtcyI6WyIiLCJtdWx0aS0wMC0wMSIsMTAxMDAwMDAwXSwibmFtZSI6IlRSQU5TRkVSIiwibW9kdWxlIjp7Im5hbWVzcGFjZSI6bnVsbCwibmFtZSI6ImNvaW4ifSwibW9kdWxlSGFzaCI6IjNpSUJRZEpuc3Q0NFoyWmdYb0hQa0FhdXliSjBoODVsX2VuX1NHSE5pYkUifSx7InBhcmFtcyI6WyIiLCJtdWx0aS0wMi0wMy0wNC1hbnkiLDEyMzQwMDAwMF0sIm5hbWUiOiJUUkFOU0ZFUiIsIm1vZHVsZSI6eyJuYW1lc3BhY2UiOm51bGwsIm5hbWUiOiJjb2luIn0sIm1vZHVsZUhhc2giOiIzaUlCUWRKbnN0NDRaMlpnWG9IUGtBYXV5YkowaDg1bF9lbl9TR0hOaWJFIn0seyJwYXJhbXMiOlsiIiwiZTdmNzYzNGU5MjU1NDFmMzY4YjgyN2FkNWM3MjQyMTkwNTEwMGY2MjA1Mjg1YTc4YzE5ZDdiNGEzODcxMTgwNSIsMTUwXSwibmFtZSI6IlRSQU5TRkVSIiwibW9kdWxlIjp7Im5hbWVzcGFjZSI6bnVsbCwibmFtZSI6ImNvaW4ifSwibW9kdWxlSGFzaCI6IjNpSUJRZEpuc3Q0NFoyWmdYb0hQa0FhdXliSjBoODVsX2VuX1NHSE5pYkUifSx7InBhcmFtcyI6WyIiLCJhbGxvY2F0aW9uMDAiLDEwMDAwMF0sIm5hbWUiOiJUUkFOU0ZFUiIsIm1vZHVsZSI6eyJuYW1lc3BhY2UiOm51bGwsIm5hbWUiOiJjb2luIn0sIm1vZHVsZUhhc2giOiIzaUlCUWRKbnN0NDRaMlpnWG9IUGtBYXV5YkowaDg1bF9lbl9TR0hOaWJFIn0seyJwYXJhbXMiOlsiIiwiYWxsb2NhdGlvbjAxIiwxMDAwMDBdLCJuYW1lIjoiVFJBTlNGRVIiLCJtb2R1bGUiOnsibmFtZXNwYWNlIjpudWxsLCJuYW1lIjoiY29pbiJ9LCJtb2R1bGVIYXNoIjoiM2lJQlFkSm5zdDQ0WjJaZ1hvSFBrQWF1eWJKMGg4NWxfZW5fU0dITmliRSJ9LHsicGFyYW1zIjpbIiIsImFsbG9jYXRpb24wMiIsMTAwMDAwXSwibmFtZSI6IlRSQU5TRkVSIiwibW9kdWxlIjp7Im5hbWVzcGFjZSI6bnVsbCwibmFtZSI6ImNvaW4ifSwibW9kdWxlSGFzaCI6IjNpSUJRZEpuc3Q0NFoyWmdYb0hQa0FhdXliSjBoODVsX2VuX1NHSE5pYkUifV0sIm1ldGFEYXRhIjpudWxsLCJjb250aW51YXRpb24iOm51bGwsInR4SWQiOjh9") ] diff --git a/src/Chainweb/BlockHeader/Genesis/QuirkedGasPact5InstantTimedCPM1to9Payload.hs b/src/Chainweb/BlockHeader/Genesis/QuirkedGasPact5InstantTimedCPM1to9Payload.hs index b15f37daf4..81841fbf2a 100644 --- a/src/Chainweb/BlockHeader/Genesis/QuirkedGasPact5InstantTimedCPM1to9Payload.hs +++ b/src/Chainweb/BlockHeader/Genesis/QuirkedGasPact5InstantTimedCPM1to9Payload.hs @@ -8,7 +8,7 @@ import qualified Data.Text as T import qualified Data.Vector as V import GHC.Stack -import Chainweb.Payload +import Chainweb.Pact.Payload import Chainweb.Utils (unsafeFromText, toText) payloadBlock :: HasCallStack => PayloadWithOutputs @@ -21,7 +21,7 @@ payloadBlock where actualHash, expectedHash :: BlockPayloadHash actualHash = _payloadWithOutputsPayloadHash payload - expectedHash = unsafeFromText "tL8Um8Zql3uKtYX5yo9-YoW_cKGf_BFBONzVD5JDd5k" + expectedHash = unsafeFromText "jrfVQ_AVbtnWRVXeUhyNurrz1XXl37sofUfEBh7EBG0" payload = newPayloadWithOutputs minerData coinbase txs minerData = unsafeFromText "eyJhY2NvdW50IjoiTm9NaW5lciIsInByZWRpY2F0ZSI6IjwiLCJwdWJsaWMta2V5cyI6W119" @@ -35,5 +35,5 @@ payloadBlock , (unsafeFromText "eyJoYXNoIjoiQ1pteWxXZmllUk1CTXU1dzJFT21wRndLLXQ3YmNPVHM0bUsyYVQzM3VSNCIsInNpZ3MiOltdLCJjbWQiOiJ7XCJuZXR3b3JrSWRcIjpudWxsLFwicGF5bG9hZFwiOntcImV4ZWNcIjp7XCJkYXRhXCI6e1wibnMtYWRtaW4ta2V5c2V0XCI6W1wiMzY4ODIwZjgwYzMyNGJiYzdjMmIwNjEwNjg4YTdkYTQzZTM5ZjkxZDExODczMjY3MWNkOWM3NTAwZmY0M2NjYVwiXSxcIm5zLW9wZXJhdGUta2V5c2V0XCI6W1wiMzY4ODIwZjgwYzMyNGJiYzdjMmIwNjEwNjg4YTdkYTQzZTM5ZjkxZDExODczMjY3MWNkOWM3NTAwZmY0M2NjYVwiXSxcIm5zLWdlbmVzaXMta2V5c2V0XCI6e1wicHJlZFwiOlwiPVwiLFwia2V5c1wiOltdfX0sXCJjb2RlXCI6XCIoZGVmaW5lLWtleXNldCAnbnMtYWRtaW4ta2V5c2V0IChyZWFkLWtleXNldCAnbnMtYWRtaW4ta2V5c2V0KSlcXG4oZGVmaW5lLWtleXNldCAnbnMtb3BlcmF0ZS1rZXlzZXQgKHJlYWQta2V5c2V0ICducy1nZW5lc2lzLWtleXNldCkpXFxuXFxuKG1vZHVsZSBucyBHT1ZFUk5BTkNFXFxuICBcXFwiQWRtaW5pc3RlcnMgZGVmaW5pdGlvbiBvZiBuZXcgbmFtZXNwYWNlcyBpbiBDaGFpbndlYi5cXFwiXFxuXFxuICAoZGVmc2NoZW1hIHJlZy1lbnRyeVxcbiAgICBhZG1pbi1ndWFyZDpndWFyZFxcbiAgICBhY3RpdmU6Ym9vbClcXG5cXG4gIChkZWZ0YWJsZSByZWdpc3RyeTp7cmVnLWVudHJ5fSlcXG5cXG4gIChkZWZjYXAgR09WRVJOQU5DRSAoKVxcbiAgICAoZW5mb3JjZS1rZXlzZXQgJ25zLWFkbWluLWtleXNldCkpXFxuXFxuICAoZGVmY2FwIE9QRVJBVEUgKClcXG4gICAgKGVuZm9yY2Uta2V5c2V0ICducy1vcGVyYXRlLWtleXNldCkpXFxuXFxuICAoZGVmY29uc3QgR1VBUkRfU1VDQ0VTUyAoY3JlYXRlLXVzZXItZ3VhcmQgKHN1Y2Nlc3MpKSlcXG4gIChkZWZjb25zdCBHVUFSRF9GQUlMVVJFIChjcmVhdGUtdXNlci1ndWFyZCAoZmFpbHVyZSkpKVxcblxcbiAgKGRlZnVuIHN1Y2Nlc3MgKClcXG4gICAgdHJ1ZSlcXG4gIChkZWZ1biBmYWlsdXJlICgpXFxuICAgIChlbmZvcmNlIGZhbHNlIFxcXCJEaXNhYmxlZFxcXCIpKVxcblxcbiAgKGRlZnVuIHZhbGlkYXRlLW5hbWUgKG5hbWUpXFxuICAgIChlbmZvcmNlICghPSBcXFwiXFxcIiBuYW1lKSBcXFwiRW1wdHkgbmFtZSBub3QgYWxsb3dlZFxcXCIpXFxuICAgIChlbmZvcmNlICg8IChsZW5ndGggbmFtZSkgNjQpIFxcXCJOYW1lIG11c3QgYmUgbGVzcyB0aGFuIDY0IGNoYXJhY3RlcnMgbG9uZ1xcXCIpXFxuICAgIChlbmZvcmNlIChpcy1jaGFyc2V0IENIQVJTRVRfTEFUSU4xIG5hbWUpXFxuICAgICAgICAgICAgIFxcXCJOYW1lIG11c3QgYmUgaW4gbGF0aW4xIGNoYXJzZXRcXFwiKSlcXG5cXG4gIChkZWZ1biBjcmVhdGUtcHJpbmNpcGFsLW5hbWVzcGFjZTpzdHJpbmdcXG4gICAgICAoIGc6Z3VhcmRcXG4gICAgICAgIClcXG4gICAgXFxcIiBGb3JtYXQgcHJpbmNpcGFsIG5hbWVzcGFjZSBhcyBQYWN0IGhhc2ggKEJMQUtFMmIyNTYpIG9mIHByaW5jaXBhbCBcXFxcXFxuICAgIFxcXFwgaW4gaGV4IHRydW5jYXRlZCB0byAxNjAgYml0cyAoNDAgY2hhcmFjdGVycyksIHByZXBlbmRlZCB3aXRoICduXycuXFxcXFxcbiAgICBcXFxcIE9ubHkgdzogYW5kIGs6IGFjY291bnQgcHJvdG9jb2xzIGFyZSBzdXBwb3J0ZWQuIFxcXCJcXG5cXG4gICAgKGxldFxcbiAgICAgICgodHkgKHR5cGVvZi1wcmluY2lwYWwgKGNyZWF0ZS1wcmluY2lwYWwgZykpKSlcXG5cXG4gICAgICA7OyBvbmx5IHc6IGFuZCBrOiBjdXJyZW50bHkgc3VwcG9ydGVkXFxuICAgICAgKGlmIChvciAoPSB0eSBcXFwiazpcXFwiKSAoPSB0eSBcXFwidzpcXFwiKSlcXG4gICAgICAgICgrIFxcXCJuX1xcXCIgKHRha2UgNDAgKGludC10by1zdHIgMTYgKHN0ci10by1pbnQgNjQgKGhhc2ggZykpKSkpXFxuICAgICAgICAoZW5mb3JjZSBmYWxzZVxcbiAgICAgICAgICAoZm9ybWF0IFxcXCJVbnN1cHBvcnRlZCBndWFyZCBwcm90b2NvbDoge31cXFwiIFt0eV0pKVxcbiAgICAgICAgKSlcXG4gIClcXG5cXG4gIChkZWZ1biB2YWxpZGF0ZTpib29sXFxuICAgICAgKCBucy1uYW1lOnN0cmluZ1xcbiAgICAgICAgbnMtYWRtaW46Z3VhcmRcXG4gICAgICAgIClcXG4gICAgXFxcIiBNYW5hZ2VzIG5hbWVzcGFjZSBpbnN0YWxsIGZvciBDaGFpbndlYi4gXFxcXFxcbiAgICBcXFxcIEFsbG93cyBwcmluY2lwYWwgbmFtZXNwYWNlcy4gXFxcXFxcbiAgICBcXFxcIE5vbi1wcmluY2lwYWwgbmFtZXNwYWNlcyByZXF1aXJlIGFjdGl2ZSByb3cgaW4gcmVnaXN0cnkgXFxcXFxcbiAgICBcXFxcIGZvciBOUy1OQU1FIHdpdGggZ3VhcmQgbWF0Y2hpbmcgTlMtQURNSU4uXFxcIlxcblxcbiAgICAoaWYgKD0gKGNyZWF0ZS1wcmluY2lwYWwtbmFtZXNwYWNlIG5zLWFkbWluKSBucy1uYW1lKVxcblxcbiAgICAgIHRydWUgOzsgYWxsb3cgcHJpbmNpcGFsIG5hbWVzcGFjZXNcXG5cXG4gICAgICAod2l0aC1kZWZhdWx0LXJlYWQgcmVnaXN0cnkgbnMtbmFtZSAgICAgICA7OyBvdGhlcndpc2UgZW5mb3JjZSByZWdpc3RyeVxcbiAgICAgICAgeyAnYWRtaW4tZ3VhcmQgOiBucy1hZG1pblxcbiAgICAgICAgLCAnYWN0aXZlIDogZmFsc2UgfVxcbiAgICAgICAgeyAnYWRtaW4tZ3VhcmQgOj0gYWdcXG4gICAgICAgICwgJ2FjdGl2ZSA6PSBpcy1hY3RpdmUgfVxcblxcbiAgICAgICAgKGVuZm9yY2UgaXMtYWN0aXZlIFxcXCJJbmFjdGl2ZSBvciB1bnJlZ2lzdGVyZWQgbmFtZXNwYWNlXFxcIilcXG4gICAgICAgIChlbmZvcmNlICg9IG5zLWFkbWluIGFnKSBcXFwiQWRtaW4gZ3VhcmQgbXVzdCBtYXRjaCBndWFyZCBpbiByZWdpc3RyeVxcXCIpXFxuXFxuICAgICAgICB0cnVlKVxcbiAgICAgICkpXFxuXFxuICAoZGVmdW4gd3JpdGUtcmVnaXN0cnk6c3RyaW5nXFxuICAgICAgKCBucy1uYW1lOnN0cmluZ1xcbiAgICAgICAgZ3VhcmQ6Z3VhcmRcXG4gICAgICAgIGFjdGl2ZTpib29sXFxuICAgICAgICApXFxuICAgIFxcXCIgV3JpdGUgZW50cnkgd2l0aCBHVUFSRCBhbmQgQUNUSVZFIGludG8gcmVnaXN0cnkgZm9yIE5BTUUuIFxcXFxcXG4gICAgXFxcXCBHdWFyZGVkIGJ5IG9wZXJhdGUga2V5c2V0LiBcXFwiXFxuXFxuICAgICh3aXRoLWNhcGFiaWxpdHkgKE9QRVJBVEUpXFxuXFxuICAgICAgKHZhbGlkYXRlLW5hbWUgbnMtbmFtZSlcXG5cXG4gICAgICAod3JpdGUgcmVnaXN0cnkgbnMtbmFtZVxcbiAgICAgICAgeyAnYWRtaW4tZ3VhcmQ6IGd1YXJkXFxuICAgICAgICAsICdhY3RpdmU6IGFjdGl2ZSB9KVxcblxcbiAgICAgIFxcXCJSZWdpc3RlciBlbnRyeSB3cml0dGVuXFxcIikpXFxuXFxuICAoZGVmdW4gcXVlcnk6b2JqZWN0e3JlZy1lbnRyeX1cXG4gICAgICAoIG5zLW5hbWU6c3RyaW5nIClcXG4gICAgKHJlYWQgcmVnaXN0cnkgbnMtbmFtZSkpXFxuXFxuKVxcblxcbihjcmVhdGUtdGFibGUgcmVnaXN0cnkpXFxuXFxuKHdyaXRlLXJlZ2lzdHJ5IFxcXCJrYWRlbmFcXFwiXFxuICAoa2V5c2V0LXJlZi1ndWFyZCAnbnMtb3BlcmF0ZS1rZXlzZXQpIHRydWUpXFxuKHdyaXRlLXJlZ2lzdHJ5IFxcXCJ1c2VyXFxcIiBHVUFSRF9GQUlMVVJFIHRydWUpXFxuKHdyaXRlLXJlZ2lzdHJ5IFxcXCJmcmVlXFxcIiBHVUFSRF9GQUlMVVJFIHRydWUpXFxuXFxuKGRlZmluZS1uYW1lc3BhY2UgXFxcImthZGVuYVxcXCJcXG4gIChrZXlzZXQtcmVmLWd1YXJkICducy1vcGVyYXRlLWtleXNldClcXG4gIChrZXlzZXQtcmVmLWd1YXJkICducy1vcGVyYXRlLWtleXNldCkpXFxuXFxuKGRlZmluZS1uYW1lc3BhY2UgXFxcInVzZXJcXFwiIEdVQVJEX1NVQ0NFU1MgR1VBUkRfRkFJTFVSRSlcXG4oZGVmaW5lLW5hbWVzcGFjZSBcXFwiZnJlZVxcXCIgR1VBUkRfU1VDQ0VTUyBHVUFSRF9GQUlMVVJFKVxcbjs7cm90YXRlIHRvIHJlYWwgb3BlcmF0ZSBrZXlzZXRcXG4oZGVmaW5lLWtleXNldCAnbnMtb3BlcmF0ZS1rZXlzZXQgKHJlYWQta2V5c2V0ICducy1vcGVyYXRlLWtleXNldCkpXFxuXCJ9fSxcInNpZ25lcnNcIjpbXSxcIm1ldGFcIjp7XCJjcmVhdGlvblRpbWVcIjowLFwidHRsXCI6MTcyODAwLFwiZ2FzTGltaXRcIjowLFwiY2hhaW5JZFwiOlwiXCIsXCJnYXNQcmljZVwiOjAsXCJzZW5kZXJcIjpcIlwifSxcIm5vbmNlXCI6XCJsb2FkLW5zLWRldm5ldC1zZW5kZXIwMFwifSJ9", unsafeFromText "eyJnYXMiOjAsInJlc3VsdCI6eyJzdGF0dXMiOiJzdWNjZXNzIiwiZGF0YSI6IktleXNldCB3cml0ZSBzdWNjZXNzIn0sInJlcUtleSI6IkNabXlsV2ZpZVJNQk11NXcyRU9tcEZ3Sy10N2JjT1RzNG1LMmFUMzN1UjQiLCJsb2dzIjoidDdzQzg1Y1hlWFdSdG90M1lEb2pSejZibWtncEN6enJQQ0Z6QThzTkg3OCIsIm1ldGFEYXRhIjpudWxsLCJjb250aW51YXRpb24iOm51bGwsInR4SWQiOjV9") , (unsafeFromText "eyJoYXNoIjoiWE5BNmxPSjFXLTdYWXY1WWI0QXFsNzRveFlJN09KcWpPUVQ1b1k0OHEtZyIsInNpZ3MiOltdLCJjbWQiOiJ7XCJuZXR3b3JrSWRcIjpudWxsLFwicGF5bG9hZFwiOntcImV4ZWNcIjp7XCJkYXRhXCI6e1wiYWxsb2NhdGlvbi10ZXN0MDFcIjpbXCI3MDExYzM3OTE0MGZmODk5ZjdlNjEzYWMwYTk3ODRhN2MwYTUxNWQzMGZlMGFiMmIwYzA3ZTVhYTE3NjM1ZTNlXCJdLFwiYWxsb2NhdGlvbjAyXCI6W1wiZTllNGU3MWJkMDYzZGNmN2UwNmJkNWIxYTE2Njg4ODk3ZDE1Y2E4YmQyZTUwOWM0NTNjNjE2MjE5YzE4NmNjNVwiXSxcImFsbG9jYXRpb24wMFwiOltcImQ4MmQwZGNkZTk4MjU1MDVkODZhZmI2ZGNjMTA0MTFkNmI2N2E0MjlhNzllMjFiZGE0YmIxMTliZjI4YWI4NzFcIl0sXCJhbGxvY2F0aW9uLXRlc3QwMlwiOltcIjA2NTQ0ZTIyYmZlZjIzMGQ2ZDIyZjk0ODZhYzZjYjc2YmYyNThlYmZiZjAxMzdlZTU4ZjY1NzQzZTFhNWI4YzRcIl0sXCJhbGxvY2F0aW9uMDFcIjpbXCJiNGM4YTNlYTkxZDMxNDZiMDU2MDk5NDc0MGYwZTNlZWQ5MWM1OWQyZWVjYTFkYzk5ZjBjMjg3Mjg0NWMyOTRkXCJdfSxcImNvZGVcIjpcIihkZWZpbmUta2V5c2V0IFxcXCJhbGxvY2F0aW9uMDBcXFwiIChyZWFkLWtleXNldCBcXFwiYWxsb2NhdGlvbjAwXFxcIikpXFxuKGRlZmluZS1rZXlzZXQgXFxcImFsbG9jYXRpb24wMVxcXCIgKHJlYWQta2V5c2V0IFxcXCJhbGxvY2F0aW9uMDFcXFwiKSlcXG4oZGVmaW5lLWtleXNldCBcXFwiYWxsb2NhdGlvbjAyXFxcIiAocmVhZC1rZXlzZXQgXFxcImFsbG9jYXRpb24wMlxcXCIpKVxcbihkZWZpbmUta2V5c2V0IFxcXCJhbGxvY2F0aW9uLXRlc3QwMVxcXCIgKHJlYWQta2V5c2V0IFxcXCJhbGxvY2F0aW9uLXRlc3QwMVxcXCIpKVxcbihkZWZpbmUta2V5c2V0IFxcXCJhbGxvY2F0aW9uLXRlc3QwMlxcXCIgKHJlYWQta2V5c2V0IFxcXCJhbGxvY2F0aW9uLXRlc3QwMlxcXCIpKVwifX0sXCJzaWduZXJzXCI6W10sXCJtZXRhXCI6e1wiY3JlYXRpb25UaW1lXCI6MCxcInR0bFwiOjE3MjgwMCxcImdhc0xpbWl0XCI6MCxcImNoYWluSWRcIjpcIlwiLFwiZ2FzUHJpY2VcIjowLFwic2VuZGVyXCI6XCJcIn0sXCJub25jZVwiOlwiZGV2bmV0LWtleXNldHNcIn0ifQ", unsafeFromText "eyJnYXMiOjAsInJlc3VsdCI6eyJzdGF0dXMiOiJzdWNjZXNzIiwiZGF0YSI6IktleXNldCB3cml0ZSBzdWNjZXNzIn0sInJlcUtleSI6IlhOQTZsT0oxVy03WFl2NVliNEFxbDc0b3hZSTdPSnFqT1FUNW9ZNDhxLWciLCJsb2dzIjoiYXJRSWpQVGRrcXhoQTNjWl9WaVE3OXM3Uk5XRTlGV2Rha0xWdXl4Nlc0YyIsIm1ldGFEYXRhIjpudWxsLCJjb250aW51YXRpb24iOm51bGwsInR4SWQiOjZ9") , (unsafeFromText "eyJoYXNoIjoiNWtxZ0tzWWtwbjZCcS1KUnhNYnA1VG9jUWhRWGRJVVNiM1NGQm1Ba3VWcyIsInNpZ3MiOltdLCJjbWQiOiJ7XCJuZXR3b3JrSWRcIjpudWxsLFwicGF5bG9hZFwiOntcImV4ZWNcIjp7XCJkYXRhXCI6bnVsbCxcImNvZGVcIjpcIihjb2luLmNyZWF0ZS1hbGxvY2F0aW9uLWFjY291bnQgXFxcImFsbG9jYXRpb24wMFxcXCIgKHRpbWUgXFxcIjE5MDAtMTAtMTVUMTg6MDA6MDBaXFxcIikgXFxcImFsbG9jYXRpb24wMFxcXCIgMTAwMDAwMC4wKVxcbihjb2luLmNyZWF0ZS1hbGxvY2F0aW9uLWFjY291bnQgXFxcImFsbG9jYXRpb24wMVxcXCIgKHRpbWUgXFxcIjIxMDAtMTAtMzFUMTg6MDA6MDBaXFxcIikgXFxcImFsbG9jYXRpb24wMVxcXCIgMTAwMDAwMC4wKVxcbihjb2luLmNyZWF0ZS1hbGxvY2F0aW9uLWFjY291bnQgXFxcImFsbG9jYXRpb24wMlxcXCIgKHRpbWUgXFxcIjE5MDAtMTAtMzFUMTg6MDA6MDBaXFxcIikgXFxcImFsbG9jYXRpb24wMlxcXCIgMTAwMDAwMC4wKVxcbihjb2luLmNyZWF0ZS1hbGxvY2F0aW9uLWFjY291bnQgXFxcImFsbG9jYXRpb24tdGVzdDAxXFxcIiAodGltZSBcXFwiMTkwMC0xMC0zMVQxODowMDowMFpcXFwiKSBcXFwiYWxsb2NhdGlvbi10ZXN0MDFcXFwiIDEwMDAwMDAuMClcXG4oY29pbi5jcmVhdGUtYWxsb2NhdGlvbi1hY2NvdW50IFxcXCJhbGxvY2F0aW9uLXRlc3QwMlxcXCIgKHRpbWUgXFxcIjE5MDAtMTAtMzFUMTg6MDA6MDBaXFxcIikgXFxcImFsbG9jYXRpb24tdGVzdDAyXFxcIiAyMDAwMDAwLjApXCJ9fSxcInNpZ25lcnNcIjpbXSxcIm1ldGFcIjp7XCJjcmVhdGlvblRpbWVcIjowLFwidHRsXCI6MTcyODAwLFwiZ2FzTGltaXRcIjowLFwiY2hhaW5JZFwiOlwiXCIsXCJnYXNQcmljZVwiOjAsXCJzZW5kZXJcIjpcIlwifSxcIm5vbmNlXCI6XCJkZXZuZXQtYWxsb2NhdGlvbnNcIn0ifQ", unsafeFromText "eyJnYXMiOjAsInJlc3VsdCI6eyJzdGF0dXMiOiJzdWNjZXNzIiwiZGF0YSI6IldyaXRlIHN1Y2NlZWRlZCJ9LCJyZXFLZXkiOiI1a3FnS3NZa3BuNkJxLUpSeE1icDVUb2NRaFFYZElVU2IzU0ZCbUFrdVZzIiwibG9ncyI6IkhpX3ZfVEhFT2s2aEJFRU0yWmV2Vzh3eVJsQWpUZzNjVUQydXBlVkx0b1UiLCJtZXRhRGF0YSI6bnVsbCwiY29udGludWF0aW9uIjpudWxsLCJ0eElkIjo3fQ") - , (unsafeFromText "eyJoYXNoIjoiZjIxVTFJRnlRN0ZfLTRlTnR6QTFuWnZjQ0g5cnY5ZnZsNWM1a0RyNXFsdyIsInNpZ3MiOltdLCJjbWQiOiJ7XCJuZXR3b3JrSWRcIjpudWxsLFwicGF5bG9hZFwiOntcImV4ZWNcIjp7XCJkYXRhXCI6e1wic2VuZGVyMDdcIjpbXCI0YzMxZGM5ZWU3ZjI0MTc3Zjc4YjZmNTE4MDEyYTIwODMyNmUyYWYxZjM3YmIwYTI0MDViNTA1NmQwY2FkNjI4XCJdLFwic2VuZGVyMDFcIjpbXCI2YmUyZjQ4NWE3YWY3NWZlZGI0YjdmMTUzYTkwM2Y3ZTYwMDBjYTRhYTUwMTE3OWM5MWEyNDUwYjc3N2JkMmE3XCJdLFwic2VuZGVyMDZcIjpbXCI1ZmZjMWY3ZmVmN2E0NDczODYyNTc2MmY3NWE0MjI5NDU0OTUxZTAzZjJhZmM2ZjgxMzA5YzBjMWJkZjllZTZmXCJdLFwic2VuZGVyMDBcIjpbXCIzNjg4MjBmODBjMzI0YmJjN2MyYjA2MTA2ODhhN2RhNDNlMzlmOTFkMTE4NzMyNjcxY2Q5Yzc1MDBmZjQzY2NhXCJdLFwiZTdmN1wiOltcImU3Zjc2MzRlOTI1NTQxZjM2OGI4MjdhZDVjNzI0MjE5MDUxMDBmNjIwNTI4NWE3OGMxOWQ3YjRhMzg3MTE4MDVcIl0sXCJzZW5kZXIwNVwiOltcImYwOWQ4ZjYzOTRhZWE0MjVmZTY3ODNkODhjZDgxMzYzZDgwMTdmMTZhZmQzNzExYzU3NWJlMGY1Y2Q1YzliYjlcIl0sXCJzZW5kZXIwNFwiOltcIjJkNzBhYTRmNjk3YzNhM2I4ZGQ2ZDk3NzQ1YWMwNzRlZGNmZDBlYjY1YzM3Nzc0Y2RlMjUxMzU0ODNiZWE3MWVcIl0sXCJtdWx0aS0wMi0wMy0wNC1hbnlcIjp7XCJwcmVkXCI6XCJrZXlzLWFueVwiLFwia2V5c1wiOltcIjNhOWRkNTMyZDczZGFjZTE5NWRiYjY0ZDFkYmE2NTcyZmI3ODNkMGZkZDMyNDY4NWUzMmZiZGEyZjg5Zjk5YTZcIixcIjQzZjJhZGIxZGUxOTIwMDBjYjM3NzdiYWNjN2Y5ODNiNjYxNGZkOWMxNzE1Y2Q0NGNkNDg0YjZkM2EwZDM0YzhcIixcIjJkNzBhYTRmNjk3YzNhM2I4ZGQ2ZDk3NzQ1YWMwNzRlZGNmZDBlYjY1YzM3Nzc0Y2RlMjUxMzU0ODNiZWE3MWVcIl19LFwic2VuZGVyMDlcIjpbXCJjNTlkOTg0MGIwYjY2MDkwODM2NTQ2YjdlYjRhNzM2MDYyNTc1MjdlYzhjMmI0ODIzMDBmZDIyOTI2NGIwN2U2XCJdLFwic2VuZGVyMDNcIjpbXCI0M2YyYWRiMWRlMTkyMDAwY2IzNzc3YmFjYzdmOTgzYjY2MTRmZDljMTcxNWNkNDRjZDQ4NGI2ZDNhMGQzNGM4XCJdLFwibXVsdGktMDAtMDFcIjpbXCIzNjg4MjBmODBjMzI0YmJjN2MyYjA2MTA2ODhhN2RhNDNlMzlmOTFkMTE4NzMyNjcxY2Q5Yzc1MDBmZjQzY2NhXCIsXCI2YmUyZjQ4NWE3YWY3NWZlZGI0YjdmMTUzYTkwM2Y3ZTYwMDBjYTRhYTUwMTE3OWM5MWEyNDUwYjc3N2JkMmE3XCJdLFwic2VuZGVyMDhcIjpbXCI2M2IyZWJhNGVkNzBkNDYxMmQzZTdiYzkwZGIyZmJmNGM3NmY3YjA3NDM2M2U4NmQ3M2YwYmM2MTdmOGU4YjgxXCJdLFwic2VuZGVyMDJcIjpbXCIzYTlkZDUzMmQ3M2RhY2UxOTVkYmI2NGQxZGJhNjU3MmZiNzgzZDBmZGQzMjQ2ODVlMzJmYmRhMmY4OWY5OWE2XCJdfSxcImNvZGVcIjpcIihjb2luLmNvaW5iYXNlIFxcXCJzZW5kZXIwMFxcXCIgKHJlYWQta2V5c2V0IFxcXCJzZW5kZXIwMFxcXCIpIDEwMDAwMDAwMC4wKVxcbihjb2luLmNvaW5iYXNlIFxcXCJzZW5kZXIwMVxcXCIgKHJlYWQta2V5c2V0IFxcXCJzZW5kZXIwMVxcXCIpIDExMDAwMDAwMC4wKVxcbihjb2luLmNvaW5iYXNlIFxcXCJzZW5kZXIwMlxcXCIgKHJlYWQta2V5c2V0IFxcXCJzZW5kZXIwMlxcXCIpIDEyMDAwMDAwMC4wKVxcbihjb2luLmNvaW5iYXNlIFxcXCJzZW5kZXIwM1xcXCIgKHJlYWQta2V5c2V0IFxcXCJzZW5kZXIwM1xcXCIpIDEzMDAwMDAwMC4wKVxcbihjb2luLmNvaW5iYXNlIFxcXCJzZW5kZXIwNFxcXCIgKHJlYWQta2V5c2V0IFxcXCJzZW5kZXIwNFxcXCIpIDE0MDAwMDAwMC4wKVxcbihjb2luLmNvaW5iYXNlIFxcXCJzZW5kZXIwNVxcXCIgKHJlYWQta2V5c2V0IFxcXCJzZW5kZXIwNVxcXCIpIDE1MDAwMDAwMC4wKVxcbihjb2luLmNvaW5iYXNlIFxcXCJzZW5kZXIwNlxcXCIgKHJlYWQta2V5c2V0IFxcXCJzZW5kZXIwNlxcXCIpIDE2MDAwMDAwMC4wKVxcbihjb2luLmNvaW5iYXNlIFxcXCJzZW5kZXIwN1xcXCIgKHJlYWQta2V5c2V0IFxcXCJzZW5kZXIwN1xcXCIpIDE3MDAwMDAwMC4wKVxcbihjb2luLmNvaW5iYXNlIFxcXCJzZW5kZXIwOFxcXCIgKHJlYWQta2V5c2V0IFxcXCJzZW5kZXIwOFxcXCIpIDE4MDAwMDAwMC4wKVxcbihjb2luLmNvaW5iYXNlIFxcXCJzZW5kZXIwOVxcXCIgKHJlYWQta2V5c2V0IFxcXCJzZW5kZXIwOVxcXCIpIDE5MDAwMDAwMC4wKVxcbihjb2luLmNvaW5iYXNlIFxcXCJtdWx0aS0wMC0wMVxcXCIgKHJlYWQta2V5c2V0IFxcXCJtdWx0aS0wMC0wMVxcXCIpIDEwMTAwMDAwMC4wKVxcbihjb2luLmNvaW5iYXNlIFxcXCJtdWx0aS0wMi0wMy0wNC1hbnlcXFwiIChyZWFkLWtleXNldCBcXFwibXVsdGktMDItMDMtMDQtYW55XFxcIikgMTIzNDAwMDAwLjApXFxuXFxuKGNvaW4uY29pbmJhc2UgXFxcImU3Zjc2MzRlOTI1NTQxZjM2OGI4MjdhZDVjNzI0MjE5MDUxMDBmNjIwNTI4NWE3OGMxOWQ3YjRhMzg3MTE4MDVcXFwiIChyZWFkLWtleXNldCBcXFwiZTdmN1xcXCIpIDE1MC4wKVwifX0sXCJzaWduZXJzXCI6W10sXCJtZXRhXCI6e1wiY3JlYXRpb25UaW1lXCI6MCxcInR0bFwiOjE3MjgwMCxcImdhc0xpbWl0XCI6MCxcImNoYWluSWRcIjpcIlwiLFwiZ2FzUHJpY2VcIjowLFwic2VuZGVyXCI6XCJcIn0sXCJub25jZVwiOlwiZGV2bmV0LWdyYW50c05cIn0ifQ", unsafeFromText "eyJnYXMiOjAsInJlc3VsdCI6eyJzdGF0dXMiOiJzdWNjZXNzIiwiZGF0YSI6IldyaXRlIHN1Y2NlZWRlZCJ9LCJyZXFLZXkiOiJmMjFVMUlGeVE3Rl8tNGVOdHpBMW5admNDSDlydjlmdmw1YzVrRHI1cWx3IiwibG9ncyI6IkF3MTVuVFF0YmlQYlVCQm1reGpRV09JZlc3ZHNfUi1sWjhNMGZDMXAxZHciLCJldmVudHMiOlt7InBhcmFtcyI6WyIiLCJzZW5kZXIwMCIsMTAwMDAwMDAwXSwibmFtZSI6IlRSQU5TRkVSIiwibW9kdWxlIjp7Im5hbWVzcGFjZSI6bnVsbCwibmFtZSI6ImNvaW4ifSwibW9kdWxlSGFzaCI6IjNpSUJRZEpuc3Q0NFoyWmdYb0hQa0FhdXliSjBoODVsX2VuX1NHSE5pYkUifSx7InBhcmFtcyI6WyIiLCJzZW5kZXIwMSIsMTEwMDAwMDAwXSwibmFtZSI6IlRSQU5TRkVSIiwibW9kdWxlIjp7Im5hbWVzcGFjZSI6bnVsbCwibmFtZSI6ImNvaW4ifSwibW9kdWxlSGFzaCI6IjNpSUJRZEpuc3Q0NFoyWmdYb0hQa0FhdXliSjBoODVsX2VuX1NHSE5pYkUifSx7InBhcmFtcyI6WyIiLCJzZW5kZXIwMiIsMTIwMDAwMDAwXSwibmFtZSI6IlRSQU5TRkVSIiwibW9kdWxlIjp7Im5hbWVzcGFjZSI6bnVsbCwibmFtZSI6ImNvaW4ifSwibW9kdWxlSGFzaCI6IjNpSUJRZEpuc3Q0NFoyWmdYb0hQa0FhdXliSjBoODVsX2VuX1NHSE5pYkUifSx7InBhcmFtcyI6WyIiLCJzZW5kZXIwMyIsMTMwMDAwMDAwXSwibmFtZSI6IlRSQU5TRkVSIiwibW9kdWxlIjp7Im5hbWVzcGFjZSI6bnVsbCwibmFtZSI6ImNvaW4ifSwibW9kdWxlSGFzaCI6IjNpSUJRZEpuc3Q0NFoyWmdYb0hQa0FhdXliSjBoODVsX2VuX1NHSE5pYkUifSx7InBhcmFtcyI6WyIiLCJzZW5kZXIwNCIsMTQwMDAwMDAwXSwibmFtZSI6IlRSQU5TRkVSIiwibW9kdWxlIjp7Im5hbWVzcGFjZSI6bnVsbCwibmFtZSI6ImNvaW4ifSwibW9kdWxlSGFzaCI6IjNpSUJRZEpuc3Q0NFoyWmdYb0hQa0FhdXliSjBoODVsX2VuX1NHSE5pYkUifSx7InBhcmFtcyI6WyIiLCJzZW5kZXIwNSIsMTUwMDAwMDAwXSwibmFtZSI6IlRSQU5TRkVSIiwibW9kdWxlIjp7Im5hbWVzcGFjZSI6bnVsbCwibmFtZSI6ImNvaW4ifSwibW9kdWxlSGFzaCI6IjNpSUJRZEpuc3Q0NFoyWmdYb0hQa0FhdXliSjBoODVsX2VuX1NHSE5pYkUifSx7InBhcmFtcyI6WyIiLCJzZW5kZXIwNiIsMTYwMDAwMDAwXSwibmFtZSI6IlRSQU5TRkVSIiwibW9kdWxlIjp7Im5hbWVzcGFjZSI6bnVsbCwibmFtZSI6ImNvaW4ifSwibW9kdWxlSGFzaCI6IjNpSUJRZEpuc3Q0NFoyWmdYb0hQa0FhdXliSjBoODVsX2VuX1NHSE5pYkUifSx7InBhcmFtcyI6WyIiLCJzZW5kZXIwNyIsMTcwMDAwMDAwXSwibmFtZSI6IlRSQU5TRkVSIiwibW9kdWxlIjp7Im5hbWVzcGFjZSI6bnVsbCwibmFtZSI6ImNvaW4ifSwibW9kdWxlSGFzaCI6IjNpSUJRZEpuc3Q0NFoyWmdYb0hQa0FhdXliSjBoODVsX2VuX1NHSE5pYkUifSx7InBhcmFtcyI6WyIiLCJzZW5kZXIwOCIsMTgwMDAwMDAwXSwibmFtZSI6IlRSQU5TRkVSIiwibW9kdWxlIjp7Im5hbWVzcGFjZSI6bnVsbCwibmFtZSI6ImNvaW4ifSwibW9kdWxlSGFzaCI6IjNpSUJRZEpuc3Q0NFoyWmdYb0hQa0FhdXliSjBoODVsX2VuX1NHSE5pYkUifSx7InBhcmFtcyI6WyIiLCJzZW5kZXIwOSIsMTkwMDAwMDAwXSwibmFtZSI6IlRSQU5TRkVSIiwibW9kdWxlIjp7Im5hbWVzcGFjZSI6bnVsbCwibmFtZSI6ImNvaW4ifSwibW9kdWxlSGFzaCI6IjNpSUJRZEpuc3Q0NFoyWmdYb0hQa0FhdXliSjBoODVsX2VuX1NHSE5pYkUifSx7InBhcmFtcyI6WyIiLCJtdWx0aS0wMC0wMSIsMTAxMDAwMDAwXSwibmFtZSI6IlRSQU5TRkVSIiwibW9kdWxlIjp7Im5hbWVzcGFjZSI6bnVsbCwibmFtZSI6ImNvaW4ifSwibW9kdWxlSGFzaCI6IjNpSUJRZEpuc3Q0NFoyWmdYb0hQa0FhdXliSjBoODVsX2VuX1NHSE5pYkUifSx7InBhcmFtcyI6WyIiLCJtdWx0aS0wMi0wMy0wNC1hbnkiLDEyMzQwMDAwMF0sIm5hbWUiOiJUUkFOU0ZFUiIsIm1vZHVsZSI6eyJuYW1lc3BhY2UiOm51bGwsIm5hbWUiOiJjb2luIn0sIm1vZHVsZUhhc2giOiIzaUlCUWRKbnN0NDRaMlpnWG9IUGtBYXV5YkowaDg1bF9lbl9TR0hOaWJFIn0seyJwYXJhbXMiOlsiIiwiZTdmNzYzNGU5MjU1NDFmMzY4YjgyN2FkNWM3MjQyMTkwNTEwMGY2MjA1Mjg1YTc4YzE5ZDdiNGEzODcxMTgwNSIsMTUwXSwibmFtZSI6IlRSQU5TRkVSIiwibW9kdWxlIjp7Im5hbWVzcGFjZSI6bnVsbCwibmFtZSI6ImNvaW4ifSwibW9kdWxlSGFzaCI6IjNpSUJRZEpuc3Q0NFoyWmdYb0hQa0FhdXliSjBoODVsX2VuX1NHSE5pYkUifV0sIm1ldGFEYXRhIjpudWxsLCJjb250aW51YXRpb24iOm51bGwsInR4SWQiOjh9") + , (unsafeFromText "eyJoYXNoIjoibWd3Z3lCdTRGS3NEQ042Q3dWOEJNcFdNcnBwb2UtVkJKYTFYRjktLTFQRSIsInNpZ3MiOltdLCJjbWQiOiJ7XCJuZXR3b3JrSWRcIjpudWxsLFwicGF5bG9hZFwiOntcImV4ZWNcIjp7XCJkYXRhXCI6e1wic2VuZGVyMDdcIjpbXCI0YzMxZGM5ZWU3ZjI0MTc3Zjc4YjZmNTE4MDEyYTIwODMyNmUyYWYxZjM3YmIwYTI0MDViNTA1NmQwY2FkNjI4XCJdLFwic2VuZGVyMDFcIjpbXCI2YmUyZjQ4NWE3YWY3NWZlZGI0YjdmMTUzYTkwM2Y3ZTYwMDBjYTRhYTUwMTE3OWM5MWEyNDUwYjc3N2JkMmE3XCJdLFwic2VuZGVyMDZcIjpbXCI1ZmZjMWY3ZmVmN2E0NDczODYyNTc2MmY3NWE0MjI5NDU0OTUxZTAzZjJhZmM2ZjgxMzA5YzBjMWJkZjllZTZmXCJdLFwic2VuZGVyMDBcIjpbXCIzNjg4MjBmODBjMzI0YmJjN2MyYjA2MTA2ODhhN2RhNDNlMzlmOTFkMTE4NzMyNjcxY2Q5Yzc1MDBmZjQzY2NhXCJdLFwiZTdmN1wiOltcImU3Zjc2MzRlOTI1NTQxZjM2OGI4MjdhZDVjNzI0MjE5MDUxMDBmNjIwNTI4NWE3OGMxOWQ3YjRhMzg3MTE4MDVcIl0sXCJzZW5kZXIwNVwiOltcImYwOWQ4ZjYzOTRhZWE0MjVmZTY3ODNkODhjZDgxMzYzZDgwMTdmMTZhZmQzNzExYzU3NWJlMGY1Y2Q1YzliYjlcIl0sXCJzZW5kZXIwNFwiOltcIjJkNzBhYTRmNjk3YzNhM2I4ZGQ2ZDk3NzQ1YWMwNzRlZGNmZDBlYjY1YzM3Nzc0Y2RlMjUxMzU0ODNiZWE3MWVcIl0sXCJtdWx0aS0wMi0wMy0wNC1hbnlcIjp7XCJwcmVkXCI6XCJrZXlzLWFueVwiLFwia2V5c1wiOltcIjJkNzBhYTRmNjk3YzNhM2I4ZGQ2ZDk3NzQ1YWMwNzRlZGNmZDBlYjY1YzM3Nzc0Y2RlMjUxMzU0ODNiZWE3MWVcIixcIjNhOWRkNTMyZDczZGFjZTE5NWRiYjY0ZDFkYmE2NTcyZmI3ODNkMGZkZDMyNDY4NWUzMmZiZGEyZjg5Zjk5YTZcIixcIjQzZjJhZGIxZGUxOTIwMDBjYjM3NzdiYWNjN2Y5ODNiNjYxNGZkOWMxNzE1Y2Q0NGNkNDg0YjZkM2EwZDM0YzhcIl19LFwic2VuZGVyMDlcIjpbXCJjNTlkOTg0MGIwYjY2MDkwODM2NTQ2YjdlYjRhNzM2MDYyNTc1MjdlYzhjMmI0ODIzMDBmZDIyOTI2NGIwN2U2XCJdLFwic2VuZGVyMDNcIjpbXCI0M2YyYWRiMWRlMTkyMDAwY2IzNzc3YmFjYzdmOTgzYjY2MTRmZDljMTcxNWNkNDRjZDQ4NGI2ZDNhMGQzNGM4XCJdLFwibXVsdGktMDAtMDFcIjpbXCIzNjg4MjBmODBjMzI0YmJjN2MyYjA2MTA2ODhhN2RhNDNlMzlmOTFkMTE4NzMyNjcxY2Q5Yzc1MDBmZjQzY2NhXCIsXCI2YmUyZjQ4NWE3YWY3NWZlZGI0YjdmMTUzYTkwM2Y3ZTYwMDBjYTRhYTUwMTE3OWM5MWEyNDUwYjc3N2JkMmE3XCJdLFwic2VuZGVyMDhcIjpbXCI2M2IyZWJhNGVkNzBkNDYxMmQzZTdiYzkwZGIyZmJmNGM3NmY3YjA3NDM2M2U4NmQ3M2YwYmM2MTdmOGU4YjgxXCJdLFwic2VuZGVyMDJcIjpbXCIzYTlkZDUzMmQ3M2RhY2UxOTVkYmI2NGQxZGJhNjU3MmZiNzgzZDBmZGQzMjQ2ODVlMzJmYmRhMmY4OWY5OWE2XCJdfSxcImNvZGVcIjpcIihjb2luLmNvaW5iYXNlIFxcXCJzZW5kZXIwMFxcXCIgKHJlYWQta2V5c2V0IFxcXCJzZW5kZXIwMFxcXCIpIDEwMDAwMDAwMC4wKVxcbihjb2luLmNvaW5iYXNlIFxcXCJzZW5kZXIwMVxcXCIgKHJlYWQta2V5c2V0IFxcXCJzZW5kZXIwMVxcXCIpIDExMDAwMDAwMC4wKVxcbihjb2luLmNvaW5iYXNlIFxcXCJzZW5kZXIwMlxcXCIgKHJlYWQta2V5c2V0IFxcXCJzZW5kZXIwMlxcXCIpIDEyMDAwMDAwMC4wKVxcbihjb2luLmNvaW5iYXNlIFxcXCJzZW5kZXIwM1xcXCIgKHJlYWQta2V5c2V0IFxcXCJzZW5kZXIwM1xcXCIpIDEzMDAwMDAwMC4wKVxcbihjb2luLmNvaW5iYXNlIFxcXCJzZW5kZXIwNFxcXCIgKHJlYWQta2V5c2V0IFxcXCJzZW5kZXIwNFxcXCIpIDE0MDAwMDAwMC4wKVxcbihjb2luLmNvaW5iYXNlIFxcXCJzZW5kZXIwNVxcXCIgKHJlYWQta2V5c2V0IFxcXCJzZW5kZXIwNVxcXCIpIDE1MDAwMDAwMC4wKVxcbihjb2luLmNvaW5iYXNlIFxcXCJzZW5kZXIwNlxcXCIgKHJlYWQta2V5c2V0IFxcXCJzZW5kZXIwNlxcXCIpIDE2MDAwMDAwMC4wKVxcbihjb2luLmNvaW5iYXNlIFxcXCJzZW5kZXIwN1xcXCIgKHJlYWQta2V5c2V0IFxcXCJzZW5kZXIwN1xcXCIpIDE3MDAwMDAwMC4wKVxcbihjb2luLmNvaW5iYXNlIFxcXCJzZW5kZXIwOFxcXCIgKHJlYWQta2V5c2V0IFxcXCJzZW5kZXIwOFxcXCIpIDE4MDAwMDAwMC4wKVxcbihjb2luLmNvaW5iYXNlIFxcXCJzZW5kZXIwOVxcXCIgKHJlYWQta2V5c2V0IFxcXCJzZW5kZXIwOVxcXCIpIDE5MDAwMDAwMC4wKVxcbihjb2luLmNvaW5iYXNlIFxcXCJtdWx0aS0wMC0wMVxcXCIgKHJlYWQta2V5c2V0IFxcXCJtdWx0aS0wMC0wMVxcXCIpIDEwMTAwMDAwMC4wKVxcbihjb2luLmNvaW5iYXNlIFxcXCJtdWx0aS0wMi0wMy0wNC1hbnlcXFwiIChyZWFkLWtleXNldCBcXFwibXVsdGktMDItMDMtMDQtYW55XFxcIikgMTIzNDAwMDAwLjApXFxuXFxuKGNvaW4uY29pbmJhc2UgXFxcImU3Zjc2MzRlOTI1NTQxZjM2OGI4MjdhZDVjNzI0MjE5MDUxMDBmNjIwNTI4NWE3OGMxOWQ3YjRhMzg3MTE4MDVcXFwiIChyZWFkLWtleXNldCBcXFwiZTdmN1xcXCIpIDE1MC4wKVwifX0sXCJzaWduZXJzXCI6W10sXCJtZXRhXCI6e1wiY3JlYXRpb25UaW1lXCI6MCxcInR0bFwiOjE3MjgwMCxcImdhc0xpbWl0XCI6MCxcImNoYWluSWRcIjpcIlwiLFwiZ2FzUHJpY2VcIjowLFwic2VuZGVyXCI6XCJcIn0sXCJub25jZVwiOlwiZGV2bmV0LWdyYW50c05cIn0ifQ", unsafeFromText "eyJnYXMiOjAsInJlc3VsdCI6eyJzdGF0dXMiOiJzdWNjZXNzIiwiZGF0YSI6IldyaXRlIHN1Y2NlZWRlZCJ9LCJyZXFLZXkiOiJtZ3dneUJ1NEZLc0RDTjZDd1Y4Qk1wV01ycHBvZS1WQkphMVhGOS0tMVBFIiwibG9ncyI6IkF3MTVuVFF0YmlQYlVCQm1reGpRV09JZlc3ZHNfUi1sWjhNMGZDMXAxZHciLCJldmVudHMiOlt7InBhcmFtcyI6WyIiLCJzZW5kZXIwMCIsMTAwMDAwMDAwXSwibmFtZSI6IlRSQU5TRkVSIiwibW9kdWxlIjp7Im5hbWVzcGFjZSI6bnVsbCwibmFtZSI6ImNvaW4ifSwibW9kdWxlSGFzaCI6IjNpSUJRZEpuc3Q0NFoyWmdYb0hQa0FhdXliSjBoODVsX2VuX1NHSE5pYkUifSx7InBhcmFtcyI6WyIiLCJzZW5kZXIwMSIsMTEwMDAwMDAwXSwibmFtZSI6IlRSQU5TRkVSIiwibW9kdWxlIjp7Im5hbWVzcGFjZSI6bnVsbCwibmFtZSI6ImNvaW4ifSwibW9kdWxlSGFzaCI6IjNpSUJRZEpuc3Q0NFoyWmdYb0hQa0FhdXliSjBoODVsX2VuX1NHSE5pYkUifSx7InBhcmFtcyI6WyIiLCJzZW5kZXIwMiIsMTIwMDAwMDAwXSwibmFtZSI6IlRSQU5TRkVSIiwibW9kdWxlIjp7Im5hbWVzcGFjZSI6bnVsbCwibmFtZSI6ImNvaW4ifSwibW9kdWxlSGFzaCI6IjNpSUJRZEpuc3Q0NFoyWmdYb0hQa0FhdXliSjBoODVsX2VuX1NHSE5pYkUifSx7InBhcmFtcyI6WyIiLCJzZW5kZXIwMyIsMTMwMDAwMDAwXSwibmFtZSI6IlRSQU5TRkVSIiwibW9kdWxlIjp7Im5hbWVzcGFjZSI6bnVsbCwibmFtZSI6ImNvaW4ifSwibW9kdWxlSGFzaCI6IjNpSUJRZEpuc3Q0NFoyWmdYb0hQa0FhdXliSjBoODVsX2VuX1NHSE5pYkUifSx7InBhcmFtcyI6WyIiLCJzZW5kZXIwNCIsMTQwMDAwMDAwXSwibmFtZSI6IlRSQU5TRkVSIiwibW9kdWxlIjp7Im5hbWVzcGFjZSI6bnVsbCwibmFtZSI6ImNvaW4ifSwibW9kdWxlSGFzaCI6IjNpSUJRZEpuc3Q0NFoyWmdYb0hQa0FhdXliSjBoODVsX2VuX1NHSE5pYkUifSx7InBhcmFtcyI6WyIiLCJzZW5kZXIwNSIsMTUwMDAwMDAwXSwibmFtZSI6IlRSQU5TRkVSIiwibW9kdWxlIjp7Im5hbWVzcGFjZSI6bnVsbCwibmFtZSI6ImNvaW4ifSwibW9kdWxlSGFzaCI6IjNpSUJRZEpuc3Q0NFoyWmdYb0hQa0FhdXliSjBoODVsX2VuX1NHSE5pYkUifSx7InBhcmFtcyI6WyIiLCJzZW5kZXIwNiIsMTYwMDAwMDAwXSwibmFtZSI6IlRSQU5TRkVSIiwibW9kdWxlIjp7Im5hbWVzcGFjZSI6bnVsbCwibmFtZSI6ImNvaW4ifSwibW9kdWxlSGFzaCI6IjNpSUJRZEpuc3Q0NFoyWmdYb0hQa0FhdXliSjBoODVsX2VuX1NHSE5pYkUifSx7InBhcmFtcyI6WyIiLCJzZW5kZXIwNyIsMTcwMDAwMDAwXSwibmFtZSI6IlRSQU5TRkVSIiwibW9kdWxlIjp7Im5hbWVzcGFjZSI6bnVsbCwibmFtZSI6ImNvaW4ifSwibW9kdWxlSGFzaCI6IjNpSUJRZEpuc3Q0NFoyWmdYb0hQa0FhdXliSjBoODVsX2VuX1NHSE5pYkUifSx7InBhcmFtcyI6WyIiLCJzZW5kZXIwOCIsMTgwMDAwMDAwXSwibmFtZSI6IlRSQU5TRkVSIiwibW9kdWxlIjp7Im5hbWVzcGFjZSI6bnVsbCwibmFtZSI6ImNvaW4ifSwibW9kdWxlSGFzaCI6IjNpSUJRZEpuc3Q0NFoyWmdYb0hQa0FhdXliSjBoODVsX2VuX1NHSE5pYkUifSx7InBhcmFtcyI6WyIiLCJzZW5kZXIwOSIsMTkwMDAwMDAwXSwibmFtZSI6IlRSQU5TRkVSIiwibW9kdWxlIjp7Im5hbWVzcGFjZSI6bnVsbCwibmFtZSI6ImNvaW4ifSwibW9kdWxlSGFzaCI6IjNpSUJRZEpuc3Q0NFoyWmdYb0hQa0FhdXliSjBoODVsX2VuX1NHSE5pYkUifSx7InBhcmFtcyI6WyIiLCJtdWx0aS0wMC0wMSIsMTAxMDAwMDAwXSwibmFtZSI6IlRSQU5TRkVSIiwibW9kdWxlIjp7Im5hbWVzcGFjZSI6bnVsbCwibmFtZSI6ImNvaW4ifSwibW9kdWxlSGFzaCI6IjNpSUJRZEpuc3Q0NFoyWmdYb0hQa0FhdXliSjBoODVsX2VuX1NHSE5pYkUifSx7InBhcmFtcyI6WyIiLCJtdWx0aS0wMi0wMy0wNC1hbnkiLDEyMzQwMDAwMF0sIm5hbWUiOiJUUkFOU0ZFUiIsIm1vZHVsZSI6eyJuYW1lc3BhY2UiOm51bGwsIm5hbWUiOiJjb2luIn0sIm1vZHVsZUhhc2giOiIzaUlCUWRKbnN0NDRaMlpnWG9IUGtBYXV5YkowaDg1bF9lbl9TR0hOaWJFIn0seyJwYXJhbXMiOlsiIiwiZTdmNzYzNGU5MjU1NDFmMzY4YjgyN2FkNWM3MjQyMTkwNTEwMGY2MjA1Mjg1YTc4YzE5ZDdiNGEzODcxMTgwNSIsMTUwXSwibmFtZSI6IlRSQU5TRkVSIiwibW9kdWxlIjp7Im5hbWVzcGFjZSI6bnVsbCwibmFtZSI6ImNvaW4ifSwibW9kdWxlSGFzaCI6IjNpSUJRZEpuc3Q0NFoyWmdYb0hQa0FhdXliSjBoODVsX2VuX1NHSE5pYkUifV0sIm1ldGFEYXRhIjpudWxsLCJjb250aW51YXRpb24iOm51bGwsInR4SWQiOjh9") ] diff --git a/src/Chainweb/BlockHeader/Genesis/RecapDevelopment0Payload.hs b/src/Chainweb/BlockHeader/Genesis/RecapDevelopment0Payload.hs index f4a8eff163..a34b83f4f4 100644 --- a/src/Chainweb/BlockHeader/Genesis/RecapDevelopment0Payload.hs +++ b/src/Chainweb/BlockHeader/Genesis/RecapDevelopment0Payload.hs @@ -8,7 +8,7 @@ import qualified Data.Text as T import qualified Data.Vector as V import GHC.Stack -import Chainweb.Payload +import Chainweb.Pact.Payload import Chainweb.Utils (unsafeFromText, toText) payloadBlock :: HasCallStack => PayloadWithOutputs diff --git a/src/Chainweb/BlockHeader/Genesis/RecapDevelopment10to19Payload.hs b/src/Chainweb/BlockHeader/Genesis/RecapDevelopment10to19Payload.hs index 49fd274c64..d97e671387 100644 --- a/src/Chainweb/BlockHeader/Genesis/RecapDevelopment10to19Payload.hs +++ b/src/Chainweb/BlockHeader/Genesis/RecapDevelopment10to19Payload.hs @@ -8,7 +8,7 @@ import qualified Data.Text as T import qualified Data.Vector as V import GHC.Stack -import Chainweb.Payload +import Chainweb.Pact.Payload import Chainweb.Utils (unsafeFromText, toText) payloadBlock :: HasCallStack => PayloadWithOutputs diff --git a/src/Chainweb/BlockHeader/Genesis/RecapDevelopment1to9Payload.hs b/src/Chainweb/BlockHeader/Genesis/RecapDevelopment1to9Payload.hs index b12622a559..7d837cfe84 100644 --- a/src/Chainweb/BlockHeader/Genesis/RecapDevelopment1to9Payload.hs +++ b/src/Chainweb/BlockHeader/Genesis/RecapDevelopment1to9Payload.hs @@ -8,7 +8,7 @@ import qualified Data.Text as T import qualified Data.Vector as V import GHC.Stack -import Chainweb.Payload +import Chainweb.Pact.Payload import Chainweb.Utils (unsafeFromText, toText) payloadBlock :: HasCallStack => PayloadWithOutputs diff --git a/src/Chainweb/BlockHeader/Genesis/Testnet040Payload.hs b/src/Chainweb/BlockHeader/Genesis/Testnet040Payload.hs index e7d9b18a7d..a3746400d8 100644 --- a/src/Chainweb/BlockHeader/Genesis/Testnet040Payload.hs +++ b/src/Chainweb/BlockHeader/Genesis/Testnet040Payload.hs @@ -8,7 +8,7 @@ import qualified Data.Text as T import qualified Data.Vector as V import GHC.Stack -import Chainweb.Payload +import Chainweb.Pact.Payload import Chainweb.Utils (unsafeFromText, toText) payloadBlock :: HasCallStack => PayloadWithOutputs diff --git a/src/Chainweb/BlockHeader/Genesis/Testnet041to19Payload.hs b/src/Chainweb/BlockHeader/Genesis/Testnet041to19Payload.hs index 87d45eb48c..1ada66b82e 100644 --- a/src/Chainweb/BlockHeader/Genesis/Testnet041to19Payload.hs +++ b/src/Chainweb/BlockHeader/Genesis/Testnet041to19Payload.hs @@ -8,7 +8,7 @@ import qualified Data.Text as T import qualified Data.Vector as V import GHC.Stack -import Chainweb.Payload +import Chainweb.Pact.Payload import Chainweb.Utils (unsafeFromText, toText) payloadBlock :: HasCallStack => PayloadWithOutputs diff --git a/src/Chainweb/BlockHeader/Genesis/Testnet060Payload.hs b/src/Chainweb/BlockHeader/Genesis/Testnet060Payload.hs index bd9d31a087..9269e91293 100644 --- a/src/Chainweb/BlockHeader/Genesis/Testnet060Payload.hs +++ b/src/Chainweb/BlockHeader/Genesis/Testnet060Payload.hs @@ -8,7 +8,7 @@ import qualified Data.Text as T import qualified Data.Vector as V import GHC.Stack -import Chainweb.Payload +import Chainweb.Pact.Payload import Chainweb.Utils (unsafeFromText, toText) payloadBlock :: HasCallStack => PayloadWithOutputs diff --git a/src/Chainweb/BlockHeader/Genesis/Testnet061to19Payload.hs b/src/Chainweb/BlockHeader/Genesis/Testnet061to19Payload.hs index e5f0dbc51d..f2c58c4c6d 100644 --- a/src/Chainweb/BlockHeader/Genesis/Testnet061to19Payload.hs +++ b/src/Chainweb/BlockHeader/Genesis/Testnet061to19Payload.hs @@ -8,7 +8,7 @@ import qualified Data.Text as T import qualified Data.Vector as V import GHC.Stack -import Chainweb.Payload +import Chainweb.Pact.Payload import Chainweb.Utils (unsafeFromText, toText) payloadBlock :: HasCallStack => PayloadWithOutputs diff --git a/src/Chainweb/BlockHeader/Internal.hs b/src/Chainweb/BlockHeader/Internal.hs index 6153fc2df0..771e6e6ffa 100644 --- a/src/Chainweb/BlockHeader/Internal.hs +++ b/src/Chainweb/BlockHeader/Internal.hs @@ -4,6 +4,7 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE EmptyCase #-} {-# LANGUAGE FlexibleContexts #-} @@ -41,16 +42,9 @@ -- are writing tests. module Chainweb.BlockHeader.Internal ( --- * Newtype wrappers for function parameters - ParentHeader(..) -, parentHeader -, parentHeaderHash -, _rankedParentHash -, rankedParentHash -, ParentCreationTime(..) -- * Block Payload Hash -, BlockPayloadHash + BlockPayloadHash , BlockPayloadHash_(..) , encodeBlockPayloadHash , decodeBlockPayloadHash @@ -66,6 +60,7 @@ module Chainweb.BlockHeader.Internal , encodeEpochStartTime , decodeEpochStartTime , epochStart +, makeGenesisBlockHeader -- * POW Target , powTarget @@ -96,6 +91,7 @@ module Chainweb.BlockHeader.Internal , rankedBlockHash , _rankedBlockPayloadHash , rankedBlockPayloadHash +, encodeAsMiningWork , encodeBlockHeader , encodeBlockHeaderWithoutHash , decodeBlockHeader @@ -117,7 +113,11 @@ module Chainweb.BlockHeader.Internal -- * Genesis BlockHeader , isGenesisBlockHeader +, isGenesisBlockHeader' +, childBlockHeight +, parentBlockHeight , genesisParentBlockHash +, genesisRankedParentBlockHash , genesisBlockHeader , genesisBlockHeaders , genesisBlockHeadersAtHeight @@ -140,6 +140,7 @@ module Chainweb.BlockHeader.Internal , genesisForkState -- * CAS Constraint +, ReadableBlockHeaderCas , BlockHeaderCas -- * Misc @@ -159,7 +160,9 @@ import Chainweb.Difficulty import Chainweb.Graph import Chainweb.MerkleLogHash import Chainweb.MerkleUniverse +import Chainweb.Parent import Chainweb.PowHash +import Chainweb.Ranked import Chainweb.Storage.Table import Chainweb.Time import Chainweb.TreeDB (TreeDbEntry(..)) @@ -169,7 +172,6 @@ import Chainweb.Utils.Serialization import Chainweb.Version import Chainweb.Version.Guards import Chainweb.Version.Mainnet -import Chainweb.Version.Registry (lookupVersionByName, lookupVersionByCode) import Chainweb.Version.Testnet04 import Control.DeepSeq import Control.Exception @@ -183,18 +185,17 @@ import Data.HashMap.Strict (HashMap) import Data.HashMap.Strict qualified as HM import Data.HashSet qualified as HS import Data.Hashable -import Data.IORef import Data.Kind import Data.Memory.Endian qualified as BA -import Data.MerkleLog hiding (Actual, Expected, MerkleHash) +import Data.MerkleLog.Root import Data.Text qualified as T import Data.Word import GHC.Generics (Generic) import GHC.Stack import Numeric.AffineSpace import Numeric.Natural -import System.IO.Unsafe import Text.Read (readEither) +import Control.Monad import Chainweb.ForkState -- -------------------------------------------------------------------------- -- @@ -335,7 +336,7 @@ data BlockHeader :: Type where -- an advantage to an attacker that would increase the success -- probability for an attack. - , _blockParent :: {-# UNPACK #-} !BlockHash + , _blockParent :: {-# UNPACK #-} !(Parent BlockHash) -- ^ authoritative , _blockAdjacentHashes :: !BlockHashRecord @@ -397,17 +398,15 @@ instance Hashable BlockHeader where instance HasChainId BlockHeader where _chainId = _blockChainId -instance HasChainGraph BlockHeader where - _chainGraph h = _chainGraph (_chainwebVersion h, _blockHeight h) - -instance HasChainwebVersion BlockHeader where - _chainwebVersion = lookupVersionByCode . _blockChainwebVersion +instance HasVersion => HasChainGraph BlockHeader where + _chainGraph h = chainGraphAt (_blockHeight h) instance IsCasValue BlockHeader where type CasKeyType BlockHeader = BlockHash casKey = _blockHash {-# INLINE casKey #-} +type ReadableBlockHeaderCas tbl = ReadableCas tbl BlockHeader type BlockHeaderCas tbl = Cas tbl BlockHeader -- | Used for quickly identifying "which block" this is. @@ -429,15 +428,15 @@ makeLenses ''BlockHeader -- adjustments. This is to account for rapidly changing total hash power in the -- early stages of the network. -- -effectiveWindow :: BlockHeader -> Maybe WindowWidth -effectiveWindow h = WindowWidth <$> case _versionWindow (_chainwebVersion h) of +effectiveWindow :: HasVersion => BlockHeader -> Maybe WindowWidth +effectiveWindow h = WindowWidth <$> case _versionWindow implicitVersion of WindowWidth w | int (_blockHeight h) <= w -> Just $ max 1 $ w `div` 10 | otherwise -> Just w -- | Return whether the given 'BlockHeader' is the last header in its epoch. -- -isLastInEpoch :: BlockHeader -> Bool +isLastInEpoch :: HasVersion => BlockHeader -> Bool isLastInEpoch h = case effectiveWindow h of Nothing -> False Just (WindowWidth w) -> (int (_blockHeight h) + 1) `mod` w == 0 @@ -451,13 +450,12 @@ isLastInEpoch h = case effectiveWindow h of -- all chainweb version. Emergency DAs are enabled (and have occured) only on -- mainnet01 for cut heights smaller than 80,000. -- -slowEpoch :: ParentHeader -> BlockCreationTime -> Bool -slowEpoch (ParentHeader p) (BlockCreationTime ct) = actual > (expected * 5) +slowEpoch :: HasVersion => Parent BlockHeader -> BlockCreationTime -> Bool +slowEpoch (Parent p) (BlockCreationTime ct) = actual > (expected * 5) where EpochStartTime es = _blockEpochStart p - v = _chainwebVersion p - BlockDelay bd = _versionBlockDelay v - WindowWidth ww = _versionWindow v + BlockDelay bd = _versionBlockDelay implicitVersion + WindowWidth ww = _versionWindow implicitVersion expected :: Micros expected = bd * int ww @@ -475,9 +473,10 @@ slowEpoch (ParentHeader p) (BlockCreationTime ct) = actual > (expected * 5) -- transition. -- powTarget - :: ParentHeader + :: HasVersion + => Parent BlockHeader -- ^ parent header - -> HM.HashMap ChainId ParentHeader + -> HM.HashMap ChainId (Parent BlockHeader) -- ^ adjacent Parents -> BlockCreationTime -- ^ block creation time of new block @@ -486,28 +485,27 @@ powTarget -- -> HashTarget -- ^ POW target of new block -powTarget p@(ParentHeader ph) as bct = case effectiveWindow ph of +powTarget p@(Parent ph) as bct = case effectiveWindow ph of Nothing -> maxTarget Just w -- Emergency DA, legacy - | slowEpochGuard ver (_chainId ph) (_blockHeight ph) && slowEpoch p bct -> + | slowEpochGuard (_chainId ph) (_blockHeight ph) && slowEpoch p bct -> activeAdjust w | isLastInEpoch ph -> activeAdjust w | otherwise -> _blockTarget ph where - ver = _chainwebVersion ph - t = EpochStartTime $ if oldTargetGuard ver (_chainId ph) (_blockHeight ph) + t = EpochStartTime $ if oldTargetGuard (_chainId ph) (_blockHeight ph) then _bct bct else _bct (_blockCreationTime ph) activeAdjust w - | oldDaGuard ver (_chainId ph) (_blockHeight ph + 1) - = legacyAdjust (_versionBlockDelay ver) w (t .-. _blockEpochStart ph) (_blockTarget ph) + | oldDaGuard (_chainId ph) (_blockHeight ph + 1) + = legacyAdjust (_versionBlockDelay implicitVersion) w (t .-. _blockEpochStart ph) (_blockTarget ph) | otherwise = avgTarget $ adjustForParent w <$> (p : HM.elems as) - adjustForParent w (ParentHeader a) - = adjust (_versionBlockDelay ver) w (toEpochStart a .-. _blockEpochStart a) (_blockTarget a) + adjustForParent w (Parent a) + = adjust (_versionBlockDelay implicitVersion) w (toEpochStart a .-. _blockEpochStart a) (_blockTarget a) toEpochStart = EpochStartTime . _bct . _blockCreationTime @@ -519,9 +517,10 @@ powTarget p@(ParentHeader ph) as bct = case effectiveWindow ph of -- | Compute the epoch start value for a new BlockHeader -- epochStart - :: ParentHeader + :: HasVersion + => Parent BlockHeader -- ^ parent header - -> HM.HashMap ChainId ParentHeader + -> HM.HashMap ChainId (Parent BlockHeader) -- ^ Adjacent parents of the block. It is not checked whether the -- set of adjacent parents conforms with the current graph. -> BlockCreationTime @@ -531,13 +530,13 @@ epochStart -- -> EpochStartTime -- ^ epoch start time of new block -epochStart ph@(ParentHeader p) adj (BlockCreationTime bt) +epochStart ph@(Parent p) adj (BlockCreationTime bt) | Nothing <- effectiveWindow p = _blockEpochStart p -- A special case for starting a new devnet, to compensate the inaccurate -- creation time of the genesis blocks. This would result in a very long -- first epoch that cause a trivial target in the second epoch. - | ver ^. versionCheats . fakeFirstEpochStart, _blockHeight p == 1 = EpochStartTime (_bct $ _blockCreationTime p) + | implicitVersion ^. versionCheats . fakeFirstEpochStart, _blockHeight p == 1 = EpochStartTime (_bct $ _blockCreationTime p) -- New Graph: the block time of the genesis block isn't accurate, we thus -- use the block time of the first block on the chain. Depending on where @@ -547,13 +546,13 @@ epochStart ph@(ParentHeader p) adj (BlockCreationTime bt) | parentIsFirstOnNewChain = EpochStartTime (_bct $ _blockCreationTime p) -- End of epoch, DA adjustment (legacy version) - | isLastInEpoch p && oldTargetGuard ver (_chainId p) (_blockHeight p) = EpochStartTime bt + | isLastInEpoch p && oldTargetGuard (_chainId p) (_blockHeight p) = EpochStartTime bt -- End of epoch, DA adjustment | isLastInEpoch p = EpochStartTime (_bct $ _blockCreationTime p) -- Within epoch with old legacy DA - | oldDaGuard ver (_chainId p) (_blockHeight p + 1) = _blockEpochStart p + | oldDaGuard (_chainId p) (_blockHeight p + 1) = _blockEpochStart p -- Within an epoch with new DA | otherwise = _blockEpochStart p @@ -561,7 +560,6 @@ epochStart ph@(ParentHeader p) adj (BlockCreationTime bt) -- Experimental, allow DA to support multiple hash functions -- | otherwise = _blockEpochStart p .+^ _adjustmentAvg where - ver = _chainwebVersion p cid = _chainId p -- Add a penalty for fast chains by adding the different between the @@ -580,7 +578,7 @@ epochStart ph@(ParentHeader p) adj (BlockCreationTime bt) -- * Can handle non continuous non uniform distribution of hash power -- accross chains. -- - _adjustmentMax = maximum adjCreationTimes .-. _blockCreationTime p + _adjustmentMax = maximum adjCreationTimes .-. fmap _blockCreationTime ph -- the maximum is at least @_blockCreationTime p@ and thus the result is -- greater or equal 0. @@ -606,81 +604,68 @@ epochStart ph@(ParentHeader p) adj (BlockCreationTime bt) _adjustmentAvg = x `divTimeSpan` length adjCreationTimes where x :: TimeSpan Micros - x = foldr1 addTimeSpan $ (.-. _blockCreationTime p) <$> adjCreationTimes + x = foldr1 addTimeSpan $ (.-. fmap _blockCreationTime ph) <$> adjCreationTimes -- This includes the parent header itself, but excludes any adjacent genesis -- headers which usually don't have accurate creation time. -- -- The result is guaranteed to be non-empty -- - adjCreationTimes = fmap _blockCreationTime - $ HM.insert cid (_parentHeader ph) - $ HM.filter (not . isGenesisBlockHeader) - $ fmap _parentHeader adj + adjCreationTimes = fmap (fmap _blockCreationTime) + $ HM.insert cid ph + $ HM.filter (not . isGenesisBlockHeader . unwrapParent) + $ adj parentIsFirstOnNewChain - = _blockHeight p > 1 && _blockHeight p == genesisHeight ver cid + 1 + = _blockHeight p > 1 && _blockHeight p == genesisHeight cid + 1 {-# INLINE epochStart #-} -- -------------------------------------------------------------------------- -- -- Newtype wrappers for function parameters -newtype ParentCreationTime = ParentCreationTime - { _parentCreationTime :: BlockCreationTime } - deriving stock (Show, Eq, Ord, Generic) - deriving anyclass (NFData) - deriving newtype (ToJSON, FromJSON, Hashable, LeftTorsor) - -newtype ParentHeader = ParentHeader - { _parentHeader :: BlockHeader } - deriving (Show, Eq, Ord, Generic) - deriving anyclass (NFData) - -parentHeader :: Lens' ParentHeader BlockHeader -parentHeader = lens _parentHeader $ \_ hdr -> ParentHeader hdr - -parentHeaderHash :: Getter ParentHeader BlockHash -parentHeaderHash = parentHeader . blockHash - -_rankedParentHash :: ParentHeader -> RankedBlockHash -_rankedParentHash = _rankedBlockHash . _parentHeader - -rankedParentHash :: Getter ParentHeader RankedBlockHash -rankedParentHash = parentHeader . rankedBlockHash - -instance HasChainId ParentHeader where - _chainId = _chainId . _parentHeader - {-# INLINE _chainId #-} - -instance HasChainwebVersion ParentHeader where - _chainwebVersion = _chainwebVersion . _parentHeader - {-# INLINE _chainwebVersion #-} - -instance HasChainGraph ParentHeader where - _chainGraph = _chainGraph . _parentHeader - {-# INLINE _chainGraph #-} - -isGenesisBlockHeader :: BlockHeader -> Bool +isGenesisBlockHeader :: HasVersion => BlockHeader -> Bool isGenesisBlockHeader b = - _blockHeight b == genesisHeight (_chainwebVersion b) (_chainId b) + _blockHeight b == genesisHeight (_chainId b) + +-- Alternate method of detecting a genesis block using only its parent + chain + version +isGenesisBlockHeader' :: HasVersion => ChainId -> Parent BlockHash -> Bool +isGenesisBlockHeader' cid ph = + genesisParentBlockHash cid == ph + +-- The height of a child of the given block. +childBlockHeight :: HasVersion => ChainId -> Parent (Ranked BlockHash) -> BlockHeight +childBlockHeight cid (Parent rbh) + | isGenesisBlockHeader' cid (Parent (_rankedBlockHashHash rbh)) = + _rankedBlockHashHeight rbh + | otherwise = + succ (_rankedBlockHashHeight rbh) + +-- | The height of a parent of the given block. Note that you need the hash of +-- the parent and the height of the child. +parentBlockHeight :: HasVersion => ChainId -> Ranked (Parent BlockHash) -> Parent (Ranked BlockHash) +parentBlockHeight cid (Ranked height parentHash) + | isGenesisBlockHeader' cid parentHash = + Parent $ Ranked height $ unwrapParent parentHash + | otherwise = + Parent $ Ranked (pred height) $ unwrapParent parentHash -- | The genesis block hash includes the Chainweb version and the 'ChainId' -- within the Chainweb version. -- -- It is the '_blockParent' of the genesis block -- -genesisParentBlockHash :: HasChainId p => ChainwebVersion -> p -> BlockHash -genesisParentBlockHash v p = BlockHash $ MerkleLogHash - $ merkleRoot $ merkleTree @ChainwebMerkleHashAlgorithm +genesisParentBlockHash :: (HasVersion, HasChainId p) => p -> Parent BlockHash +genesisParentBlockHash p = Parent $ BlockHash $ MerkleLogHash + $ merkleRoot @ChainwebMerkleHashAlgorithm [ InputNode "CHAINWEB_GENESIS" - , encodeMerkleInputNode encodeChainwebVersionCode (_versionCode v) + , encodeMerkleInputNode encodeChainwebVersionCode (_versionCode implicitVersion) , encodeMerkleInputNode encodeChainId (_chainId p) ] -{-# NOINLINE genesisBlockHeaderCache #-} -genesisBlockHeaderCache :: IORef (HashMap ChainwebVersionCode (HashMap ChainId BlockHeader)) -genesisBlockHeaderCache = unsafePerformIO $ do - newIORef HM.empty +genesisRankedParentBlockHash :: (HasVersion, HasChainId p) => p -> Parent RankedBlockHash +genesisRankedParentBlockHash p = Parent $ RankedBlockHash + (genesisHeight (_chainId p)) + (unwrapParent $ genesisParentBlockHash p) -- | A block chain is globally uniquely identified by its genesis hash. -- Internally, we use the 'ChainwebVersionTag value and the 'ChainId' @@ -694,26 +679,21 @@ genesisBlockHeaders :: ChainwebVersion -> HashMap ChainId BlockHeader genesisBlockHeaders = \v -> if _versionCode v == _versionCode mainnet then mainnetGenesisHeaders else if _versionCode v == _versionCode testnet04 then testnetGenesisHeaders - else unsafeDupablePerformIO $ - HM.lookup (_versionCode v) <$> readIORef genesisBlockHeaderCache >>= \case - Just hs -> return hs - Nothing -> do - let freshGenesisHeaders = makeGenesisBlockHeaders v - modifyIORef' genesisBlockHeaderCache $ HM.insert (_versionCode v) freshGenesisHeaders - return freshGenesisHeaders - where - mainnetGenesisHeaders = makeGenesisBlockHeaders mainnet - testnetGenesisHeaders = makeGenesisBlockHeaders testnet04 + else withVersion v makeGenesisBlockHeaders + where + mainnetGenesisHeaders = withVersion mainnet makeGenesisBlockHeaders + testnetGenesisHeaders = withVersion testnet04 makeGenesisBlockHeaders -genesisBlockHeader :: (HasCallStack, HasChainId p) => ChainwebVersion -> p -> BlockHeader -genesisBlockHeader v p = genesisBlockHeaders v ^?! ix (_chainId p) +genesisBlockHeader :: (HasCallStack, HasChainId p, HasVersion) => p -> BlockHeader +genesisBlockHeader p = genesisBlockHeaders implicitVersion ^?! at (_chainId p) . _Just -makeGenesisBlockHeaders :: ChainwebVersion -> HashMap ChainId BlockHeader -makeGenesisBlockHeaders v = HM.fromList [ (cid, makeGenesisBlockHeader v cid) | cid <- HS.toList (chainIds v)] +makeGenesisBlockHeaders :: HasVersion => HashMap ChainId BlockHeader +makeGenesisBlockHeaders = + HM.fromList [ (cid, makeGenesisBlockHeader cid) | cid <- HS.toList chainIds] -makeGenesisBlockHeader :: ChainwebVersion -> ChainId -> BlockHeader -makeGenesisBlockHeader v cid = - makeGenesisBlockHeader' v cid (_genesisTime (_versionGenesis v) ^?! atChain cid) (Nonce 0) +makeGenesisBlockHeader :: HasVersion => ChainId -> BlockHeader +makeGenesisBlockHeader cid = + makeGenesisBlockHeader' cid (_genesisTime (_versionGenesis implicitVersion) ^?! atChain cid) (Nonce 0) -- | Like `genesisBlockHeader`, but with slightly more control. -- @@ -722,42 +702,41 @@ makeGenesisBlockHeader v cid = -- building the Merkle tree. -- makeGenesisBlockHeader' - :: HasChainId p - => ChainwebVersion - -> p + :: (HasChainId p, HasVersion) + => p -> BlockCreationTime -> Nonce -> BlockHeader -makeGenesisBlockHeader' v p ct@(BlockCreationTime t) n = +makeGenesisBlockHeader' p ct@(BlockCreationTime t) n = fromLog @ChainwebMerkleHashAlgorithm mlog where - (h, g) = genesisHeightAndGraph v p + (h, g) = genesisHeightAndGraph p cid = _chainId p mlog = newMerkleLog $ genesisForkState :+: ct - :+: genesisParentBlockHash v cid - :+: (v ^?! versionGenesis . genesisBlockTarget . atChain cid) - :+: genesisBlockPayloadHash v cid + :+: genesisParentBlockHash cid + :+: (implicitVersion ^?! versionGenesis . genesisBlockTarget . atChain cid) + :+: genesisBlockPayloadHash cid :+: cid :+: BlockWeight 0 :+: h -- because of chain graph changes (new chains) not all chains start at 0 - :+: _versionCode v + :+: _versionCode implicitVersion :+: EpochStartTime t :+: n :+: MerkleLogBody (blockHashRecordToVector adjParents) adjParents = BlockHashRecord $ HM.fromList $ - (\c -> (c, genesisParentBlockHash v c)) <$> HS.toList (adjacentChainIds g p) + (\c -> (c, genesisParentBlockHash c)) <$> HS.toList (adjacentChainIds g p) -- | The set of genesis block headers as it exited at a particular block height -- genesisBlockHeadersAtHeight - :: ChainwebVersion - -> BlockHeight + :: HasVersion + => BlockHeight -> HashMap ChainId BlockHeader -genesisBlockHeadersAtHeight v h = - HM.filter (\hdr -> _blockHeight hdr <= h) (genesisBlockHeaders v) +genesisBlockHeadersAtHeight h = + HM.filter (\hdr -> _blockHeight hdr <= h) (genesisBlockHeaders implicitVersion) -- -- -------------------------------------------------------------------------- -- -- Genesis Height @@ -770,16 +749,16 @@ genesisBlockHeadersAtHeight v h = -- (We generally assume that this invariant holds throughout the code base. -- It is enforced via the 'mkChainId' smart constructor for ChainId.) -- -genesisHeight :: HasCallStack => ChainwebVersion -> ChainId -> BlockHeight -genesisHeight v c = _blockHeight (genesisBlockHeader v c) +genesisHeight :: (HasVersion, HasCallStack) => ChainId -> BlockHeight +genesisHeight c = genesisBlockHeight c -instance HasMerkleLog ChainwebMerkleHashAlgorithm ChainwebHashTag BlockHeader where +instance HasVersion => HasMerkleLog ChainwebMerkleHashAlgorithm ChainwebHashTag BlockHeader where -- /IMPORTANT/ a types must occur at most once in this list type MerkleLogHeader BlockHeader = '[ ForkState , BlockCreationTime - , BlockHash + , Parent BlockHash , HashTarget , BlockPayloadHash , ChainId @@ -789,7 +768,7 @@ instance HasMerkleLog ChainwebMerkleHashAlgorithm ChainwebHashTag BlockHeader wh , EpochStartTime , Nonce ] - type MerkleLogBody BlockHeader = BlockHash + type MerkleLogBody BlockHeader = Parent BlockHash toLog bh = merkleLog @ChainwebMerkleHashAlgorithm root entries where @@ -837,17 +816,16 @@ instance HasMerkleLog ChainwebMerkleHashAlgorithm ChainwebHashTag BlockHeader wh :+: nonce :+: MerkleLogBody adjParents ) = _merkleLogEntries l - cwv = lookupVersionByCode cwvc adjGraph - | height == genesisBlockHeight cwv cid = chainGraphAt cwv height - | otherwise = chainGraphAt cwv (height - 1) + | height == genesisBlockHeight cid = chainGraphAt height + | otherwise = chainGraphAt (height - 1) encodeBlockHeaderWithoutHash :: BlockHeader -> Put encodeBlockHeaderWithoutHash b = do encodeForkState (_blockFlags b) encodeBlockCreationTime (_blockCreationTime b) - encodeBlockHash (_blockParent b) + encodeBlockHash (unwrapParent $ _blockParent b) encodeBlockHashRecord (_blockAdjacentHashes b) encodeHashTarget (_blockTarget b) encodeBlockPayloadHash (_blockPayloadHash b) @@ -863,12 +841,43 @@ encodeBlockHeader b = do encodeBlockHeaderWithoutHash b encodeBlockHash (_blockHash b) +-- | Encode the block header as a mining work value. +-- +-- NOTE: The legacy format of this is just the block header without the block +-- hash. With the legacy format the size and layout of the mining work depended +-- on the chain graph. The new format has a fixed size and layout that matches +-- the format that has been used in Mainnet01 and Testnet04 since genesis. +-- +encodeAsMiningWork :: HasVersion => BlockHeader -> Put +encodeAsMiningWork b = do + encodeForkState (_blockFlags b) + encodeBlockCreationTime (_blockCreationTime b) + encodeBlockHash (unwrapParent $ _blockParent b) + + if hashedAdjacentRecord (_chainId b) (_blockHeight b) + then do + encodeWordLe @Word16 0xf0f0 + replicateM_ 3 $ do + encodeWordLe @Word32 0 + encodeAdjacentsHash (adjacentsHash $ _blockAdjacentHashes b) + else do + encodeBlockHashRecord (_blockAdjacentHashes b) + + encodeHashTarget (_blockTarget b) + encodeBlockPayloadHash (_blockPayloadHash b) + encodeChainId (_blockChainId b) + encodeBlockWeight (_blockWeight b) + encodeBlockHeight (_blockHeight b) + encodeChainwebVersionCode (_blockChainwebVersion b) + encodeEpochStartTime (_blockEpochStart b) + encodeNonce (_blockNonce b) + -- | Decode and check that -- -- 1. chain id is in graph -- 2. all adjacentParent match adjacents in graph -- -decodeBlockHeaderChecked :: Get BlockHeader +decodeBlockHeaderChecked :: HasVersion => Get BlockHeader decodeBlockHeaderChecked = do !bh <- decodeBlockHeader _ <- checkAdjacentChainIds bh bh (Expected $ _blockAdjacentChainIds bh) @@ -881,7 +890,7 @@ decodeBlockHeaderChecked = do -- 3. chainId matches the expected chain id -- decodeBlockHeaderCheckedChainId - :: HasChainId p + :: (HasVersion, HasChainId p) => Expected p -> Get BlockHeader decodeBlockHeaderCheckedChainId p = do @@ -891,11 +900,11 @@ decodeBlockHeaderCheckedChainId p = do -- | Decode a BlockHeader and trust the result -- -decodeBlockHeaderWithoutHash :: Get BlockHeader +decodeBlockHeaderWithoutHash :: HasVersion => Get BlockHeader decodeBlockHeaderWithoutHash = do a0 <- decodeForkState a1 <- decodeBlockCreationTime - a2 <- decodeBlockHash -- parent hash + a2 <- Parent <$> decodeBlockHash a3 <- decodeBlockHashRecord a4 <- decodeHashTarget a5 <- decodeBlockPayloadHash @@ -927,7 +936,7 @@ decodeBlockHeader :: Get BlockHeader decodeBlockHeader = BlockHeader <$> decodeForkState <*> decodeBlockCreationTime - <*> decodeBlockHash -- parent hash + <*> (Parent <$> decodeBlockHash) <*> decodeBlockHashRecord <*> decodeHashTarget <*> decodeBlockPayloadHash @@ -962,7 +971,7 @@ blockAdjacentChainIds = to _blockAdjacentChainIds -- throws a @ChainNotAdjacentException@ if @cid@ is not adajcent with @_chainId -- h@ in the chain graph of @h@. -- -getAdjacentHash :: MonadThrow m => HasChainId p => p -> BlockHeader -> m BlockHash +getAdjacentHash :: MonadThrow m => HasChainId p => p -> BlockHeader -> m (Parent BlockHash) getAdjacentHash p b = firstOf (blockAdjacentHashes . ixg (_chainId p)) b ??? ChainNotAdjacentException (_chainId b) @@ -970,7 +979,7 @@ getAdjacentHash p b = firstOf (blockAdjacentHashes . ixg (_chainId p)) b (Actual $ _blockAdjacentChainIds b) {-# INLINE getAdjacentHash #-} -computeBlockHash :: BlockHeader -> BlockHash +computeBlockHash :: HasVersion => BlockHeader -> BlockHash computeBlockHash h = BlockHash $ MerkleLogHash $ computeMerkleLogRoot h {-# INLINE computeBlockHash #-} @@ -978,11 +987,11 @@ computeBlockHash h = BlockHash $ MerkleLogHash $ computeMerkleLogRoot h -- '_blockHash'. The value (interpreted as 'BlockHashNat' must be smaller than -- the value of '_blockTarget' (interpreted as 'BlockHashNat'). -- -_blockPow :: BlockHeader -> PowHash +_blockPow :: HasVersion => BlockHeader -> PowHash _blockPow h = cryptoHash @Blake2s_256 - $ runPutS $ encodeBlockHeaderWithoutHash h + $ runPutS $ encodeAsMiningWork h -blockPow :: Getter BlockHeader PowHash +blockPow :: HasVersion => Getter BlockHeader PowHash blockPow = to _blockPow {-# INLINE blockPow #-} @@ -1017,7 +1026,8 @@ newtype ExtendedObjectEncoded a = ExtendedObjectEncoded { _extendedObjectEncoded deriving newtype (Eq, Ord, Hashable, NFData) blockHeaderProperties - :: KeyValue e kv + :: HasVersion + => KeyValue e kv => ObjectEncoded BlockHeader -> [kv] blockHeaderProperties (ObjectEncoded b) = @@ -1030,7 +1040,7 @@ blockHeaderProperties (ObjectEncoded b) = , "chainId" .= _chainId b , "weight" .= _blockWeight b , "height" .= _blockHeight b - , "chainwebVersion" .= _versionName (_chainwebVersion b) + , "chainwebVersion" .= _versionName implicitVersion , "epochStart" .= _blockEpochStart b , "featureFlags" .= _blockFlags b , "hash" .= _blockHash b @@ -1038,7 +1048,8 @@ blockHeaderProperties (ObjectEncoded b) = {-# INLINE blockHeaderProperties #-} extendedBlockHeaderProperties - :: KeyValue e kv + :: HasVersion + => KeyValue e kv => ExtendedObjectEncoded BlockHeader -> [kv] extendedBlockHeaderProperties (ExtendedObjectEncoded b) = @@ -1049,13 +1060,13 @@ extendedBlockHeaderProperties (ExtendedObjectEncoded b) = ] {-# INLINE extendedBlockHeaderProperties #-} -instance ToJSON (ObjectEncoded BlockHeader) where +instance HasVersion => ToJSON (ObjectEncoded BlockHeader) where toJSON = object . blockHeaderProperties toEncoding = pairs . mconcat . blockHeaderProperties {-# INLINE toJSON #-} {-# INLINE toEncoding #-} -parseBlockHeaderObject :: Object -> Parser BlockHeader +parseBlockHeaderObject :: HasVersion => Object -> Parser BlockHeader parseBlockHeaderObject o = BlockHeader <$> o .: "featureFlags" <*> o .: "creationTime" @@ -1068,17 +1079,25 @@ parseBlockHeaderObject o = BlockHeader <*> o .: "height" -- TODO: lookupVersionByName should probably be deprecated for performance, -- so perhaps we move this codec outside of the node proper. - <*> (_versionCode . lookupVersionByName <$> (o .: "chainwebVersion")) + <*> parseVersionCode <*> o .: "epochStart" <*> o .: "nonce" <*> o .: "hash" - -instance FromJSON (ObjectEncoded BlockHeader) where + where + parseVersionCode = do + v <- o .: "chainwebVersion" + if _versionName implicitVersion == v + then return (_versionCode implicitVersion) + else fail $ T.unpack + $ "invalid chainwebversion. expected " <> getChainwebVersionName (_versionName implicitVersion) + <> ", got " <> getChainwebVersionName v + +instance HasVersion => FromJSON (ObjectEncoded BlockHeader) where parseJSON = withObject "BlockHeader" $ fmap ObjectEncoded . parseBlockHeaderObject {-# INLINE parseJSON #-} -instance ToJSON (ExtendedObjectEncoded BlockHeader) where +instance HasVersion => ToJSON (ExtendedObjectEncoded BlockHeader) where toJSON = object . extendedBlockHeaderProperties toEncoding = pairs . mconcat . extendedBlockHeaderProperties {-# INLINE toJSON #-} @@ -1104,21 +1123,21 @@ blockForkVotes = blockForkState . forkVotes -- | Returns whether a block is the first block in a fork epoch. -- -isForkEpochStart :: ChainwebVersion -> BlockHeight -> Bool -isForkEpochStart v h = - rem (int h) (forkEpochLength v) == 0 +isForkEpochStart :: HasVersion => BlockHeight -> Bool +isForkEpochStart h = + rem (int h) forkEpochLength == 0 -- | Returns whether a block is at a height at which voting occurs. -- -isForkVoteBlock :: ChainwebVersion -> BlockHeight -> Bool -isForkVoteBlock v h = - rem (int h) (forkEpochLength v) - < _versionForkVoteCastingLength v +isForkVoteBlock :: HasVersion => BlockHeight -> Bool +isForkVoteBlock h = + rem (int h) forkEpochLength + < _versionForkVoteCastingLength implicitVersion -- | Returns whether a block is at a height at which vote couting occurs. -- -isForkCountBlock :: ChainwebVersion -> BlockHeight -> Bool -isForkCountBlock v h = not (isForkVoteBlock v h) +isForkCountBlock :: HasVersion => BlockHeight -> Bool +isForkCountBlock h = not (isForkVoteBlock h) -- | New Fork State computation -- @@ -1128,36 +1147,36 @@ isForkCountBlock v h = not (isForkVoteBlock v h) -- * forkCountBlock -> forkVotes are deterministically set -- newForkState - :: HM.HashMap ChainId ParentHeader + :: HasVersion + => HM.HashMap ChainId (Parent BlockHeader) -- ^ Adjacent parent headers - -> ParentHeader + -> Parent BlockHeader -- Parent block header -> ForkNumber -- ^ Target fork number. Vote "yes" to increase fork number, if the fork -- number of the parent header is less than this value. -> ForkState newForkState as p targetFork - | isForkEpochStart v (succ $ view (parentHeader . blockHeight) p) = cur + | isForkEpochStart (succ $ view (_Parent . blockHeight) p) = cur -- reset votes and vote -- There is probably a bug here, when we increase the fork number. -- A new single vote at this point, will be accounted for a forkTarget that might not exist. -- But hopefuklly, most of the time it will have no impact. & forkVotes .~ (if vote then addVote resetVotes else resetVotes) -- based on current vote count decide whether to increase fork number - & forkNumber %~ (if decideVotes v curVotes then succ else id) - | isForkVoteBlock v (succ $ view (parentHeader . blockHeight) p) = cur + & forkNumber %~ (if decideVotes curVotes then succ else id) + | isForkVoteBlock (succ $ view (_Parent . blockHeight) p) = cur -- vote & forkVotes %~ (if vote then addVote else id) | otherwise = cur -- do one vote counting step & forkVotes .~ countVotes allParentVotes where - v = _chainwebVersion p vote = curNumber < targetFork - cur = view (parentHeader . blockForkState) p - curNumber = view (parentHeader . blockForkNumber) p - curVotes = view (parentHeader . blockForkVotes) p - allParentVotes = view (parentHeader . blockForkVotes) <$> (p : HM.elems as) + cur = view (_Parent . blockForkState) p + curNumber = view (_Parent . blockForkNumber) p + curVotes = view (_Parent . blockForkVotes) p + allParentVotes = view (_Parent . blockForkVotes) <$> (p : HM.elems as) genesisForkState :: ForkState genesisForkState = ForkState 0 @@ -1197,10 +1216,11 @@ instance IsBlockHeader BlockHeader where -- but might be worth it! -- newBlockHeader - :: ForkNumber + :: HasVersion + => ForkNumber -- ^ Target fork number. Forks will be voted "yes" until this fork -- number is reached. - -> HM.HashMap ChainId ParentHeader + -> HM.HashMap ChainId (Parent BlockHeader) -- ^ Adjacent parent hashes. The hash and the PoW target of these are -- needed for construction the new header. -> BlockPayloadHash @@ -1210,39 +1230,41 @@ newBlockHeader -- nonce is valid with respect to the target. -> BlockCreationTime -- ^ Creation time of the block. - -> ParentHeader + -> Parent BlockHeader -- ^ parent block header -> BlockHeader -newBlockHeader targetFork adj pay nonce t p@(ParentHeader b) = +newBlockHeader targetFork adj pay nonce t p@(Parent b) = fromLog @ChainwebMerkleHashAlgorithm $ newMerkleLog $ newForkState adj p targetFork :+: t - :+: _blockHash b + :+: Parent (_blockHash b) :+: target :+: pay :+: cid :+: _blockWeight b + BlockWeight (targetToDifficulty target) :+: _blockHeight b + 1 - :+: _versionCode v + :+: _versionCode implicitVersion :+: epochStart p adj t :+: nonce :+: MerkleLogBody (blockHashRecordToVector adjHashes) where cid = _chainId p - v = _chainwebVersion p target = powTarget p adj t - adjHashes = BlockHashRecord $ _blockHash . _parentHeader <$> adj + adjHashes = BlockHashRecord $ fmap _blockHash <$> adj -- -------------------------------------------------------------------------- -- -- TreeDBEntry instance -instance TreeDbEntry BlockHeader where +instance HasVersion => TreeDbEntry BlockHeader where type Key BlockHeader = BlockHash key = _blockHash rank = int . _blockHeight parent e | isGenesisBlockHeader e = Nothing - | otherwise = Just (_blockParent e) + | otherwise = Just (unwrapParent $ _blockParent e) + +instance IsRanked BlockHeader where + rank = _blockHeight -- -------------------------------------------------------------------------- -- -- Misc @@ -1257,9 +1279,10 @@ instance TreeDbEntry BlockHeader where -- Note that for all but genesis headers the number of adjacent hashes depends -- on the graph of the parent. -- -headerSizes :: ChainwebVersion -> Rule BlockHeight Natural -headerSizes v = (\g -> _versionHeaderBaseSizeBytes v + 36 * degree g + 2) - <$> _versionGraphs v +headerSizes :: HasVersion => Rule BlockHeight Natural +headerSizes = + fmap (\g -> _versionHeaderBaseSizeBytes implicitVersion + 36 * degree g + 2) + $ _versionGraphs implicitVersion -- | The size of the serialized block header. -- @@ -1270,18 +1293,17 @@ headerSizes v = (\g -> _versionHeaderBaseSizeBytes v + 36 * degree g + 2) -- on the graph of the parent. -- headerSizeBytes - :: HasCallStack - => ChainwebVersion - -> ChainId + :: (HasCallStack, HasVersion) + => ChainId -> BlockHeight -> Natural -headerSizeBytes v cid h = snd +headerSizeBytes cid h = snd $ ruleHead $ ruleDropWhile (> relevantHeight) - $ headerSizes v + $ headerSizes where relevantHeight - | genesisHeight v cid == h = h + | genesisHeight cid == h = h | otherwise = h - 1 -- | The size of the work bytes /without/ the preamble of the chain id and target @@ -1295,12 +1317,17 @@ headerSizeBytes v cid h = snd -- given chainweb version. This would only ever change as part of the -- introduction of new block header format. -- +-- TODO: we should probably just make this a global constant, fix all tests and +-- call it a day. +-- workSizeBytes - :: HasCallStack - => ChainwebVersion - -> BlockHeight + :: (HasCallStack, HasVersion) + => BlockHeight -> Natural -workSizeBytes v h = headerSizeBytes v (unsafeChainId 0) h - 32 +workSizeBytes h + | hashedAdjacentRecord (unsafeChainId 0) h = + _versionHeaderBaseSizeBytes implicitVersion + 36 * 3 + 2 - 32 + | otherwise = headerSizeBytes (unsafeChainId 0) h - 32 _rankedBlockHash :: BlockHeader -> RankedBlockHash _rankedBlockHash h = RankedBlockHash diff --git a/src/Chainweb/BlockHeader/Validation.hs b/src/Chainweb/BlockHeader/Validation.hs index 5edb68ab0a..d76db3758a 100644 --- a/src/Chainweb/BlockHeader/Validation.hs +++ b/src/Chainweb/BlockHeader/Validation.hs @@ -116,6 +116,7 @@ import Chainweb.BlockHeader import Chainweb.ChainId import Chainweb.ChainValue import Chainweb.Difficulty +import Chainweb.Parent import Chainweb.Time import Chainweb.Utils import Chainweb.Version @@ -135,11 +136,7 @@ instance HasChainId ValidatedHeader where _chainId = _chainId . _validatedHeader {-# INLINE _chainId #-} -instance HasChainwebVersion ValidatedHeader where - _chainwebVersion = _chainwebVersion . _validatedHeader - {-# INLINE _chainwebVersion #-} - -instance HasChainGraph ValidatedHeader where +instance HasVersion => HasChainGraph ValidatedHeader where _chainGraph = _chainGraph . _validatedHeader {-# INLINE _chainGraph #-} @@ -182,8 +179,8 @@ _validatedHeaders (ValidatedHeaders hs) = hs -- data InvalidValidationParameters - = InvalidChainStepParameters ParentHeader BlockHeader - | InvalidWebStepParameters (HM.HashMap ChainId ParentHeader) ChainStep + = InvalidChainStepParameters (Parent BlockHeader) BlockHeader + | InvalidWebStepParameters (HM.HashMap ChainId (Parent BlockHeader)) ChainStep deriving (Show, Eq, Ord, Generic) instance Exception InvalidValidationParameters where @@ -198,10 +195,10 @@ instance Exception InvalidValidationParameters where -- -- NOTE: the constructor of this type is intentionally NOT exported. -- -data ChainStep = ChainStep ParentHeader BlockHeader +data ChainStep = ChainStep (Parent BlockHeader) BlockHeader deriving (Show, Eq, Ord, Generic) -_chainStepParent :: ChainStep -> ParentHeader +_chainStepParent :: ChainStep -> Parent BlockHeader _chainStepParent (ChainStep p _) = p {-# INLINE _chainStepParent #-} @@ -211,13 +208,13 @@ _chainStepHeader (ChainStep _ h) = h chainStep :: MonadThrow m - => ParentHeader + => Parent BlockHeader -- ^ Parent block header. The genesis header is considered its own parent. -> BlockHeader -- ^ Block header under scrutiny -> m ChainStep chainStep p b - | view blockParent b == view blockHash (_parentHeader p) + | view blockParent b == fmap (view blockHash) p = return $ ChainStep p b | otherwise = throwM $ InvalidChainStepParameters p b @@ -230,27 +227,27 @@ chainStep p b -- -- NOTE: the constructor of this type is intentionally NOT exported. -- -data WebStep = WebStep (HM.HashMap ChainId ParentHeader) ChainStep +data WebStep = WebStep (HM.HashMap ChainId (Parent BlockHeader)) ChainStep deriving (Show, Eq, Ord, Generic) webStep :: MonadThrow m - => HM.HashMap ChainId ParentHeader + => HM.HashMap ChainId (Parent BlockHeader) -> ChainStep -> m WebStep webStep as hp@(ChainStep _ h) = WebStep <$> itraverse f hashes <*> pure hp where - hashes :: HM.HashMap ChainId BlockHash + hashes :: HM.HashMap ChainId (Parent BlockHash) hashes = view (blockAdjacentHashes . getBlockHashRecord) h f cid a = case HM.lookup cid as of Nothing -> throwM $ InvalidWebStepParameters as hp Just x - | view blockHash (_parentHeader x) == a -> return x + | fmap (view blockHash) x == a -> return x | otherwise -> throwM $ InvalidWebStepParameters as hp -_webStepAdjs :: WebStep -> HM.HashMap ChainId ParentHeader +_webStepAdjs :: WebStep -> HM.HashMap ChainId (Parent BlockHeader) _webStepAdjs (WebStep as _) = as {-# INLINE _webStepAdjs #-} @@ -262,7 +259,7 @@ _webStepHeader :: WebStep -> BlockHeader _webStepHeader (WebStep _ p) = _chainStepHeader p {-# INLINE _webStepHeader #-} -_webStepParent :: WebStep -> ParentHeader +_webStepParent :: WebStep -> Parent BlockHeader _webStepParent (WebStep _ p) = _chainStepParent p {-# INLINE _webStepParent #-} @@ -272,8 +269,8 @@ _webStepParent (WebStep _ p) = _chainStepParent p -- | A data type that describes a failure of validating a block header. -- data ValidationFailure = ValidationFailure - { _validateFailureParent :: !(Maybe ParentHeader) - , _validateFailureAdjecents :: !(Maybe (HM.HashMap ChainId ParentHeader)) + { _validateFailureParent :: !(Maybe (Parent BlockHeader)) + , _validateFailureAdjecents :: !(Maybe (HM.HashMap ChainId (Parent BlockHeader))) , _validateFailureHeader :: !BlockHeader , _validationFailureFailures :: ![ValidationFailureType] } @@ -290,13 +287,13 @@ webStepFailure hp = ValidationFailure (Just $ _webStepAdjs hp) (_webStepHeader hp) -instance Show ValidationFailure where +instance HasVersion => Show ValidationFailure where show (ValidationFailure p as e ts) = T.unpack $ "Validation failure" <> ". Description: " <> T.unlines (map description ts) <> ". Header: " <> encodeToText (ObjectEncoded e) - <> maybe "" (\p' -> ". Parent: " <> encodeToText (ObjectEncoded $ _parentHeader p')) p - <> maybe "" (\as' -> ". Adjacents: " <> encodeToText (ObjectEncoded . _parentHeader <$> as')) as + <> maybe "" (\p' -> ". Parent: " <> encodeToText (ObjectEncoded $ unwrapParent p')) p + <> maybe "" (\as' -> ". Adjacents: " <> encodeToText (ObjectEncoded . unwrapParent <$> as')) as where description t = case t of MissingParent -> "Parent isn't in the database" @@ -403,7 +400,7 @@ data ValidationFailureType -- epoch. deriving (Show, Eq, Ord) -instance Exception ValidationFailure +instance HasVersion => Exception ValidationFailure -- | The list of validation failures that are definite and independent of any -- external context. A block for which validation fails with one of these @@ -471,7 +468,7 @@ isEphemeral failures -- * IncorrectPayloadHash -- validateBlockHeaderM - :: MonadThrow m + :: (MonadThrow m, HasVersion) => Time Micros -- ^ The current clock time -> (ChainValue BlockHash -> m (Maybe BlockHeader)) @@ -499,7 +496,7 @@ validateBlockHeaderM t lookupHeader h = -- * IncorrectPayloadHash -- validateBlockHeadersM - :: MonadThrow m + :: (MonadThrow m, HasVersion) => Time Micros -- ^ The current clock time -> (ChainValue BlockHash -> m (Maybe BlockHeader)) @@ -527,7 +524,7 @@ validateBlockHeadersM t lookupHeader as = do -- performed -- validateIntrinsicM - :: MonadThrow m + :: (MonadThrow m, HasVersion) => Time Micros -- ^ The current clock time -> BlockHeader @@ -545,7 +542,7 @@ validateIntrinsicM t e = unless (null failures) -- performed -- validateInductiveChainM - :: MonadThrow m + :: (MonadThrow m, HasVersion) => (BlockHash -> m (Maybe BlockHeader)) -- ^ Context of Validated BlockHeaders -> BlockHeader @@ -570,14 +567,14 @@ validateInductiveChainM lookupHeader h = -- Returns the parent if it exists or an validation failure otherwise. -- validateBlockParentExists - :: Monad m + :: (Monad m, HasVersion) => (BlockHash -> m (Maybe BlockHeader)) -> BlockHeader -> m (Either ValidationFailureType ChainStep) validateBlockParentExists lookupParent h - | isGenesisBlockHeader h = return $ Right $ ChainStep (ParentHeader h) h - | otherwise = lookupParent (view blockParent h) >>= \case - (Just !p) -> return $ Right $ ChainStep (ParentHeader p) h + | isGenesisBlockHeader h = return $ Right $ ChainStep (Parent h) h + | otherwise = lookupParent (unwrapParent $ view blockParent h) >>= \case + (Just !p) -> return $ Right $ ChainStep (Parent p) h Nothing -> return $ Left MissingParent -- | Validate that the parent and all adjacent parents exist with the given @@ -586,7 +583,7 @@ validateBlockParentExists lookupParent h -- Returns the parents if they exist or an validation failure otherwise. -- validateAllParentsExist - :: Monad m + :: (Monad m, HasVersion) => (ChainValue BlockHash -> m (Maybe BlockHeader)) -> BlockHeader -> m (Either ValidationFailureType WebStep) @@ -595,12 +592,11 @@ validateAllParentsExist lookupParent h = runExceptT $ WebStep <*> ExceptT (validateBlockParentExists lookupOnChain h) where lookupOnChain = lookupParent . ChainValue (_chainId h) - v = _chainwebVersion h f c ph - | genesisParentBlockHash v c == ph = return - $ ParentHeader $ genesisBlockHeader v c - | otherwise = lift (lookupParent $ ChainValue c ph) >>= \case - (Just !p) -> return $ ParentHeader p + | genesisParentBlockHash c == ph = return + $ Parent $ genesisBlockHeader c + | otherwise = lift (lookupParent $ fmap unwrapParent $ ChainValue c ph) >>= \case + (Just !p) -> return $ Parent p Nothing -> throwError MissingAdjacentParent -- -------------------------------------------------------------------------- -- @@ -615,7 +611,8 @@ validateAllParentsExist lookupParent h = runExceptT $ WebStep -- * IncorrectPayloadHash -- isValidBlockHeader - :: Time Micros + :: HasVersion + => Time Micros -- ^ The current clock time -> WebStep -> Bool @@ -631,7 +628,8 @@ isValidBlockHeader t p = null $ validateBlockHeader t p -- * IncorrectPayloadHash -- validateBlockHeader - :: Time Micros + :: HasVersion + => Time Micros -- ^ The current clock time -> WebStep -> [ValidationFailureType] @@ -647,7 +645,8 @@ validateBlockHeader t p -- without observing the remainder of the database. -- validateIntrinsic - :: Time Micros + :: HasVersion + => Time Micros -- ^ The current clock time -> BlockHeader -- ^ block header to be validated @@ -667,7 +666,8 @@ validateIntrinsic t b = concat -- | Validate properties of a block with respect to a given parent. -- validateInductive - :: WebStep + :: HasVersion + => WebStep -> [ValidationFailureType] -- ^ A list of ways in which the block header isn't valid validateInductive ps @@ -675,7 +675,8 @@ validateInductive ps <> validateInductiveWebStep ps validateInductiveChainStep - :: ChainStep + :: HasVersion + => ChainStep -- ^ parent block header. The genesis header is considered its own parent. -> [ValidationFailureType] -- ^ A list of ways in which the block header isn't valid @@ -689,7 +690,8 @@ validateInductiveChainStep s = concat ] validateInductiveWebStep - :: WebStep + :: HasVersion + => WebStep -- ^ parent block header. The genesis header is considered its own parent. -> [ValidationFailureType] -- ^ A list of ways in which the block header isn't valid @@ -707,62 +709,60 @@ validateInductiveWebStep s = concat -- Intrinsic BlockHeader properties -- -------------------------------------------------------------------------- -- -prop_block_pow :: BlockHeader -> Bool +prop_block_pow :: HasVersion => BlockHeader -> Bool prop_block_pow b | isGenesisBlockHeader b = True -- Genesis block headers are not mined. So there's not need for POW - | b ^. chainwebVersion . versionCheats . disablePow = True + | implicitVersion ^. versionCheats . disablePow = True | otherwise = checkTarget (view blockTarget b) (view blockPow b) -prop_block_hash :: BlockHeader -> Bool +prop_block_hash :: HasVersion => BlockHeader -> Bool prop_block_hash b = view blockHash b == computeBlockHash b -prop_block_genesis_parent :: BlockHeader -> Bool +prop_block_genesis_parent :: HasVersion => BlockHeader -> Bool prop_block_genesis_parent b = isGenesisBlockHeader b ==> hasGenesisParentHash b && hasGenesisParentHash b ==> isGenesisBlockHeader b where hasGenesisParentHash b' = - view blockParent b' == genesisParentBlockHash (_chainwebVersion b') (_chainId b') + view blockParent b' == genesisParentBlockHash (_chainId b') -prop_block_genesis_target :: BlockHeader -> Bool +prop_block_genesis_target :: HasVersion => BlockHeader -> Bool prop_block_genesis_target b = isGenesisBlockHeader b - ==> view blockTarget b == _chainwebVersion b ^?! versionGenesis . genesisBlockTarget . atChain (_chainId b) + ==> view blockTarget b == implicitVersion ^?! versionGenesis . genesisBlockTarget . atChain (_chainId b) prop_block_current :: Time Micros -> BlockHeader -> Bool prop_block_current t b = BlockCreationTime t >= view blockCreationTime b --- prop_block_featureFlags :: BlockHeader -> Bool --- prop_block_featureFlags b --- | skipFeatureFlagValidationGuard v cid h = True --- | otherwise = view blockFlags b == mkFeatureFlags --- where --- v = _chainwebVersion b --- h = view blockHeight b --- cid = _chainId b +_prop_block_featureFlags :: HasVersion => BlockHeader -> Bool +_prop_block_featureFlags b + | skipFeatureFlagValidationGuard cid h = True + | otherwise = view blockFlags b == ForkState 0 + where + h = view blockHeight b + cid = _chainId b -- | Verify that the adjacent hashes of the block are for the correct set of -- chain ids. -- -prop_block_adjacent_chainIds :: BlockHeader -> Bool +prop_block_adjacent_chainIds :: HasVersion => BlockHeader -> Bool prop_block_adjacent_chainIds b = isJust $ checkAdjacentChainIds adjGraph b (Expected $ view blockAdjacentChainIds b) where adjGraph | isGenesisBlockHeader b = _chainGraph b - | otherwise = chainGraphAt (_chainwebVersion b) (view blockHeight b - 1) + | otherwise = chainGraphAt (view blockHeight b - 1) -- | Validate that fork votes are reset at the start of a fork epoch. -- -prop_block_forkVotesReset :: BlockHeader -> Bool +prop_block_forkVotesReset :: HasVersion => BlockHeader -> Bool prop_block_forkVotesReset b - | skipFeatureFlagValidationGuard v cid h = True - | isForkEpochStart v h = + | skipFeatureFlagValidationGuard cid h = True + | isForkEpochStart h = votes == resetVotes || votes == addVote resetVotes | otherwise = True where votes = view blockForkVotes b - v = _chainwebVersion b h = view blockHeight b cid = _chainId b @@ -773,113 +773,109 @@ prop_block_forkVotesReset b -- -------------------------------------------------------------------------- -- -- Single chain inductive properties -prop_block_height :: ChainStep -> Bool -prop_block_height (ChainStep (ParentHeader p) b) +prop_block_height :: HasVersion => ChainStep -> Bool +prop_block_height (ChainStep (Parent p) b) | isGenesisBlockHeader b = view blockHeight b == view blockHeight p | otherwise = view blockHeight b == view blockHeight p + 1 prop_block_chainwebVersion :: ChainStep -> Bool -prop_block_chainwebVersion (ChainStep (ParentHeader p) b) = +prop_block_chainwebVersion (ChainStep (Parent p) b) = view blockChainwebVersion p == view blockChainwebVersion b -prop_block_weight :: ChainStep -> Bool -prop_block_weight (ChainStep (ParentHeader p) b) +prop_block_weight :: HasVersion => ChainStep -> Bool +prop_block_weight (ChainStep (Parent p) b) | isGenesisBlockHeader b = view blockWeight b == view blockWeight p | otherwise = view blockWeight b == expectedWeight where expectedWeight = int (targetToDifficulty (view blockTarget b)) + view blockWeight p prop_block_chainId :: ChainStep -> Bool -prop_block_chainId (ChainStep (ParentHeader p) b) +prop_block_chainId (ChainStep (Parent p) b) = view blockChainId p == view blockChainId b -- | Validate that that fork votes are correctly incremented. -- -prop_block_forkVote :: ChainStep -> Bool -prop_block_forkVote (ChainStep (ParentHeader p) b) - | skipFeatureFlagValidationGuard v cid h = True - | isForkEpochStart v h = +prop_block_forkVote :: HasVersion => ChainStep -> Bool +prop_block_forkVote (ChainStep (Parent p) b) + | skipFeatureFlagValidationGuard cid h = True + | isForkEpochStart h = votes == resetVotes || votes == addVote resetVotes - | isForkVoteBlock v h = + | isForkVoteBlock h = votes == parentVotes || votes == addVote parentVotes | otherwise = True where votes = view blockForkVotes b parentVotes = view blockForkVotes p - v = _chainwebVersion b h = view blockHeight b cid = _chainId b -- | Validate that fork number is incremented correctly at fork epoch start. -- -prop_block_forkNumber :: ChainStep -> Bool -prop_block_forkNumber (ChainStep (ParentHeader p) b) - | skipFeatureFlagValidationGuard v cid h = True - | isForkEpochStart v h && decideVotes v parentVotes = fnum == pfnum + 1 +prop_block_forkNumber :: HasVersion => ChainStep -> Bool +prop_block_forkNumber (ChainStep (Parent p) b) + | skipFeatureFlagValidationGuard cid h = True + | isForkEpochStart h && decideVotes parentVotes = fnum == pfnum + 1 | otherwise = fnum == pfnum where fnum = view blockForkNumber b pfnum = view blockForkNumber p parentVotes = view blockForkVotes p - v = _chainwebVersion b h = view blockHeight b cid = _chainId b -- | Validate that fork number does not exceed the version fork number. -prop_block_forkKnown :: BlockHeader -> Bool +prop_block_forkKnown :: HasVersion => BlockHeader -> Bool prop_block_forkKnown b - | skipFeatureFlagValidationGuard v cid h = True - | fnum > _versionForkNumber v = False + | skipFeatureFlagValidationGuard cid h = True + | fnum > _versionForkNumber implicitVersion = False | otherwise = True where fnum = view blockForkNumber b - v = _chainwebVersion b h = view blockHeight b cid = _chainId b -- -------------------------------------------------------------------------- -- -- Multi chain inductive properties -prop_block_forkVoteCount :: WebStep -> Bool +prop_block_forkVoteCount :: HasVersion => WebStep -> Bool prop_block_forkVoteCount (WebStep as (ChainStep p b)) - | skipFeatureFlagValidationGuard v cid h = True - | isForkEpochStart v h = + | skipFeatureFlagValidationGuard cid h = True + | isForkEpochStart h = votes == resetVotes || votes == addVote resetVotes - | isForkVoteBlock v h = + | isForkVoteBlock h = votes == parentVotes || votes == addVote parentVotes | otherwise = votes == countVotes allParentVotes where votes = view blockForkVotes b - parentVotes = view blockForkVotes (_parentHeader p) - allParentVotes = view (parentHeader . blockForkVotes) <$> (p : toList as) - v = _chainwebVersion b + parentVotes = view blockForkVotes (unwrapParent p) + allParentVotes = view blockForkVotes . unwrapParent <$> (p : toList as) h = view blockHeight b cid = _chainId b -prop_block_target :: WebStep -> Bool +prop_block_target :: HasVersion => WebStep -> Bool prop_block_target (WebStep as (ChainStep p b)) = view blockTarget b == powTarget p as (view blockCreationTime b) -prop_block_epoch :: WebStep -> Bool +prop_block_epoch :: HasVersion => WebStep -> Bool prop_block_epoch (WebStep as (ChainStep p b)) - | oldDaGuard (_chainwebVersion b) (_chainId b) (view blockHeight b) + | oldDaGuard (_chainId b) (view blockHeight b) = view blockEpochStart b <= EpochStartTime (_bct $ view blockCreationTime b) - && view blockEpochStart (_parentHeader p) <= view blockEpochStart b + && view blockEpochStart (unwrapParent p) <= view blockEpochStart b && view blockEpochStart b == epochStart p as (view blockCreationTime b) | otherwise = view blockEpochStart b <= EpochStartTime (_bct $ view blockCreationTime b) && view blockEpochStart b == epochStart p as (view blockCreationTime b) -prop_block_creationTime :: WebStep -> Bool -prop_block_creationTime (WebStep as (ChainStep (ParentHeader p) b)) +prop_block_creationTime :: HasVersion => WebStep -> Bool +prop_block_creationTime (WebStep as (ChainStep (Parent p) b)) | isGenesisBlockHeader b = view blockCreationTime b == view blockCreationTime p - | oldDaGuard (_chainwebVersion b) (_chainId b) (view blockHeight b) + | oldDaGuard (_chainId b) (view blockHeight b) = view blockCreationTime b > view blockCreationTime p | otherwise = view blockCreationTime b > view blockCreationTime p - && all (\x -> view blockCreationTime b > view blockCreationTime (_parentHeader x)) as + && all (\x -> view blockCreationTime b > view blockCreationTime (unwrapParent x)) as -- | The chainId index of the adjacent parents of the header and the blocks -- in the webstep reference the same hashes and the chain Ids in of the @@ -889,14 +885,14 @@ prop_block_creationTime (WebStep as (ChainStep (ParentHeader p) b)) -- we include it here again as assertion (to double check during testing) and -- for documentation purposes. -- -prop_block_adjacent_parents :: WebStep -> Bool +prop_block_adjacent_parents :: HasVersion => WebStep -> Bool prop_block_adjacent_parents (WebStep as (ChainStep _ b)) | isGenesisBlockHeader b - = adjsHashes == imap (\cid _ -> genesisParentBlockHash v cid) as + = adjsHashes == imap (\cid _ -> genesisParentBlockHash cid) as -- chainId indexes in web adjadent parent record references the -- genesis block parent hashes | otherwise - = adjsHashes == (view blockHash . _parentHeader <$> as) + = adjsHashes == (fmap (view blockHash) <$> as) -- chainId indexes in web adjadent parent record and web step are -- referencing the same hashes && iall (\cid h -> cid == _chainId h) as @@ -904,11 +900,10 @@ prop_block_adjacent_parents (WebStep as (ChainStep _ b)) -- it is indexed where adjsHashes = _getBlockHashRecord (view blockAdjacentHashes b) - v = _chainwebVersion b prop_block_adjacent_parents_version :: WebStep -> Bool prop_block_adjacent_parents_version (WebStep as (ChainStep _ b)) - = all ((== v) . view blockChainwebVersion . _parentHeader) as + = all ((== v) . view blockChainwebVersion . unwrapParent) as where v = view blockChainwebVersion b diff --git a/src/Chainweb/BlockHeaderDB.hs b/src/Chainweb/BlockHeaderDB.hs index 9c462b0f8c..e52cc32862 100644 --- a/src/Chainweb/BlockHeaderDB.hs +++ b/src/Chainweb/BlockHeaderDB.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE ExplicitNamespaces #-} + -- | -- Module: Chainweb.BlockHeaderDB -- Copyright: Copyright © 2018 Kadena LLC. @@ -9,12 +11,20 @@ -- module Chainweb.BlockHeaderDB ( +-- * Ranked Block Header + RankedBlockHeader(..) +, BlockRank(..) + -- * Chain Database Handle - Configuration(..) +, Configuration(..) , BlockHeaderDb +, RankedBlockHeaderDb(..) , initBlockHeaderDb , closeBlockHeaderDb , withBlockHeaderDb + +-- * Misc +, type RankedBlockHeaderCas ) where -- internal imports diff --git a/src/Chainweb/BlockHeaderDB/HeaderOracle.hs b/src/Chainweb/BlockHeaderDB/HeaderOracle.hs index 6a6d2eb4d1..77de8cb3b0 100644 --- a/src/Chainweb/BlockHeaderDB/HeaderOracle.hs +++ b/src/Chainweb/BlockHeaderDB/HeaderOracle.hs @@ -33,7 +33,7 @@ import Chainweb.BlockHeader (BlockHeader, blockHash, blockHeight, blockForkNumbe import Chainweb.BlockHeaderDB (BlockHeaderDb) import Chainweb.TreeDB (seekAncestor) import Chainweb.TreeDB qualified as TreeDB -import Chainweb.Version (_chainwebVersion) +import Chainweb.Version import Chainweb.Version.Guards (minimumBlockHeaderHistory) import Control.Exception (Exception(..), throwIO) import Control.Lens @@ -50,10 +50,12 @@ data HeaderOracle = HeaderOracle -- | Create a new 'HeaderOracle' specifically for SPV verification, with the given upper bound. -- -- The lower bound of the oracle is determined by the 'spvProofExpirationWindow'. -createSpv :: BlockHeaderDb -> BlockHeader -> IO HeaderOracle +createSpv :: HasVersion => BlockHeaderDb -> BlockHeader -> IO HeaderOracle createSpv db upperBound = do - let mWindow = minimumBlockHeaderHistory (_chainwebVersion upperBound) (upperBound ^. blockForkNumber) (upperBound ^. blockHeight) - let gh = genesisBlockHeader (_chainwebVersion upperBound) upperBound + let mWindow = minimumBlockHeaderHistory + (upperBound ^. blockForkNumber) + (upperBound ^. blockHeight) + let gh = genesisBlockHeader upperBound let defaultOracle = create db gh upperBound case mWindow of @@ -86,7 +88,7 @@ instance Exception InvalidHeaderOracleBounds where -- | Create a new 'HeaderOracle' with the given lower and upper bounds. -- -- Throws an 'InvalidHeaderOracleBounds' exception if the lower bound is not an ancestor of the upper bound. -create :: BlockHeaderDb -> BlockHeader -> BlockHeader -> IO HeaderOracle +create :: HasVersion => BlockHeaderDb -> BlockHeader -> BlockHeader -> IO HeaderOracle create db lowerBound upperBound = do valid <- TreeDB.ancestorOf db (view blockHash lowerBound) (view blockHash upperBound) if valid @@ -113,7 +115,8 @@ data HeaderOracleResponse deriving stock (Eq) -- | Query the oracle, asking if the block is within its bounds. -query :: () +query + :: HasVersion => HeaderOracle -> BlockHash -> IO HeaderOracleResponse diff --git a/src/Chainweb/BlockHeaderDB/Internal.hs b/src/Chainweb/BlockHeaderDB/Internal.hs index f272bb8b7a..df6f163314 100644 --- a/src/Chainweb/BlockHeaderDB/Internal.hs +++ b/src/Chainweb/BlockHeaderDB/Internal.hs @@ -1,9 +1,12 @@ {-# LANGUAGE BangPatterns #-} +{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE ImportQualifiedPost #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} @@ -25,6 +28,19 @@ -- Internal BlockHeader DB implementation. This module must be imported only by -- modules within the @Chainweb.BlockHeader@ namespace. -- +-- Whenever possible prefer 'RankedBlockHeaderDb' over 'BlockHeaderDb' as it is +-- more efficient. +-- +-- TODO: +-- Consider renaming RankedBlockHeaderDb to BlockHeaderDb and BlockHeaderDb to +-- UnrankedBlockHeaderDb. Or remove the unranked version alltogether. +-- +-- Ideally, we would just inlcude the rank as the first 4 bytes in the block +-- hash, but that ship has probably sailed. (4 bytes are sufficient for about +-- 4G of blocks or 4000 years of block history at 2 blocks per minute. +-- Even when producint 1 block per ms, e.g. during tests, this would still +-- be sufficient for about 49 days.) +-- module Chainweb.BlockHeaderDB.Internal ( -- * Internal Types @@ -34,6 +50,7 @@ module Chainweb.BlockHeaderDB.Internal -- * Chain Database Handle , Configuration(..) , BlockHeaderDb(..) +, RankedBlockHeaderDb(..) , initBlockHeaderDb , closeBlockHeaderDb , withBlockHeaderDb @@ -41,22 +58,27 @@ module Chainweb.BlockHeaderDB.Internal -- * Insertion , insertBlockHeaderDb , unsafeInsertBlockHeaderDb + +-- * Misc +, type RankedBlockHeaderCas ) where import Control.Arrow import Control.DeepSeq +import Control.Exception.Safe import Control.Lens hiding (children) import Control.Monad -import Control.Monad.Catch -import Control.Monad.Trans.Maybe +import Control.Monad.IO.Class +import Control.Monad.Trans.Resource hiding (throwM) import Data.Aeson import Data.Function import Data.Hashable +import Data.HashSet qualified as HS import Data.Maybe import qualified Data.Text.Encoding as T -import GHC.Generics +import GHC.Generics (Generic) import Prelude hiding (lookup) @@ -69,6 +91,8 @@ import Chainweb.BlockHeader import Chainweb.BlockHeader.Validation import Chainweb.BlockHeight import Chainweb.ChainId +import Chainweb.Parent +import Chainweb.Ranked qualified as R import Chainweb.TreeDB import Chainweb.Utils hiding (Codec) import Chainweb.Utils.Paging @@ -91,20 +115,21 @@ data Configuration = Configuration -- -------------------------------------------------------------------------- -- -- Ranked Block Header -newtype RankedBlockHeader = RankedBlockHeader { _getRankedBlockHeader :: BlockHeader } +newtype RankedBlockHeader = RankedBlockHeader + { _getRankedBlockHeader :: BlockHeader } deriving (Show, Generic) deriving anyclass (NFData) deriving newtype (Hashable, Eq, ToJSON, FromJSON) -instance HasChainwebVersion RankedBlockHeader where - _chainwebVersion = _chainwebVersion . _getRankedBlockHeader - {-# INLINE _chainwebVersion #-} +instance R.IsRanked RankedBlockHeader where + rank = view blockHeight . _getRankedBlockHeader + {-# INLINE rank #-} instance HasChainId RankedBlockHeader where _chainId = _chainId . _getRankedBlockHeader {-# INLINE _chainId #-} -instance HasChainGraph RankedBlockHeader where +instance HasVersion => HasChainGraph RankedBlockHeader where _chainGraph = _chainGraph . _getRankedBlockHeader {-# INLINE _chainGraph #-} @@ -118,6 +143,20 @@ instance IsCasValue RankedBlockHeader where = RankedBlockHash (view blockHeight bh) (view blockHash bh) {-# INLINE casKey #-} +type RankedBlockHeaderCas tbl = Cas tbl RankedBlockHeader + +instance HasVersion => TreeDbEntry RankedBlockHeader where + type Key RankedBlockHeader = RankedBlockHash + key = _rankedBlockHash . _getRankedBlockHeader + {-# INLINE key #-} + rank = int . view blockHeight . _getRankedBlockHeader + {-# INLINE rank #-} + parent e + | isGenesisBlockHeader (_getRankedBlockHeader e) = Nothing + | otherwise = Just $ RankedBlockHash + (pred $ view blockHeight $ _getRankedBlockHeader e) + (unwrapParent $ view blockParent $ _getRankedBlockHeader e) + -- -------------------------------------------------------------------------- -- -- BlockRank @@ -161,11 +200,30 @@ instance HasChainId BlockHeaderDb where _chainId = _chainDbId {-# INLINE _chainId #-} -instance HasChainwebVersion BlockHeaderDb where - _chainwebVersion = _chainDbChainwebVersion - {-# INLINE _chainwebVersion #-} +instance (k ~ CasKeyType BlockHeader, HasVersion) => ReadableTable BlockHeaderDb k BlockHeader where + tableLookup = lookup + {-# INLINE tableLookup #-} + +-- -------------------------------------------------------------------------- -- +-- RankedBlockHeaderDb -instance (k ~ CasKeyType BlockHeader) => ReadableTable BlockHeaderDb k BlockHeader where +-- | A rangked block header db uses the same underlying storage as a +-- 'BlockHeaderDb' but always includes the header rank in the key, which +-- results in more efficient queries, because it bypasses a lookup in the rank +-- table. +-- +newtype RankedBlockHeaderDb = RankedBlockHeaderDb + { _rankedBlockHeaderDb :: BlockHeaderDb } + deriving (Generic) + +instance HasChainId RankedBlockHeaderDb where + _chainId = _chainId . _rankedBlockHeaderDb + {-# INLINE _chainId #-} + +instance + (k ~ CasKeyType RankedBlockHeader, HasVersion) + => ReadableTable RankedBlockHeaderDb k RankedBlockHeader + where tableLookup = lookup {-# INLINE tableLookup #-} @@ -178,7 +236,7 @@ instance (k ~ CasKeyType BlockHeader) => ReadableTable BlockHeaderDb k BlockHead -- -- Updates all indices. -- -dbAddChecked :: BlockHeaderDb -> BlockHeader -> IO () +dbAddChecked :: HasVersion => BlockHeaderDb -> BlockHeader -> IO () dbAddChecked db e = unlessM (tableMember (_chainDbCas db) ek) dbAddCheckedInternal where r = int $ rank e @@ -196,7 +254,7 @@ dbAddChecked db e = unlessM (tableMember (_chainDbCas db) ek) dbAddCheckedIntern dbAddCheckedInternal = case parent e of Nothing -> add Just p -> tableLookup (_chainDbCas db) (RankedBlockHash (r - 1) p) >>= \case - Nothing -> throwM $ TreeDbParentMissing @BlockHeaderDb e + Nothing -> throwM $ TreeDbParentMissing @BlockHeaderDb e "dbAddCheckedInternal" Just (RankedBlockHeader pe) -> do unless (rank e == rank pe + 1) $ throwM $ TreeDbInvalidRank @BlockHeaderDb e @@ -214,7 +272,7 @@ dbAddChecked db e = unlessM (tableMember (_chainDbCas db) ek) dbAddCheckedIntern -- | Initialize a database handle -- -initBlockHeaderDb :: Configuration -> IO BlockHeaderDb +initBlockHeaderDb :: HasVersion => Configuration -> IO BlockHeaderDb initBlockHeaderDb config = do dbAddChecked db rootEntry return db @@ -236,7 +294,7 @@ initBlockHeaderDb config = do ["BlockHeader", cidNs, "rank"] !db = BlockHeaderDb cid - (_chainwebVersion rootEntry) + implicitVersion headerTable rankTable @@ -246,15 +304,14 @@ closeBlockHeaderDb :: BlockHeaderDb -> IO () closeBlockHeaderDb _ = return () withBlockHeaderDb - :: RocksDb - -> ChainwebVersion + :: HasVersion + => RocksDb -> ChainId - -> (BlockHeaderDb -> IO b) - -> IO b -withBlockHeaderDb db v cid = bracket start closeBlockHeaderDb + -> ResourceT IO BlockHeaderDb +withBlockHeaderDb db cid = snd <$> allocate start closeBlockHeaderDb where start = initBlockHeaderDb Configuration - { _configRoot = genesisBlockHeader v cid + { _configRoot = genesisBlockHeader cid , _configRocksDb = db } @@ -264,46 +321,103 @@ withBlockHeaderDb db v cid = bracket start closeBlockHeaderDb -- | TODO provide more efficient branchEntries implementation that uses -- iterators. -- -instance TreeDb BlockHeaderDb where +instance HasVersion => TreeDb BlockHeaderDb where type DbEntry BlockHeaderDb = BlockHeader - lookup db h = runMaybeT $ do - -- lookup rank - r <- MaybeT $ tableLookup (_chainDbRankTable db) h - MaybeT $ lookupRanked db (int r) h + lookup db h = do + liftIO (tableLookup (_chainDbRankTable db) h) >>= \case + Nothing -> return Nothing + Just v -> fmap _getRankedBlockHeader + <$> lookup (RankedBlockHeaderDb db) (RankedBlockHash (int v) h) + {-# INLINEABLE lookup #-} + + lookupRanked db r h = fmap _getRankedBlockHeader + <$> lookupRanked (RankedBlockHeaderDb db) r (RankedBlockHash (int r) h) + {-# INLINEABLE lookupRanked #-} + + entries db k l mir mar f = do + rk <- mapM (mapM (getRankedKey db)) k + entries (RankedBlockHeaderDb db) rk l mir mar + $ f . S.map _getRankedBlockHeader + {-# INLINEABLE entries #-} + + branchEntries db k l mir mar lower upper f = do + -- we use the ranked implementation as it is more efficient + -- TODO run these queries in parallel or batch them; usually it is a + -- relatively small number. + let mapSetM a = fmap HS.fromList . mapM a . HS.toList + rk <- mapM (mapM (getRankedKey db)) k + rlow <- mapSetM (mapM (getRankedKey db)) lower + rup <- mapSetM (mapM (getRankedKey db)) upper + chainBranchEntries (RankedBlockHeaderDb db) rk l mir mar rlow rup + $ f . S.map _getRankedBlockHeader + {-# INLINEABLE branchEntries #-} + + keys db k l mir mar f = do + rk <- mapM (mapM (getRankedKey db)) k + keys (RankedBlockHeaderDb db) rk l mir mar + $ f . S.map _rankedBlockHashHash + {-# INLINEABLE keys #-} + + maxEntry db = _getRankedBlockHeader <$> maxEntry (RankedBlockHeaderDb db) + {-# INLINEABLE maxEntry #-} + + maxRank db = maxRank (RankedBlockHeaderDb db) + {-# INLINEABLE maxRank #-} + +getRankedKey + :: HasVersion + => BlockHeaderDb + -> BlockHash + -> IO RankedBlockHash +getRankedKey db h = do + liftIO (tableLookup (_chainDbRankTable db) h) >>= \case + Nothing -> throwM $ TreeDbKeyNotFound @BlockHeaderDb h "getRankedKey.lookup" + Just v -> return $ RankedBlockHash (int v) h +{-# INLINE getRankedKey #-} + +-- -------------------------------------------------------------------------- -- +-- TreeDB instance for RankedBlockHeaderDb + +instance HasVersion => TreeDb RankedBlockHeaderDb where + type DbEntry RankedBlockHeaderDb = RankedBlockHeader + + lookup db = tableLookup (_chainDbCas $ _rankedBlockHeaderDb db) {-# INLINEABLE lookup #-} - lookupRanked db r h = runMaybeT $ do - rh <- MaybeT $ tableLookup (_chainDbCas db) (RankedBlockHash (int r) h) - return $! _getRankedBlockHeader rh + -- If the rank is inconsistent with the height in the key 'Nothing' is + -- returned. This is consistent with the behavior of the unraked + -- BlockHeaderDb instance. + -- + lookupRanked db r h + | int r /= R._rankedHeight h = return Nothing + | otherwise = lookup db h {-# INLINEABLE lookupRanked #-} - entries db k l mir mar f = withSeekTreeDb db k mir $ \it -> f $ do + entries db k l mir mar f = withSeekRanked db k mir $ \it -> f $ do iterToValueStream it - & S.map _getRankedBlockHeader - & maybe id (\x -> S.takeWhile (\a -> int (view blockHeight a) <= x)) mar + & maybe id (\x -> S.takeWhile (\a -> int (rank a) <= x)) mar & limitStream l {-# INLINEABLE entries #-} branchEntries = chainBranchEntries {-# INLINEABLE branchEntries #-} - keys db k l mir mar f = withSeekTreeDb db k mir $ \it -> f $ do + keys db k l mir mar f = withSeekRanked db k mir $ \it -> f $ do iterToKeyStream it & maybe id (\x -> S.takeWhile (\a -> int (_rankedBlockHashHeight a) <= x)) mar - & S.map _rankedBlockHashHash & limitStream l {-# INLINEABLE keys #-} - maxEntry db = withTableIterator (_chainDbCas db) $ \it -> do + maxEntry db = withTableIterator (_chainDbCas $ _rankedBlockHeaderDb db) $ \it -> do iterLast it iterValue it >>= \case - Just (RankedBlockHeader !r) -> return r + Just !r -> return r Nothing -> throwM $ InternalInvariantViolation "BlockHeaderDb.maxEntry: empty block header db" {-# INLINEABLE maxEntry #-} - maxRank db = withTableIterator (_chainDbCas db) $ \it -> do + maxRank db = withTableIterator (_chainDbCas $ _rankedBlockHeaderDb db) $ \it -> do iterLast it iterKey it >>= \case Just (RankedBlockHash !r _) -> return $! int r @@ -311,15 +425,19 @@ instance TreeDb BlockHeaderDb where $ InternalInvariantViolation "BlockHeaderDb.maxRank: empty block header db" {-# INLINEABLE maxRank #-} -withSeekTreeDb - :: BlockHeaderDb - -> Maybe (NextItem BlockHash) +-- -------------------------------------------------------------------------- -- + +withSeekRanked + :: RankedBlockHeaderDb + -> Maybe (NextItem RankedBlockHash) -> Maybe MinRank -> (RocksDbTableIter RankedBlockHash RankedBlockHeader -> IO a) -> IO a -withSeekTreeDb db k mir kont = - withTableIterator (_chainDbCas db) (\it -> seekTreeDb db k mir it >> kont it) -{-# INLINE withSeekTreeDb #-} +withSeekRanked db k mir kont = + withTableIterator (_chainDbCas $ _rankedBlockHeaderDb db) $ \it -> do + seekRanked k mir it + kont it +{-# INLINE withSeekRanked #-} -- | If @k@ is not 'Nothing', @seekTreeDb d k mir@ seeks key @k@ in @db@. If the -- key doesn't exist it throws @TreeDbKeyNotFound@. Otherwise if @k@ was @@ -333,13 +451,12 @@ withSeekTreeDb db k mir kont = -- If both @k@ and @minr@ are 'Nothing' it returns an iterator that points to -- the first entry in @d@. -- -seekTreeDb - :: BlockHeaderDb - -> Maybe (NextItem BlockHash) +seekRanked + :: Maybe (NextItem RankedBlockHash) -> Maybe MinRank -> RocksDbTableIter RankedBlockHash RankedBlockHeader -> IO () -seekTreeDb db k mir it = do +seekRanked k mir it = do case k of Nothing -> case mir of Nothing -> return () @@ -347,18 +464,14 @@ seekTreeDb db k mir it = do $ RankedBlockHash (BlockHeight $ int $ _getMinRank r) nullBlockHash Just a -> do - -- Seek to cursor let x = _getNextItem a - r <- tableLookup (_chainDbRankTable db) x >>= \case - Nothing -> throwM $ TreeDbKeyNotFound @BlockHeaderDb x - (Just !b) -> return b - iterSeek it (RankedBlockHash r x) + iterSeek it x -- if we don't find the cursor, throw exception iterKey it >>= \case - Just (RankedBlockHash _ b) | b == x -> return () - _ -> throwM $ TreeDbKeyNotFound @BlockHeaderDb x + Just b | b == x -> return () + _ -> throwM $ TreeDbKeyNotFound @RankedBlockHeaderDb x "seekTreeDb.iterKey" -- If the cursor is exclusive, then advance the iterator when (isExclusive a) $ iterNext it @@ -374,11 +487,10 @@ seekTreeDb db k mir it = do -- -------------------------------------------------------------------------- -- -- Insertions -insertBlockHeaderDb :: BlockHeaderDb -> ValidatedHeader -> IO () +insertBlockHeaderDb :: HasVersion => BlockHeaderDb -> ValidatedHeader -> IO () insertBlockHeaderDb db = dbAddChecked db . _validatedHeader {-# INLINE insertBlockHeaderDb #-} -unsafeInsertBlockHeaderDb :: BlockHeaderDb -> BlockHeader -> IO () +unsafeInsertBlockHeaderDb :: HasVersion => BlockHeaderDb -> BlockHeader -> IO () unsafeInsertBlockHeaderDb = dbAddChecked {-# INLINE unsafeInsertBlockHeaderDb #-} - diff --git a/src/Chainweb/BlockHeaderDB/PruneForks.hs b/src/Chainweb/BlockHeaderDB/PruneForks.hs index d79f88c2f4..2354c0db5d 100644 --- a/src/Chainweb/BlockHeaderDB/PruneForks.hs +++ b/src/Chainweb/BlockHeaderDB/PruneForks.hs @@ -1,5 +1,6 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE FlexibleContexts #-} @@ -8,6 +9,12 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE NumericUnderscores #-} +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE DerivingVia #-} -- | -- Module: Chainweb.BlockHeaderDB.PruneForks @@ -19,19 +26,23 @@ -- Prune old forks from BlockHeader DB -- module Chainweb.BlockHeaderDB.PruneForks -( pruneForksLogg -, pruneForks +( pruneForks , pruneForks_ +, safeDepth +, pruneForksJob +, DoPrune(..) +, PruneStats(..) ) where -import Control.DeepSeq -import Control.Exception (evaluate) -import Control.Lens (view) +import Control.DeepSeq (NFData) +import Control.Exception (throw) +import Control.Lens (ix, view, (^?!), iforM_, (%~)) import Control.Monad import Control.Monad.Catch import Data.Function -import qualified Data.List as L +import Data.HashSet (HashSet) +import Data.HashSet qualified as HashSet import Data.Maybe import Data.Semigroup import qualified Data.Text as T @@ -43,7 +54,7 @@ import Numeric.Natural import Prelude hiding (lookup) -import qualified Streaming.Prelude as S +import Streaming.Prelude qualified as S import System.LogLevel @@ -54,38 +65,69 @@ import Chainweb.BlockHeader import Chainweb.BlockHeaderDB.Internal import Chainweb.BlockHeight import Chainweb.Logger +import Chainweb.Parent +import Chainweb.Ranked import Chainweb.TreeDB import Chainweb.Utils hiding (Codec) import Chainweb.Version import Chainweb.Storage.Table import Chainweb.Storage.Table.RocksDB +import Chainweb.Time qualified import Data.LogMessage +import Chainweb.WebBlockHeaderDB +import Chainweb.Cut +import Control.Monad.Cont +import Chainweb.Scheduler (Scheduler, scheduleEvery) +import Data.Foldable +import Data.Ord +import Chainweb.BlockHeader.Validation (validateIntrinsicM) +import Data.Aeson (FromJSON, ToJSON) -- -------------------------------------------------------------------------- -- -- Chain Database Pruning -pruneForksLogg - :: Logger logger - => logger - -> BlockHeaderDb - -> Natural - -- ^ The depth at which pruning starts. Block at this depth are used as - -- pivots and actual deletion starts at (depth - 1). - -- - -- Note, that the max rank isn't necessarly included in the current best - -- cut. So one, should choose a depth for which one is confident that - -- all forks are resolved. +safeDepth :: BlockHeight +safeDepth = 10000 - -> (Bool -> BlockHeader -> IO ()) - -- ^ Deletion call back. This hook is called /after/ the entry is - -- deleted from the database. It's main purpose is to delete any - -- resources that were related to the deleted header and that are not - -- needed any more. The first parameter indicates whether the block - -- header got deleted from the chain database. +data PruneStats = PruneStats + { blocksPruned :: !Int + } + deriving stock Generic + deriving anyclass (NFData, ToJSON, FromJSON) + deriving LogMessage via (JsonLog PruneStats) - -> IO Int -pruneForksLogg = pruneForks . logFunctionText +-- | `ForcePrune` restarts from genesis. `PruneDryRun` does the prune without deleting +-- anything, but it also records the prune as having happened. +-- Prune +data DoPrune = Prune | ForcePrune | PruneDryRun + deriving (Show, Eq, Ord) + deriving (ToJSON, FromJSON) via (JsonTextRepresentation "DoPrune" DoPrune) + +instance HasTextRepresentation DoPrune where + toText Prune = "prune" + toText ForcePrune = "force-prune" + toText PruneDryRun = "prune-dry-run" + fromText "prune"= return Prune + fromText "force-prune" = return ForcePrune + fromText "prune-dry-run" = return PruneDryRun + fromText t = + throwM $ TextFormatException $ "HasTextRepresentation DoPrune: invalid DoPrune value " <> sshow t + +pruneForksJob + :: HasVersion + => Logger logger + => Scheduler + -> logger + -> IO Cut + -> WebBlockHeaderDb + -> DoPrune + -> Natural + -> IO () +pruneForksJob sched logger getCut wbhdb doPrune depth = + scheduleEvery sched "prune_forks" (1_000_000 * 60 * 60) $ do + initialCut <- getCut + void $ pruneForks logger initialCut wbhdb doPrune depth -- | Prunes most block headers from forks that are older than the given number -- of blocks. @@ -96,49 +138,70 @@ pruneForksLogg = pruneForks . logFunctionText -- This function doesn't guarantee to delete all blocks on forks. A small number -- of fork blocks may not get deleted. -- --- The function takes a callback that are invoked on each block header in the --- database starting from the given depth. The callback takes a parameter that --- indicates whether the related block is pruned or not. --- pruneForks - :: LogFunctionText - -> BlockHeaderDb + :: HasVersion + => Logger logger + => logger + -> Cut + -> WebBlockHeaderDb + -> DoPrune -> Natural -- ^ The depth at which pruning starts. Block at this depth are used as - -- pivots and actual deletion starts at (depth - 1). + -- initial live set and actual deletion starts at (depth - 1). -- -- Note, that the max rank isn't necessarly included in the current best -- cut. So one, should choose a depth for which one is confident that -- all forks are resolved. - -> (Bool -> BlockHeader -> IO ()) - -- ^ Deletion call back. This hook is called /after/ the entry is - -- deleted from the database. It's main purpose is to delete any - -- resources that were related to the deleted header and that are not - -- needed any more. The first parameter indicates whether the block - -- header got deleted from the chain database. - -> IO Int -pruneForks logg cdb depth callback = do - hdr <- maxEntry cdb - if - | int (view blockHeight hdr) <= depth -> do - logg Info +pruneForks logger initialCut wbhdb doPrune depth = do + let highestSafePruneTarget = + _cutMinHeight initialCut - min (int depth) (_cutMinHeight initialCut) + + (resumptionPoint, startedFrom) <- tableLookup (_webCurrentPruneJob wbhdb) () >>= \case + Just j | doPrune /= ForcePrune -> return j + _ -> return (highestSafePruneTarget, highestSafePruneTarget) + + -- the lower bound is different from the job start point because some + -- heights have already been pruned + lowerBound <- tableLookup (_webHighestPruned wbhdb) () >>= \case + Just highestPruned | doPrune /= ForcePrune -> return highestPruned + _ -> return 0 + + tableInsert (_webHighestPruned wbhdb) () lowerBound + + numPruned <- if + | int (_cutMinHeight initialCut) <= depth -> do + logFunctionText logger Info $ "Skipping database pruning because the maximum block height " - <> sshow (view blockHeight hdr) <> " is not larger than then requested depth " + <> sshow (_cutMinHeight initialCut) <> " is not larger than then requested depth " <> sshow depth return 0 - | int (view blockHeight hdr) <= int genHeight + depth -> do - logg Info $ "Skipping database pruning because there are not yet" - <> " enough block headers on the chain" + | lowerBound > resumptionPoint -> do + -- as far as I know, this can only happen if we write highestPruned + -- below and we stop before we can delete the current job. if the + -- lower bound is already pruned, the prune job is done. + logFunctionText logger Info + $ "Skipping database pruning because the lower bound is already pruned" return 0 | otherwise -> do - let mar = MaxRank $ Max $ int (view blockHeight hdr) - depth - pruneForks_ logg cdb mar (MinRank $ Min $ int genHeight) callback - where - v = _chainwebVersion cdb - cid = _chainId cdb - genHeight = genesisHeight v cid + numPruned <- + pruneForks_ logger wbhdb doPrune PruneJob + { resumptionPoint + , startedFrom + , lowerBound + } + logFunctionText logger Info + $ "Pruned " + <> sshow numPruned + <> " blocks, now pruned up to " + <> sshow startedFrom + + return numPruned + + tableInsert (_webHighestPruned wbhdb) () startedFrom + tableDelete (_webCurrentPruneJob wbhdb) () + return numPruned data PruneForksException = PruneForksDbInvariantViolation BlockHeight [BlockHeight] T.Text @@ -146,6 +209,24 @@ data PruneForksException instance Exception PruneForksException +data PruneState = PruneState + { liveSet :: HashSet BlockHash + , prevHeight :: BlockHeight + , prevRecordedHeight :: BlockHeight + , numPruned :: Int + , pendingDeletes :: ChainMap [RankedBlockHash] + , pendingDeleteCount :: Int + } deriving Show + +data PruneJob = PruneJob + { resumptionPoint :: BlockHeight + , startedFrom :: BlockHeight + -- this is the lower bound we actually work down to; we know inductively + -- that the interval [genesis, lowerbound] is already pruned. + , lowerBound :: BlockHeight + } + deriving Show + -- | Prune forks between the given min rank and max rank. -- -- Only block headers that are ancestors of a block header that has block height @@ -157,76 +238,174 @@ instance Exception PruneForksException -- TODO add option to also validate the block headers -- pruneForks_ - :: HasCallStack - => LogFunctionText - -> BlockHeaderDb - -> MaxRank - -> MinRank - -> (Bool -> BlockHeader -> IO ()) + :: (HasCallStack, HasVersion) + => Logger logger + => logger + -> WebBlockHeaderDb + -> DoPrune + -> PruneJob -> IO Int -pruneForks_ logg _ (MaxRank (Max mar)) _ _ - | mar <= 1 = 0 <$ logg Warn ("Skipping database pruning for max bound of " <> sshow mar) -pruneForks_ logg cdb mar mir callback = do - logg Debug $ "Pruning block header database for chain " <> sshow (_chainId cdb) - <> " with upper bound " <> sshow (_getMaxRank mar) - <> " and lower bound " <> sshow (_getMinRank mir) +pruneForks_ logger wbhdb doPrune pruneJob = do + logFunctionText logger Info $ "Pruning block header database job " + <> sshow pruneJob -- parent hashes of all blocks at height max rank @mar@. + -- it's fine if we miss some chains here, because we never remove chains + -- from the chain graph. -- - !pivots <- entries cdb Nothing Nothing (Just $ MinRank $ Min $ _getMaxRank mar) (Just mar) - $ fmap (force . L.nub) . S.toList_ . S.map (view blockParent) - -- the set of pivots is expected to be very small. In fact it is - -- almost always a singleton set. - - if null pivots - then do - logg Warn - $ "Skipping database pruning because of an empty set of block headers at upper pruning bound " <> sshow mar + !initialLiveSet <- webEntries wbhdb (Just $ MinRank $ Min $ _getMaxRank mar) (Just mar) + $ S.foldMap_ + $ \blk -> + HashSet.singleton (view (blockParent . _Parent) blk) + <> foldMap HashSet.singleton (getAdjs blk) + -- the initial live set is expected to be very small. In fact it is + -- almost always a singleton set on each chain. + logFunctionText logger Debug $ + "Initial live set at " <> sshow mar <> ": " <> sshow initialLiveSet + + let initialPruneState = PruneState + { liveSet = initialLiveSet + , prevHeight = resumptionPoint pruneJob + , prevRecordedHeight = resumptionPoint pruneJob + , numPruned = 0 + , pendingDeletes = noDeletes + , pendingDeleteCount = 0 + } + + now <- Chainweb.Time.getCurrentTimeIntegral + + if null initialLiveSet + then do + logFunctionText logger Warn + $ "Skipping database pruning because of an empty set of headers at upper pruning bound " + <> sshow mar return 0 - else - withReverseHeaderStream cdb (mar - 1) mir - $ S.foldM_ go (return (pivots, int (_getMaxRank mar), 0)) (\(_,_,!n) -> evaluate n) - . progress 200000 reportProgress + else do + withWebReverseHeaderStream wbhdb (max 1 mar - 1) + $ pruneBlocks now initialPruneState where - reportProgress i a = logg Info - $ "inspected " <> sshow i - <> " block headers. Current height " - <> sshow (view blockHeight a) - - go :: ([BlockHash], BlockHeight, Int) -> BlockHeader -> IO ([BlockHash], BlockHeight, Int) - go ([], _, _) cur = throwM $ InternalInvariantViolation - $ "PruneForks.pruneForks_: no pivots left at block " <> encodeToText (ObjectEncoded cur) - go (!pivots, !prevHeight, !n) !cur - - -- This checks some structural consistency. It's not a comprehensive - -- check. Comprehensive checks on various levels are availabe through - -- callbacks that are offered in the module "Chainweb.Chainweb.PruneChainDatabase" - | prevHeight /= curHeight && prevHeight /= curHeight + 1 = - throwM $ InternalInvariantViolation - $ "PruneForks.pruneForks_: detected a corrupted database. Some block headers are missing" - <> ". Current pivots: " <> encodeToText pivots - <> ". Current header: " <> encodeToText (ObjectEncoded cur) - <> ". Previous height: " <> sshow prevHeight - | view blockHash cur `elem` pivots = do - callback False cur - let !pivots' = force $ L.nub $ view blockParent cur : L.delete (view blockHash cur) pivots - return (pivots', curHeight, n) - | otherwise = do - deleteHdr cur - callback True cur - return (pivots, curHeight, n+1) - where - curHeight = view blockHeight cur - - deleteHdr k = do - -- TODO: make this atomic (create boilerplate to combine queries for - -- different tables) - casDelete (_chainDbCas cdb) (RankedBlockHeader k) - tableDelete (_chainDbRankTable cdb) (view blockHash k) - logg Debug - $ "pruned block header " <> encodeToText (view blockHash k) - <> " at height " <> sshow (view blockHeight k) + !noDeletes = onAllChains [] + mar = MaxRank $ int $ resumptionPoint pruneJob + !action = case doPrune of + PruneDryRun -> "Would have pruned " + _ -> "Pruned " + getAdjs bh = + view _Parent <$> _getBlockHashRecord (view blockAdjacentHashes bh) + + executePendingDeletes PruneState{..} = do + iforM_ pendingDeletes $ \cid pendingDeletesForCid -> do + let cdb = _webBlockHeaderDb wbhdb ^?! atChain cid + case doPrune of + PruneDryRun -> return () + _ -> do + tableDeleteBatch (_chainDbCas cdb) pendingDeletesForCid + tableDeleteBatch (_chainDbRankTable cdb) (_ranked <$> pendingDeletesForCid) + logFunctionText logger Info $ + action <> sshow pendingDeleteCount <> " block headers at height " <> sshow prevHeight + logFunctionText logger Debug $ + action <> sshow pendingDeletes <> ", at height " <> sshow prevHeight + logFunction logger Info $ + PruneStats pendingDeleteCount + + deleteBatchSize = 1000 + checkpointSize = 1000 + + pruneBlocks now initialState = + go initialState + where + go state strm = + if pendingDeleteCount state >= deleteBatchSize + || prevRecordedHeight state - prevHeight state > checkpointSize + then do + -- first execute pending deletes, then record checkpoint. that + -- way we never miss deletes. + executePendingDeletes state + -- make a checkpoint of our progress. we want to resume a level + -- higher, because we really don't prune the first height, we + -- use it for the initial live set. + tableInsert (_webCurrentPruneJob wbhdb) () + (succ $ prevHeight state, startedFrom pruneJob) + go + state + { prevRecordedHeight = prevHeight state + , pendingDeletes = noDeletes + , pendingDeleteCount = 0 + } + strm + else do + S.uncons strm >>= \case + Nothing -> do + executePendingDeletes state + return $! numPruned state + Just (block, strm') -> do + pruneBlock state block strm' + + pruneBlock :: PruneState -> BlockHeader -> S.Stream (S.Of BlockHeader) IO () -> IO Int + pruneBlock PruneState {liveSet, prevHeight} _ _ | HashSet.null liveSet = + throw $ InternalInvariantViolation + $ "PruneForks.pruneForks_: no live blocks left at height " <> sshow prevHeight + pruneBlock PruneState{..} cur strm + -- This checks some structural consistency. It's not a comprehensive + -- check. Comprehensive checks on various levels are available through + -- callbacks that are offered in the module "Chainweb.Chainweb.PruneChainDatabase" + | prevHeight /= curHeight && prevHeight /= curHeight + 1 = + throw $ InternalInvariantViolation + $ "PruneForks.pruneForks_: detected a corrupted database. " + <> "Some block headers are missing." + <> "Current live set: " <> encodeToText liveSet + <> ". Current header: " <> encodeToText (ObjectEncoded cur) + <> ". Previous height: " <> sshow prevHeight + -- if we are at or beyond the lower bound, + -- and we have no more pending fork tips to prune, + -- we're done early. + | curHeight <= lowerBound pruneJob + , curHeight < prevHeight + = do + when (pendingDeleteCount > 0) $ + executePendingDeletes PruneState{..} + return numPruned + -- the current block is live. + -- its parents take its place as live blocks. + | curHash `elem` liveSet = do + let !liveSet' = + flip (foldl' (flip HashSet.insert)) curAdjs $ + HashSet.insert curParent $ + HashSet.delete curHash liveSet + + validateIntrinsicM now cur + + go + PruneState + { liveSet = liveSet' + , prevHeight = curHeight + , prevRecordedHeight + , numPruned + , pendingDeletes + , pendingDeleteCount + } strm + -- the current block is not live, delete it. + | otherwise = do + let !newDelete = view rankedBlockHash cur + let !(!pendingDeletes', !pendingDeleteCount') = + (pendingDeletes & ix cid %~ (newDelete :) + , pendingDeleteCount + 1) + let !numPruned' = numPruned + 1 + go + PruneState + { liveSet + , prevHeight = curHeight + , prevRecordedHeight + , numPruned = numPruned' + , pendingDeletes = pendingDeletes' + , pendingDeleteCount = pendingDeleteCount' + } strm + where + curParent = view (blockParent . _Parent) cur + curAdjs = getAdjs cur + !cid = view chainId cur + !curHeight = view blockHeight cur + !curHash = view blockHash cur -- -------------------------------------------------------------------------- -- -- Utils @@ -236,16 +415,24 @@ pruneForks_ logg cdb mar mir callback = do withReverseHeaderStream :: BlockHeaderDb -> MaxRank - -> MinRank -> (S.Stream (S.Of BlockHeader) IO () -> IO a) -> IO a -withReverseHeaderStream db mar mir inner = withTableIterator headerTbl $ \it -> do - iterSeek it $ RankedBlockHash (BlockHeight $ int $ _getMaxRank mar + 1) nullBlockHash +withReverseHeaderStream db mar inner = withTableIterator headerTbl $ \it -> do + + iterSeek it $ + RankedBlockHash (BlockHeight $ int $ _getMaxRank mar + 1) nullBlockHash iterPrev it + inner $ iterToReverseValueStream it & S.map _getRankedBlockHeader - & S.takeWhile (\a -> int (view blockHeight a) >= mir) where headerTbl = _chainDbCas db -{-# INLINE withReverseHeaderStream #-} +withWebReverseHeaderStream + :: WebBlockHeaderDb + -> MaxRank + -> (S.Stream (S.Of BlockHeader) IO () -> IO a) + -> IO a +withWebReverseHeaderStream wbhdb mar inner = do + runContT (forM (_webBlockHeaderDb wbhdb) (\db -> ContT $ withReverseHeaderStream db mar)) + $ \streamPerChain -> inner $ mergeN (\bh -> (Down (view blockHeight bh), view chainId bh)) $ toList streamPerChain diff --git a/src/Chainweb/BlockHeaderDB/RemoteDB.hs b/src/Chainweb/BlockHeaderDB/RemoteDB.hs index 9c939c4565..100bffc2a0 100644 --- a/src/Chainweb/BlockHeaderDB/RemoteDB.hs +++ b/src/Chainweb/BlockHeaderDB/RemoteDB.hs @@ -21,8 +21,7 @@ module Chainweb.BlockHeaderDB.RemoteDB , remoteDb ) where -import Control.Error.Util (hush) -import Control.Lens (view) +import Control.Lens import Control.Monad.Catch (handle, throwM) import qualified Data.Text as T @@ -54,51 +53,50 @@ import Data.LogMessage data RemoteDb = RemoteDb { _remoteEnv :: !ClientEnv , _remoteLogFunction :: !ALogFunction - , _remoteVersion :: !ChainwebVersion , _remoteChainId :: {-# UNPACK #-} !ChainId } -instance TreeDb RemoteDb where +instance HasVersion => TreeDb RemoteDb where type DbEntry RemoteDb = BlockHeader maxEntry = error "Chainweb.TreeDB.RemoteDB.RemoteDb.maxEntry: not implemented" -- If other default functions rely on this, it could be quite inefficient. - lookup (RemoteDb env alog ver cid) k = hush <$> runClientM client env + lookup (RemoteDb env alog cid) k = either (const Nothing) Just <$> runClientM client env where client = logServantError alog "failed to query tree db entry" - $ headerClient ver cid k + $ headerClient cid k - keys (RemoteDb env alog ver cid) next limit minr maxr f + keys (RemoteDb env alog cid) next limit minr maxr f = f $ callAndPage client next 0 env where client :: Maybe (NextItem BlockHash) -> ClientM (Page (NextItem BlockHash) BlockHash) client nxt = logServantError alog "failed to query tree db keys" - $ hashesClient ver cid limit nxt minr maxr + $ hashesClient cid limit nxt minr maxr - entries (RemoteDb env alog ver cid) next limit minr maxr f + entries (RemoteDb env alog cid) next limit minr maxr f = f $ callAndPage client next 0 env where client :: Maybe (NextItem BlockHash) -> ClientM (Page (NextItem BlockHash) BlockHeader) client nxt = logServantError alog "failed to query tree db entries" - $ headersClient ver cid limit nxt minr maxr + $ headersClient cid limit nxt minr maxr - branchKeys (RemoteDb env alog ver cid) next limit minr maxr lower upper f + branchKeys (RemoteDb env alog cid) next limit minr maxr lower upper f = f $ callAndPage client next 0 env where client :: Maybe (NextItem BlockHash) -> ClientM (Page (NextItem BlockHash) BlockHash) client nxt = logServantError alog "failed to query remote branch keys" - $ branchHashesClient ver cid limit nxt minr maxr (BranchBounds lower upper) + $ branchHashesClient cid limit nxt minr maxr (BranchBounds lower upper) - branchEntries (RemoteDb env alog ver cid) next limit minr maxr lower upper f + branchEntries (RemoteDb env alog cid) next limit minr maxr lower upper f = f $ callAndPage client next 0 env where client :: Maybe (NextItem BlockHash) -> ClientM (Page (NextItem BlockHash) BlockHeader) client nxt = logServantError alog "failed to query remote branch entries" - $ branchHeadersClient ver cid limit nxt minr maxr (BranchBounds lower upper) + $ branchHeadersClient cid limit nxt minr maxr (BranchBounds lower upper) -- We could either use the cut or create a new API - -- maxEntry (RemoteDb env alog ver cid) e = + -- maxEntry (RemoteDb env alog cid) e = logServantError :: ALogFunction -> T.Text -> ClientM a -> ClientM a logServantError alog msg = handle $ \(e :: ClientError) -> do @@ -138,4 +136,4 @@ remoteDb -> IO RemoteDb remoteDb db logg env = do h <- root db - pure $! RemoteDb env (ALogFunction logg) (_chainwebVersion h) (view blockChainId h) + pure $! RemoteDb env (ALogFunction logg) (view blockChainId h) diff --git a/src/Chainweb/BlockHeaderDB/RestAPI.hs b/src/Chainweb/BlockHeaderDB/RestAPI.hs index 3892b62eec..93d48fc033 100644 --- a/src/Chainweb/BlockHeaderDB/RestAPI.hs +++ b/src/Chainweb/BlockHeaderDB/RestAPI.hs @@ -84,14 +84,11 @@ module Chainweb.BlockHeaderDB.RestAPI , headersApi , HashesApi , hashesApi -, BlocksApi -, BranchBlocksApi ) where import Data.Aeson import Data.Bifunctor import Data.ByteString.Lazy qualified as L -import Data.Maybe import Data.Proxy import Data.Text (Text) @@ -100,12 +97,12 @@ import Network.HTTP.Media ((//), (/:)) import Servant.API -- internal modules -import Chainweb.Block +import Chainweb.Pact.Block import Chainweb.BlockHash import Chainweb.BlockHeader import Chainweb.BlockHeaderDB import Chainweb.ChainId -import Chainweb.Payload +import Chainweb.Pact.Payload import Chainweb.RestAPI.Orphans () import Chainweb.RestAPI.Utils import Chainweb.TreeDB @@ -122,19 +119,19 @@ type BlockHeaderPage = Page (NextItem BlockHash) BlockHeader -- because this endpoint is only used on the service API, we assume clients -- want object-encoded block headers. -blockProperties :: KeyValue e kv => Block -> [kv] +blockProperties :: (HasVersion, KeyValue e kv) => Block -> [kv] blockProperties o = [ "header" .= ObjectEncoded (_blockHeader o) , "payloadWithOutputs" .= _blockPayloadWithOutputs o ] -instance ToJSON Block where +instance HasVersion => ToJSON Block where toJSON = object . blockProperties toEncoding = pairs . mconcat . blockProperties {-# INLINE toJSON #-} {-# INLINE toEncoding #-} -instance FromJSON Block where +instance HasVersion => FromJSON Block where parseJSON = withObject "Block" $ \o -> Block <$> (_objectEncoded <$> o .: "header") <*> o .: "payloadWithOutputs" @@ -158,7 +155,7 @@ instance MimeRender OctetStream BlockHeader where {-# INLINE mimeRender #-} -- | Orphan instance to encode pages of blocks as JSON -instance MimeRender JSON BlockPage where +instance HasVersion => MimeRender JSON BlockPage where mimeRender _ = encode {-# INLINE mimeRender #-} @@ -175,23 +172,24 @@ data JsonBlockHeaderObject instance Accept JsonBlockHeaderObject where contentType _ = "application" // "json" /: ("blockheader-encoding", "object") -instance MimeUnrender JsonBlockHeaderObject BlockHeader where +instance HasVersion => MimeUnrender JsonBlockHeaderObject BlockHeader where mimeUnrender _ = second _objectEncoded . eitherDecode {-# INLINE mimeUnrender #-} -instance MimeRender JsonBlockHeaderObject BlockHeader where +instance HasVersion => MimeRender JsonBlockHeaderObject BlockHeader where mimeRender _ = encode . ObjectEncoded {-# INLINE mimeRender #-} -instance MimeUnrender JsonBlockHeaderObject BlockHeaderPage where +instance HasVersion => MimeUnrender JsonBlockHeaderObject BlockHeaderPage where mimeUnrender _ = second (fmap _objectEncoded) . eitherDecode {-# INLINE mimeUnrender #-} -instance MimeRender JsonBlockHeaderObject BlockHeaderPage where +instance HasVersion => MimeRender JsonBlockHeaderObject BlockHeaderPage where mimeRender _ = encode . fmap ObjectEncoded {-# INLINE mimeRender #-} -- -------------------------------------------------------------------------- -- +-- TODO: this instance do *not* belong here instance MimeRender OctetStream BlockPayload where mimeRender _ = L.fromStrict . encodeBlockPayloads @@ -274,10 +272,10 @@ data SomeBlockHeaderDb = forall v c . (KnownChainwebVersionSymbol v, KnownChainIdSymbol c) => SomeBlockHeaderDb (BlockHeaderDb_ v c) -someBlockHeaderDbVal :: ChainwebVersion -> ChainId -> BlockHeaderDb -> SomeBlockHeaderDb -someBlockHeaderDbVal v cid db = case someChainwebVersionVal v of - (SomeChainwebVersionT (Proxy :: Proxy vt)) -> case someChainIdVal cid of - (SomeChainIdT (Proxy :: Proxy cidt)) -> SomeBlockHeaderDb (BlockHeaderDb_ @vt @cidt db) +someBlockHeaderDbVal :: HasVersion => ChainId -> BlockHeaderDb -> SomeBlockHeaderDb +someBlockHeaderDbVal cid db = case someChainwebVersionVal of + SomeChainwebVersionT (Proxy :: Proxy vt) -> case someChainIdVal cid of + SomeChainIdT (Proxy :: Proxy cidt) -> SomeBlockHeaderDb (BlockHeaderDb_ @vt @cidt db) -- -------------------------------------------------------------------------- -- -- Query Parameters @@ -467,48 +465,15 @@ p2pHeaderApi . Proxy (P2pHeaderApi v c) p2pHeaderApi = Proxy --- -------------------------------------------------------------------------- -- -type BlocksApi_ - = "block" - :> PageParams (NextItem BlockHash) - :> FilterParams - :> Get '[JSON] BlockPage - --- | @GET \/chainweb\/\\/\\/chain\/\\/block@ --- --- Returns blocks in the block header tree database in ascending order --- with respect to the children relation. --- --- Note that for blocks on different branches, the order isn't determined. --- Therefore a block of higher block height can be returned before a block of --- lower block height. --- -type BlocksApi (v :: ChainwebVersionT) (c :: ChainIdT) - = 'ChainwebEndpoint v :> ChainEndpoint c :> Reassoc BlocksApi_ - --- -------------------------------------------------------------------------- -- -type BranchBlocksApi_ - = "block" :> "branch" - :> PageParams (NextItem BlockHash) - :> MinHeightParam - :> MaxHeightParam - :> ReqBody '[JSON] (BranchBounds BlockHeaderDb) - :> Post '[JSON] BlockPage - -type BranchBlocksApi (v :: ChainwebVersionT) (c :: ChainIdT) - = 'ChainwebEndpoint v :> ChainEndpoint c :> Reassoc BranchBlocksApi_ - -- -------------------------------------------------------------------------- -- -- | BlockHeaderDb Api -- type BlockHeaderDbApi v c = HashesApi v c :<|> HeadersApi v c - :<|> BlocksApi v c :<|> HeaderApi v c :<|> BranchHashesApi v c :<|> BranchHeadersApi v c - :<|> BranchBlocksApi v c -- | Restricted P2P BlockHeader DB API -- @@ -522,41 +487,37 @@ type P2pBlockHeaderDbApi v c data HeaderUpdate = HeaderUpdate { _huHeader :: !(ObjectEncoded BlockHeader) - , _huPayloadWithOutputs :: !(Maybe PayloadWithOutputs) - , _huTxCount :: !Int , _huPowHash :: !Text , _huTarget :: !Text } deriving (Show, Eq) -headerUpdateProperties :: KeyValue e kv => HeaderUpdate -> [kv] +headerUpdateProperties :: HasVersion => KeyValue e kv => HeaderUpdate -> [kv] headerUpdateProperties o = [ "header" .= _huHeader o - , "txCount" .= _huTxCount o , "powHash" .= _huPowHash o , "target" .= _huTarget o - ] <> concatMap maybeToList - [ ("payloadWithOutputs" .=) <$> _huPayloadWithOutputs o ] {-# INLINE headerUpdateProperties #-} -instance ToJSON HeaderUpdate where +instance HasVersion => ToJSON HeaderUpdate where toJSON = object . headerUpdateProperties toEncoding = pairs . mconcat . headerUpdateProperties {-# INLINE toJSON #-} {-# INLINE toEncoding #-} -instance FromJSON HeaderUpdate where +instance HasVersion => FromJSON HeaderUpdate where parseJSON = withObject "HeaderUpdate" $ \o -> HeaderUpdate <$> o .: "header" - <*> o .:? "payloadWithOutputs" - <*> o .: "txCount" <*> o .: "powHash" <*> o .: "target" {-# INLINE parseJSON #-} type BlockStreamApi_ = - "block" :> "updates" :> Raw :<|> + -- FIXME: the block API endpoint should be part of the payload provider. + -- Consensus has no access to the payload data + -- "block" :> "updates" :> Raw :<|> + "header" :> "updates" :> Raw -- | A stream of all new blocks that are accepted into the true `Cut`. diff --git a/src/Chainweb/BlockHeaderDB/RestAPI/Client.hs b/src/Chainweb/BlockHeaderDB/RestAPI/Client.hs index 1cc32f4478..7ddd19ce46 100644 --- a/src/Chainweb/BlockHeaderDB/RestAPI/Client.hs +++ b/src/Chainweb/BlockHeaderDB/RestAPI/Client.hs @@ -34,7 +34,6 @@ module Chainweb.BlockHeaderDB.RestAPI.Client , headersClientJson , headersClientJsonPretty -, blocksClient , branchHashesClient_ , branchHashesClient @@ -44,8 +43,6 @@ module Chainweb.BlockHeaderDB.RestAPI.Client , branchHeadersClientContentType_ , branchHeadersClientJson , branchHeadersClientJsonPretty - -, branchBlocksClient ) where import Control.Monad.Identity @@ -81,8 +78,8 @@ headerClient_ headerClient_ = headerClientContentType_ @v @c @OctetStream headerClient - :: ChainwebVersion - -> ChainId + :: HasVersion + => ChainId -> DbKey BlockHeaderDb -> ClientM BlockHeader headerClient = headerClientJsonBinary @@ -99,32 +96,32 @@ headerClientContentType_ headerClientContentType_ = client (Proxy @(SetRespBodyContentType ct x)) headerClientJson - :: ChainwebVersion - -> ChainId + :: HasVersion + => ChainId -> DbKey BlockHeaderDb -> ClientM BlockHeader -headerClientJson v c k = runIdentity $ do - (SomeSing (SChainwebVersion :: Sing v)) <- return $ toSing (_versionName v) +headerClientJson c k = runIdentity $ do + SomeSing (SChainwebVersion :: Sing v) <- return $ toSing (_versionName implicitVersion) (SomeSing (SChainId :: Sing c)) <- return $ toSing c return $ headerClientContentType_ @v @c @JSON k headerClientJsonPretty - :: ChainwebVersion - -> ChainId + :: HasVersion + => ChainId -> BlockHash -> ClientM BlockHeader -headerClientJsonPretty v c k = runIdentity $ do - (SomeSing (SChainwebVersion :: Sing v)) <- return $ toSing (_versionName v) - (SomeSing (SChainId :: Sing c)) <- return $ toSing c +headerClientJsonPretty c k = runIdentity $ do + SomeSing (SChainwebVersion :: Sing v) <- return $ toSing (_versionName implicitVersion) + SomeSing (SChainId :: Sing c) <- return $ toSing c return $ headerClientContentType_ @v @c @JsonBlockHeaderObject k headerClientJsonBinary - :: ChainwebVersion - -> ChainId + :: HasVersion + => ChainId -> BlockHash -> ClientM BlockHeader -headerClientJsonBinary v c k = runIdentity $ do - (SomeSing (SChainwebVersion :: Sing v)) <- return $ toSing (_versionName v) +headerClientJsonBinary c k = runIdentity $ do + (SomeSing (SChainwebVersion :: Sing v)) <- return $ toSing (_versionName implicitVersion) (SomeSing (SChainId :: Sing c)) <- return $ toSing c return $ headerClientContentType_ @v @c @OctetStream k @@ -143,9 +140,9 @@ headersClient_ headersClient_ = headersClientContentType_ @v @c @JSON headersClient - :: ChainwebVersion + :: HasVersion -- ^ The remote chainweb that you wish to query from. - -> ChainId + => ChainId -- ^ The remote chain within the web that you wish to query from. -> Maybe Limit -- ^ The number of responses per-`Page` to return. @@ -175,9 +172,9 @@ headersClientContentType_ headersClientContentType_ = client $ Proxy @(SetRespBodyContentType ct (HeadersApi v c)) headersClientJson - :: ChainwebVersion + :: HasVersion -- ^ The remote chainweb that you wish to query from. - -> ChainId + => ChainId -- ^ The remote chain within the web that you wish to query from. -> Maybe Limit -- ^ The number of responses per-`Page` to return. @@ -190,15 +187,15 @@ headersClientJson -> Maybe MaxRank -- ^ Filter: no header of `BlockHeight` higher than this will be returned. -> ClientM BlockHeaderPage -headersClientJson v c limit start minr maxr = runIdentity $ do - (SomeSing (SChainwebVersion :: Sing v)) <- return $ toSing (_versionName v) +headersClientJson c limit start minr maxr = runIdentity $ do + (SomeSing (SChainwebVersion :: Sing v)) <- return $ toSing (_versionName implicitVersion) (SomeSing (SChainId :: Sing c)) <- return $ toSing c return $ headersClientContentType_ @v @c @JSON limit start minr maxr headersClientJsonPretty - :: ChainwebVersion + :: HasVersion -- ^ The remote chainweb that you wish to query from. - -> ChainId + => ChainId -- ^ The remote chain within the web that you wish to query from. -> Maybe Limit -- ^ The number of responses per-`Page` to return. @@ -211,30 +208,11 @@ headersClientJsonPretty -> Maybe MaxRank -- ^ Filter: no header of `BlockHeight` higher than this will be returned. -> ClientM BlockHeaderPage -headersClientJsonPretty (FromSingChainwebVersion (SChainwebVersion :: Sing v)) c limit start minr maxr = runIdentity $ do - (SomeSing (SChainId :: Sing c)) <- return $ toSing c +headersClientJsonPretty c limit start minr maxr = runIdentity $ do + SomeSing (SChainwebVersion :: Sing v) <- return $ toSing (_versionName implicitVersion) + SomeSing (SChainId :: Sing c) <- return $ toSing c return $ headersClientContentType_ @v @c @JsonBlockHeaderObject limit start minr maxr -blocksClient - :: ChainwebVersion - -- ^ The remote chainweb that you wish to query from. - -> ChainId - -- ^ The remote chain within the web that you wish to query from. - -> Maybe Limit - -- ^ The number of responses per-`Page` to return. - -> Maybe (NextItem BlockHash) - -- ^ The first header you want to see within the `Page`. - -- `Page` contains a field `_pageNext`, which can be used - -- to produce the value needed for subsequent calls. - -> Maybe MinRank - -- ^ Filter: no header of `BlockHeight` lower than this will be returned. - -> Maybe MaxRank - -- ^ Filter: no header of `BlockHeight` higher than this will be returned. - -> ClientM BlockPage -blocksClient (FromSingChainwebVersion (SChainwebVersion :: Sing v)) c limit start minr maxr = runIdentity $ do - (SomeSing (SChainId :: Sing c)) <- return $ toSing c - return $ client (Proxy @(SetRespBodyContentType JSON (BlocksApi v c))) limit start minr maxr - -- -------------------------------------------------------------------------- -- -- Branch Hashes Client @@ -251,16 +229,16 @@ branchHashesClient_ branchHashesClient_ = client (branchHashesApi @v @c) branchHashesClient - :: ChainwebVersion - -> ChainId + :: HasVersion + => ChainId -> Maybe Limit -> Maybe (NextItem BlockHash) -> Maybe MinRank -> Maybe MaxRank -> BranchBounds BlockHeaderDb -> ClientM BlockHashPage -branchHashesClient v c limit start minr maxr bounds = runIdentity $ do - SomeSing (SChainwebVersion :: Sing v) <- return $ toSing (_versionName v) +branchHashesClient c limit start minr maxr bounds = runIdentity $ do + SomeSing (SChainwebVersion :: Sing v) <- return $ toSing (_versionName implicitVersion) SomeSing (SChainId :: Sing c) <- return $ toSing c return $ branchHashesClient_ @v @c limit start minr maxr bounds @@ -280,8 +258,8 @@ branchHeadersClient_ branchHeadersClient_ = branchHeadersClientContentType_ @v @c @JSON branchHeadersClient - :: ChainwebVersion - -> ChainId + :: HasVersion + => ChainId -> Maybe Limit -> Maybe (NextItem BlockHash) -> Maybe MinRank @@ -306,49 +284,33 @@ branchHeadersClientContentType_ = client $ Proxy @(SetRespBodyContentType ct (BranchHeadersApi v c)) branchHeadersClientJson - :: ChainwebVersion - -> ChainId + :: HasVersion + => ChainId -> Maybe Limit -> Maybe (NextItem BlockHash) -> Maybe MinRank -> Maybe MaxRank -> BranchBounds BlockHeaderDb -> ClientM BlockHeaderPage -branchHeadersClientJson v c limit start minr maxr bounds = runIdentity $ do - SomeSing (SChainwebVersion :: Sing v) <- return $ toSing (_versionName v) +branchHeadersClientJson c limit start minr maxr bounds = runIdentity $ do + SomeSing (SChainwebVersion :: Sing v) <- return $ toSing (_versionName implicitVersion) SomeSing (SChainId :: Sing c) <- return $ toSing c return $ branchHeadersClientContentType_ @v @c @JSON limit start minr maxr bounds branchHeadersClientJsonPretty - :: ChainwebVersion - -> ChainId + :: HasVersion + => ChainId -> Maybe Limit -> Maybe (NextItem BlockHash) -> Maybe MinRank -> Maybe MaxRank -> BranchBounds BlockHeaderDb -> ClientM BlockHeaderPage -branchHeadersClientJsonPretty v c limit start minr maxr bounds = runIdentity $ do - SomeSing (SChainwebVersion :: Sing v) <- return $ toSing (_versionName v) +branchHeadersClientJsonPretty c limit start minr maxr bounds = runIdentity $ do + SomeSing (SChainwebVersion :: Sing v) <- return $ toSing (_versionName implicitVersion) SomeSing (SChainId :: Sing c) <- return $ toSing c return $ branchHeadersClientContentType_ @v @c @JsonBlockHeaderObject limit start minr maxr bounds --- -------------------------------------------------------------------------- -- --- Branch Blocks Client - -branchBlocksClient - :: ChainwebVersion - -> ChainId - -> Maybe Limit - -> Maybe (NextItem BlockHash) - -> Maybe MinRank - -> Maybe MaxRank - -> BranchBounds BlockHeaderDb - -> ClientM BlockPage -branchBlocksClient (FromSingChainwebVersion (SChainwebVersion :: Sing v)) c limit start minr maxr bounds = runIdentity $ do - (SomeSing (SChainId :: Sing c)) <- return $ toSing c - return $ client (Proxy @(SetRespBodyContentType JSON (BranchBlocksApi v c))) limit start minr maxr bounds - -- -------------------------------------------------------------------------- -- -- Hashes Client @@ -364,14 +326,14 @@ hashesClient_ hashesClient_ = client (hashesApi @v @c) hashesClient - :: ChainwebVersion - -> ChainId + :: HasVersion + => ChainId -> Maybe Limit -> Maybe (NextItem BlockHash) -> Maybe MinRank -> Maybe MaxRank -> ClientM BlockHashPage -hashesClient v c limit start minr maxr = runIdentity $ do - (SomeSing (SChainwebVersion :: Sing v)) <- return $ toSing (_versionName v) +hashesClient c limit start minr maxr = runIdentity $ do + (SomeSing (SChainwebVersion :: Sing v)) <- return $ toSing (_versionName implicitVersion) (SomeSing (SChainId :: Sing c)) <- return $ toSing c return $ hashesClient_ @v @c limit start minr maxr diff --git a/src/Chainweb/BlockHeaderDB/RestAPI/Server.hs b/src/Chainweb/BlockHeaderDB/RestAPI/Server.hs index 7bda07fa04..1e2a46f246 100644 --- a/src/Chainweb/BlockHeaderDB/RestAPI/Server.hs +++ b/src/Chainweb/BlockHeaderDB/RestAPI/Server.hs @@ -3,10 +3,11 @@ {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE ImportQualifiedPost #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeAbstractions #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} @@ -31,52 +32,39 @@ module Chainweb.BlockHeaderDB.RestAPI.Server ) where import Control.Applicative +import Chainweb.BlockHeader +import Chainweb.BlockHeaderDB +import Chainweb.BlockHeaderDB.RestAPI +import Chainweb.ChainId +import Chainweb.CutDB (CutDb, blockDiffStream) +import Chainweb.Difficulty (showTargetHex) +import Chainweb.PowHash (powHashBytes) +import Chainweb.RestAPI.Orphans () +import Chainweb.RestAPI.Utils +import Chainweb.TreeDB +import Chainweb.Utils.Paging +import Chainweb.Version import Control.Lens hiding (children, (.=)) import Control.Monad import Control.Monad.Except (MonadError(..)) import Control.Monad.IO.Class - import Data.Aeson import Data.Binary.Builder (fromByteString, fromLazyByteString) -import qualified Data.ByteString as BS -import qualified Data.ByteString.Base16 as B16 +import Data.ByteString qualified as BS +import Data.ByteString.Base16 qualified as B16 import Data.ByteString.Short (fromShort) import Data.Foldable import Data.Function import Data.Functor.Of import Data.IORef -import qualified Data.Map.Strict as Map import Data.Proxy import Data.Text.Encoding (decodeUtf8) -import Numeric.Natural(Natural) - import Network.Wai.EventSource (ServerEvent(..), eventSourceAppIO) - +import Numeric.Natural(Natural) import Prelude hiding (lookup) - import Servant.API import Servant.Server - -import qualified Streaming.Prelude as SP - --- internal modules - -import Chainweb.BlockHash -import Chainweb.BlockHeader -import Chainweb.BlockHeaderDB -import Chainweb.BlockHeaderDB.RestAPI -import Chainweb.ChainId -import Chainweb.CutDB (CutDb, blockDiffStream, cutDbPayloadDb) -import Chainweb.Difficulty (showTargetHex) -import Chainweb.Payload -import Chainweb.Payload.PayloadStore -import Chainweb.PowHash (powHashBytes) -import Chainweb.RestAPI.Orphans () -import Chainweb.RestAPI.Utils -import Chainweb.TreeDB -import Chainweb.Utils.Paging -import Chainweb.Version -import Chainweb.Block +import Streaming.Prelude qualified as SP -- -------------------------------------------------------------------------- -- -- Handler Tools @@ -90,11 +78,11 @@ checkKey -> DbKey db -> m (DbKey db) checkKey !db !k = liftIO (lookup db k) >>= \case - Nothing -> throwError $ err404Msg $ object - [ "reason" .= ("key not found" :: String) - , "key" .= k + Nothing -> throwError $ err404Msg $ object $ concat + [ ["reason" .= ("key not found" :: String)] + , ["key" .= k] ] - Just _ -> pure k + Just !_ -> pure k err404Msg :: ToJSON msg => msg -> ServerError err404Msg msg = setErrJSON msg err404 @@ -210,43 +198,6 @@ branchHeadersHandler db (BranchBoundsLimit boundsLimit) maxLimit limit next minr where effectiveLimit = min maxLimit <$> (limit <|> Just maxLimit) --- | Query Branch Blocks of the database. --- --- Cf. "Chainweb.BlockHeaderDB.RestAPI" for more details --- -branchBlocksHandler - :: CanReadablePayloadCas tbl - => BlockHeaderDb - -> PayloadDb tbl - -> BranchBoundsLimit - -> Limit - -- ^ max limit - -> Maybe Limit - -> Maybe (NextItem BlockHash) - -> Maybe MinRank - -> Maybe MaxRank - -> BranchBounds BlockHeaderDb - -> Handler (Page (NextItem BlockHash) Block) -branchBlocksHandler bhdb pdb (BranchBoundsLimit boundsLimit) maxLimit limit next minr maxr bounds - | fromIntegral (length (_branchBoundsUpper bounds)) > boundsLimit = throwError $ err400Msg $ - "upper branch bound limit exceeded. Only " <> show boundsLimit <> " values are supported." - | fromIntegral (length (_branchBoundsLower bounds)) > boundsLimit = throwError $ err400Msg $ - "lower branch bound limit exceeded. Only " <> show boundsLimit <> " values are supported." - | otherwise = do - nextChecked <- traverse (traverse $ checkKey bhdb) next - checkedBounds <- checkBounds bhdb bounds - liftIO - $ branchEntries bhdb nextChecked (succ <$> effectiveLimit) minr maxr - (_branchBoundsLower checkedBounds) - (_branchBoundsUpper checkedBounds) - $ finiteStreamToPage (key . _blockHeader) effectiveLimit . void . SP.mapM grabPayload - where - effectiveLimit = min maxLimit <$> (limit <|> Just maxLimit) - grabPayload :: BlockHeader -> IO Block - grabPayload h = do - Just x <- lookupPayloadWithHeight pdb (Just $ view blockHeight h) (view blockPayloadHash h) - pure (Block h x) - -- | Every `TreeDb` key within a given range. -- -- Cf. "Chainweb.BlockHeaderDB.RestAPI" for more details @@ -292,33 +243,6 @@ headersHandler db maxLimit limit next minr maxr = do where effectiveLimit = min maxLimit <$> (limit <|> Just maxLimit) --- | Every block within a given range. --- --- Cf. "Chainweb.BlockHeaderDB.RestAPI" for more details --- -blocksHandler - :: CanReadablePayloadCas tbl - => BlockHeaderDb - -> PayloadDb tbl - -> Limit - -- ^ max limit - -> Maybe Limit - -> Maybe (NextItem BlockHash) - -> Maybe MinRank - -> Maybe MaxRank - -> Handler BlockPage -blocksHandler bhdb pdb maxLimit limit next minr maxr = do - nextChecked <- traverse (traverse $ checkKey bhdb) next - liftIO - $ entries bhdb nextChecked (succ <$> effectiveLimit) minr maxr - $ finitePrefixOfInfiniteStreamToPage (key . _blockHeader) effectiveLimit . void . SP.mapM grabPayload - where - effectiveLimit = min maxLimit <$> (limit <|> Just maxLimit) - grabPayload :: BlockHeader -> IO Block - grabPayload h = do - Just x <- lookupPayloadWithHeight pdb (Just $ view blockHeight h) (view blockPayloadHash h) - pure (Block h x) - -- | Query a single 'BlockHeader' by its 'BlockHash' -- -- Cf. "Chainweb.BlockHeaderDB.RestAPI" for more details @@ -330,11 +254,11 @@ headerHandler -> DbKey db -> Handler (DbEntry db) headerHandler db k = liftIO (lookup db k) >>= \case - Nothing -> throwError $ err404Msg $ object - [ "reason" .= ("key not found" :: String) - , "key" .= k + Nothing -> throwError $ err404Msg $ object $ concat + [ ["reason" .= ("key not found" :: String)] + , ["key" .= k] ] - Just e -> pure e + Just !e -> pure e -- -------------------------------------------------------------------------- -- -- BlockHeaderDB API Server @@ -342,22 +266,19 @@ headerHandler db k = liftIO (lookup db k) >>= \case -- Full BlockHeader DB API (used for Service API) -- blockHeaderDbServer - :: CanReadablePayloadCas tbl + :: HasVersion => BlockHeaderDb_ v c - -> PayloadDb tbl -> Server (BlockHeaderDbApi v c) -blockHeaderDbServer (BlockHeaderDb_ db) pdb +blockHeaderDbServer (BlockHeaderDb_ db) = hashesHandler db :<|> headersHandler db defaultEntryLimit - :<|> blocksHandler db pdb defaultEntryLimit :<|> headerHandler db :<|> branchHashesHandler db :<|> branchHeadersHandler db defaultBoundsLimit defaultEntryLimit - :<|> branchBlocksHandler db pdb defaultBoundsLimit defaultEntryLimit -- Restricted P2P BlockHeader DB API -- -p2pBlockHeaderDbServer :: BlockHeaderDb_ v c -> Server (P2pBlockHeaderDbApi v c) +p2pBlockHeaderDbServer :: HasVersion => BlockHeaderDb_ v c -> Server (P2pBlockHeaderDbApi v c) p2pBlockHeaderDbServer (BlockHeaderDb_ db) = headersHandler db p2pEntryLimit :<|> headerHandler db @@ -367,43 +288,37 @@ p2pBlockHeaderDbServer (BlockHeaderDb_ db) -- Multichain Server someBlockHeaderDbServer - :: CanReadablePayloadCas tbl + :: HasVersion => SomeBlockHeaderDb - -> PayloadDb tbl -> SomeServer -someBlockHeaderDbServer (SomeBlockHeaderDb (db :: BlockHeaderDb_ v c)) pdb - = SomeServer (Proxy @(BlockHeaderDbApi v c)) (blockHeaderDbServer db pdb) +someBlockHeaderDbServer (SomeBlockHeaderDb (db :: BlockHeaderDb_ v c)) + = SomeServer (Proxy @(BlockHeaderDbApi v c)) (blockHeaderDbServer db) someBlockHeaderDbServers - :: CanReadablePayloadCas tbl - => ChainwebVersion - -> [(ChainId, BlockHeaderDb)] - -> [(ChainId, PayloadDb tbl)] + :: HasVersion + => ChainMap BlockHeaderDb -> SomeServer -someBlockHeaderDbServers v cdbs pdbs = mconcat - [ someBlockHeaderDbServer (someBlockHeaderDbVal v cid cdb) pdb - | (cid, (cdb, pdb)) <- - Map.toList $ Map.intersectionWith (,) (Map.fromList cdbs) (Map.fromList pdbs) - ] +someBlockHeaderDbServers = ifoldMap $ \cid cdb -> + someBlockHeaderDbServer (someBlockHeaderDbVal cid cdb) -someP2pBlockHeaderDbServer :: SomeBlockHeaderDb -> SomeServer +someP2pBlockHeaderDbServer :: HasVersion => SomeBlockHeaderDb -> SomeServer someP2pBlockHeaderDbServer (SomeBlockHeaderDb (db :: BlockHeaderDb_ v c)) = SomeServer (Proxy @(P2pBlockHeaderDbApi v c)) (p2pBlockHeaderDbServer db) -someP2pBlockHeaderDbServers :: ChainwebVersion -> [(ChainId, BlockHeaderDb)] -> SomeServer -someP2pBlockHeaderDbServers v = mconcat - . fmap (someP2pBlockHeaderDbServer . uncurry (someBlockHeaderDbVal v)) +someP2pBlockHeaderDbServers :: HasVersion => ChainMap BlockHeaderDb -> SomeServer +someP2pBlockHeaderDbServers = ifoldMap + (\cid bhdb -> someP2pBlockHeaderDbServer (someBlockHeaderDbVal cid bhdb)) -- -------------------------------------------------------------------------- -- -- BlockHeader Event Stream -someBlockStreamServer :: CanReadablePayloadCas tbl => ChainwebVersion -> CutDb tbl -> SomeServer -someBlockStreamServer (FromSingChainwebVersion (SChainwebVersion :: Sing v)) cdb = - SomeServer (Proxy @(BlockStreamApi v)) $ - blockStreamHandler cdb True :<|> blockStreamHandler cdb False +someBlockStreamServer :: HasVersion => CutDb l -> SomeServer +someBlockStreamServer cdb = runIdentity $ do + SomeChainwebVersionT @v _ <- return someChainwebVersionVal + Identity $ SomeServer (Proxy @(BlockStreamApi v)) $ blockStreamHandler cdb -blockStreamHandler :: forall tbl. CanReadablePayloadCas tbl => CutDb tbl -> Bool -> Tagged Handler Application -blockStreamHandler db withPayloads = Tagged $ \req resp -> do +blockStreamHandler :: HasVersion => CutDb l -> Tagged Handler Application +blockStreamHandler db = Tagged $ \req resp -> do streamRef <- newIORef $ SP.map f $ SP.mapM g $ SP.concat $ blockDiffStream db eventSourceAppIO (run streamRef) req resp where @@ -412,20 +327,12 @@ blockStreamHandler db withPayloads = Tagged $ \req resp -> do Nothing -> return CloseEvent Just (cur, !s') -> cur <$ writeIORef var s' - cas :: PayloadDb tbl - cas = view cutDbPayloadDb db - g :: BlockHeader -> IO HeaderUpdate - g bh = do - Just x <- lookupPayloadWithHeight cas (Just $ view blockHeight bh) (view blockPayloadHash bh) - pure $ HeaderUpdate - { _huHeader = ObjectEncoded bh - , _huPayloadWithOutputs = - x <$ guard withPayloads - , _huTxCount = length $ _payloadWithOutputsTransactions x - , _huPowHash = decodeUtf8 . B16.encode . BS.reverse . fromShort . powHashBytes $ view blockPow bh - , _huTarget = showTargetHex $ view blockTarget bh - } + g bh = pure $ HeaderUpdate + { _huHeader = ObjectEncoded bh + , _huPowHash = decodeUtf8 . B16.encode . BS.reverse . fromShort . powHashBytes $ view blockPow bh + , _huTarget = showTargetHex $ view blockTarget bh + } f :: HeaderUpdate -> ServerEvent f hu = ServerEvent (Just $ fromByteString "BlockHeader") Nothing diff --git a/src/Chainweb/BlockHeight.hs b/src/Chainweb/BlockHeight.hs index a9f1dbad0a..46ffde148b 100644 --- a/src/Chainweb/BlockHeight.hs +++ b/src/Chainweb/BlockHeight.hs @@ -37,19 +37,14 @@ module Chainweb.BlockHeight ) where import Control.DeepSeq - +import Chainweb.Crypto.MerkleLog +import Chainweb.MerkleUniverse +import Chainweb.Utils +import Chainweb.Utils.Serialization import Data.Aeson import Data.Hashable import Data.Word - import GHC.Generics (Generic) - --- Internal imports - -import Chainweb.Crypto.MerkleLog -import Chainweb.MerkleUniverse -import Chainweb.Utils.Serialization - import Numeric.Additive -- -------------------------------------------------------------------------- -- @@ -62,7 +57,9 @@ newtype BlockHeight = BlockHeight { getBlockHeight :: Word64 } ( Hashable, ToJSON, FromJSON , AdditiveSemigroup, AdditiveAbelianSemigroup, AdditiveMonoid , Num, Integral, Real, Enum, Bounded + , HasTextRepresentation ) + instance Show BlockHeight where show (BlockHeight b) = show b instance MerkleHashAlgorithm a => IsMerkleLogEntry a ChainwebHashTag BlockHeight where diff --git a/src/Chainweb/BlockPayloadHash.hs b/src/Chainweb/BlockPayloadHash.hs index 02d3a4dee0..8402652ad7 100644 --- a/src/Chainweb/BlockPayloadHash.hs +++ b/src/Chainweb/BlockPayloadHash.hs @@ -8,6 +8,8 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE DerivingVia #-} -- | -- Module: Chainweb.BlockPayloadHash @@ -36,7 +38,6 @@ import Control.DeepSeq import Control.Monad import Data.Aeson -import Data.ByteArray qualified as BA import Data.Hashable import GHC.Generics (Generic) @@ -84,11 +85,12 @@ type BlockPayloadHash = BlockPayloadHash_ ChainwebMerkleHashAlgorithm newtype BlockPayloadHash_ a = BlockPayloadHash (MerkleLogHash a) deriving (Show, Eq, Ord, Generic) deriving anyclass (NFData) - deriving newtype (BA.ByteArrayAccess) - deriving newtype (Hashable, ToJSON, FromJSON) + deriving newtype (Bytes, Hashable, ToJSON, FromJSON) deriving newtype (ToJSONKey, FromJSONKey) + deriving newtype (HasTextRepresentation) + deriving (IsMerkleLogEntry a ChainwebHashTag) via MerkleRootLogEntry a 'BlockPayloadHashTag -encodeBlockPayloadHash :: BlockPayloadHash_ a -> Put +encodeBlockPayloadHash :: MerkleHashAlgorithm a => BlockPayloadHash_ a -> Put encodeBlockPayloadHash (BlockPayloadHash w) = encodeMerkleLogHash w decodeBlockPayloadHash @@ -96,19 +98,6 @@ decodeBlockPayloadHash => Get (BlockPayloadHash_ a) decodeBlockPayloadHash = BlockPayloadHash <$!> decodeMerkleLogHash -instance MerkleHashAlgorithm a => IsMerkleLogEntry a ChainwebHashTag (BlockPayloadHash_ a) where - type Tag (BlockPayloadHash_ a) = 'BlockPayloadHashTag - toMerkleNode = encodeMerkleTreeNode - fromMerkleNode = decodeMerkleTreeNode - {-# INLINE toMerkleNode #-} - {-# INLINE fromMerkleNode #-} - -instance HasTextRepresentation BlockPayloadHash where - toText (BlockPayloadHash h) = toText h - fromText = fmap BlockPayloadHash . fromText - {-# INLINE toText #-} - {-# INLINE fromText #-} - nullBlockPayloadHash :: MerkleHashAlgorithm a => BlockPayloadHash_ a nullBlockPayloadHash = BlockPayloadHash nullHashBytes {-# INLINE nullBlockPayloadHash #-} diff --git a/src/Chainweb/ChainId.hs b/src/Chainweb/ChainId.hs index c95f165ba0..689baa5cb4 100644 --- a/src/Chainweb/ChainId.hs +++ b/src/Chainweb/ChainId.hs @@ -3,10 +3,13 @@ {-# LANGUAGE DeriveFoldable #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE ImportQualifiedPost #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} @@ -17,7 +20,6 @@ {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ViewPatterns #-} -{-# LANGUAGE DeriveTraversable #-} -- | -- Module: Chainweb.ChainId @@ -31,10 +33,9 @@ module Chainweb.ChainId ( ChainIdException(..) , ChainId +, pattern ChainId , HasChainId(..) , checkChainId -, chainIdToText -, chainIdFromText -- * Serialization , encodeChainId @@ -64,36 +65,35 @@ module Chainweb.ChainId , onChains , onChain , chainZip +, chainIntersect + +-- * Configuration Utils +, prefixLongCid +, suffixHelpCid +, helpCid +, pEnableConfigCid ) where -import Control.Applicative import Control.DeepSeq +import Chainweb.Crypto.MerkleLog +import Chainweb.MerkleUniverse +import Chainweb.Utils +import Chainweb.Utils.Serialization +import Configuration.Utils hiding (Lens') import Control.Lens hiding ((.=)) -import Control.Monad.Catch (Exception, MonadThrow) - -import Data.Aeson +import Control.Monad.Catch (Exception, MonadThrow, displayException) import Data.Aeson.Types (toJSONKeyText) -import Data.Hashable (Hashable(..)) import Data.HashMap.Strict (HashMap) -import qualified Data.HashMap.Strict as HM +import Data.HashMap.Strict qualified as HM +import Data.Hashable (Hashable(..)) import Data.Kind import Data.Proxy import Data.Semialign -import qualified Data.Text as T -import Data.These +import Data.Singletons hiding (Index) +import Data.Text qualified as T import Data.Word (Word32) - import GHC.Generics (Generic) -import GHC.TypeLits - --- internal imports - -import Chainweb.Crypto.MerkleLog -import Chainweb.MerkleUniverse -import Chainweb.Utils -import Chainweb.Utils.Serialization - -import Data.Singletons hiding (Index) +import GHC.TypeLits hiding (Mod) -- -------------------------------------------------------------------------- -- -- Exceptions @@ -124,16 +124,20 @@ instance Exception ChainIdException -- * For some arbitrary but fixed chain id consider using 'someChainId'. -- newtype ChainId :: Type where - ChainId :: Word32 -> ChainId + ChainId' :: Word32 -> ChainId deriving stock (Show, Read, Eq, Ord, Generic) - deriving anyclass (Hashable, ToJSON, FromJSON, NFData) + deriving newtype (Hashable, ToJSON, FromJSON, NFData, HasTextRepresentation) + +pattern ChainId :: Word32 -> ChainId +pattern ChainId n <- ChainId' n +{-# COMPLETE ChainId #-} instance ToJSONKey ChainId where toJSONKey = toJSONKeyText toText {-# INLINE toJSONKey #-} instance FromJSONKey ChainId where - fromJSONKey = FromJSONKeyTextParser (either fail return . eitherFromText) + fromJSONKey = FromJSONKeyTextParser (either (fail . displayException) return . fromText) {-# INLINE fromJSONKey #-} class HasChainId a where @@ -177,29 +181,15 @@ checkChainId expected actual = _chainId <$> check ChainIdMismatch (_chainId <$> expected) (_chainId <$> actual) {-# INLINE checkChainId #-} -chainIdToText :: ChainId -> T.Text -chainIdToText (ChainId i) = sshow i -{-# INLINE chainIdToText #-} - -chainIdFromText :: MonadThrow m => T.Text -> m ChainId -chainIdFromText = fmap ChainId . treadM -{-# INLINE chainIdFromText #-} - -instance HasTextRepresentation ChainId where - toText = chainIdToText - {-# INLINE toText #-} - fromText = chainIdFromText - {-# INLINE fromText #-} - -- -------------------------------------------------------------------------- -- -- Serialization encodeChainId :: ChainId -> Put -encodeChainId (ChainId w32) = putWord32le w32 +encodeChainId (ChainId' w32) = putWord32le w32 {-# INLINE encodeChainId #-} decodeChainId :: Get ChainId -decodeChainId = ChainId <$> getWord32le +decodeChainId = ChainId' <$> getWord32le {-# INLINE decodeChainId #-} decodeChainIdChecked @@ -228,9 +218,9 @@ instance KnownSymbol n => KnownChainIdSymbol ('ChainIdT n) where type ChainIdSymbol ('ChainIdT n) = n chainIdSymbolVal _ = T.pack $ symbolVal (Proxy @n) -someChainIdVal :: ChainId -> SomeChainIdT -someChainIdVal cid = case someSymbolVal (T.unpack (toText cid)) of - (SomeSymbol (Proxy :: Proxy v)) -> SomeChainIdT (Proxy @('ChainIdT v)) +someChainIdVal :: HasChainId c => c -> SomeChainIdT +someChainIdVal cid = case someSymbolVal (T.unpack (toText (_chainId cid))) of + (SomeSymbol (Proxy :: Proxy cid)) -> SomeChainIdT (Proxy @('ChainIdT cid)) -- -------------------------------------------------------------------------- -- -- Singletons @@ -264,11 +254,11 @@ pattern FromSingChainId sng <- ((\cid -> withSomeSing cid SomeSing) -> SomeSing -- of 'ChainId' for alternative ways to obtain 'ChainId' values. -- unsafeChainId :: Word32 -> ChainId -unsafeChainId = ChainId +unsafeChainId = ChainId' {-# INLINE unsafeChainId #-} chainIdInt :: Integral i => ChainId -> i -chainIdInt (ChainId cid) = int cid +chainIdInt (ChainId' cid) = int cid {-# INLINE chainIdInt #-} -- -------------------------------------------------------------------------- -- @@ -278,56 +268,92 @@ chainIdInt (ChainId cid) = int cid -- exists a value for each chain? -- | Values keyed by `ChainId`s, or a single value that applies for all chains. -data ChainMap a = AllChains a | OnChains (HashMap ChainId a) - deriving stock (Eq, Functor, Foldable, Traversable, Generic, Ord, Show) - deriving anyclass (Hashable, NFData) +newtype ChainMap a = ChainMap (HashMap ChainId a) + deriving stock (Traversable, Generic) + deriving newtype (Eq, Hashable, Functor, Foldable, NFData, Ord, Show) +instance Semigroup (ChainMap a) where + (<>) = chainZip const +instance Monoid (ChainMap a) where + mempty = ChainMap mempty +instance FunctorWithIndex ChainId ChainMap where + imap f (ChainMap a) = ChainMap $ imap f a + +instance FoldableWithIndex ChainId ChainMap where + ifoldMap f (ChainMap a) = ifoldMap f a +instance TraversableWithIndex ChainId ChainMap where + itraverse f (ChainMap a) = ChainMap <$> itraverse f a instance Unzip ChainMap where unzip = unzipDefault --- TODO: fix this. This is not a legal instance, because `align` can change the --- shape from `AllChains` to `OnChains`. This breaks the "alignedness" law. instance Semialign ChainMap where - align (OnChains l) (OnChains r) = OnChains $ align l r - align (OnChains l) (AllChains r) = OnChains $ fmap (`These` r) l - align (AllChains l) (OnChains r) = OnChains $ fmap (l `These`) r - align (AllChains l) (AllChains r) = AllChains $ These l r + align (ChainMap l) (ChainMap r) = ChainMap $ align l r --- | A smart constructor, @onChains = OnChains . HM.fromList@. +-- | A smart constructor, @onChains = ChainMap . HM.fromList@. onChains :: [(ChainId, a)] -> ChainMap a -onChains = OnChains . HM.fromList +onChains = ChainMap . HM.fromList --- | A smart constructor, @onChain c a = OnChains (HM.singleton c a)@. +-- | A smart constructor, @onChain c a = ChainMap (HM.singleton c a)@. onChain :: ChainId -> a -> ChainMap a -onChain c a = OnChains (HM.singleton c a) +onChain c a = ChainMap (HM.singleton c a) -- | Zips two `ChainMap`s on their chain IDs. chainZip :: (a -> a -> a) -> ChainMap a -> ChainMap a -> ChainMap a -chainZip f (OnChains l) (OnChains r) = OnChains $ HM.unionWith f l r -chainZip f (OnChains l) (AllChains r) = OnChains $ fmap (`f` r) l -chainZip f (AllChains l) (OnChains r) = OnChains $ fmap (l `f`) r -chainZip f (AllChains l) (AllChains r) = AllChains $ f l r +chainZip f (ChainMap l) (ChainMap r) = ChainMap $ HM.unionWith f l r + +chainIntersect :: (a -> b -> c) -> ChainMap a -> ChainMap b -> ChainMap c +chainIntersect f (ChainMap l) (ChainMap r) = ChainMap $ HM.intersectionWith f l r instance ToJSON a => ToJSON (ChainMap a) where - toJSON (AllChains a) = object - [ "allChains" .= a - ] - toJSON (OnChains m) = toJSON m + toJSON (ChainMap m) = toJSON m instance FromJSON a => FromJSON (ChainMap a) where parseJSON = withObject "ChainMap" $ \o -> - (AllChains <$> o .: "allChains") <|> OnChains <$> parseJSON (Object o) + ChainMap <$> parseJSON (Object o) makePrisms ''ChainMap -- | Provides access to the value at a `ChainId`, if it exists. atChain :: HasChainId cid => cid -> Fold (ChainMap a) a atChain cid = folding $ \case - OnChains m -> m ^. at (_chainId cid) - AllChains a -> Just a + ChainMap m -> m ^. at (_chainId cid) type instance Index (ChainMap a) = ChainId type instance IxValue (ChainMap a) = a instance IxedGet (ChainMap a) where - ixg i = atChain i + ixg = atChain +instance Ixed (ChainMap a) where + ix i = at i . _Just +instance At (ChainMap a) where + at cid f = \case + ChainMap m -> ChainMap <$> at cid f m + +-- -------------------------------------------------------------------------- -- +-- Configuration Utils + +prefixLongCid :: HasName f => ChainId -> String -> Mod f a +prefixLongCid cid = prefixLong (Just p) + where + p = "chain-" <> T.unpack (toText cid) + +suffixHelpCid :: ChainId -> String -> Mod f a +suffixHelpCid cid = suffixHelp (Just s) + where + s = "chain-" <> T.unpack (toText cid) + +helpCid :: ChainId -> String -> Mod f a +helpCid cid t = suffixHelp (Just "the respective chain") t + <> mconcat [ hidden <> internal | chainIdInt @Int cid /= 0 ] + +pEnableConfigCid + :: String + -> ChainId + -> (ChainId -> MParser a) + -> MParser (EnableConfig a) +pEnableConfigCid comp cid pConfig = id + <$< enableConfigEnabled .:: enableDisableFlag + % prefixLongCid cid comp + <> help ("whether " <> comp <> " is enabled or disabled for the respective chain") + <> mconcat [ hidden <> internal | chainIdInt @Int cid /= 0 ] + <*< enableConfigConfig %:: pConfig cid diff --git a/src/Chainweb/ChainValue.hs b/src/Chainweb/ChainValue.hs index fe01f64f73..dd5822b464 100644 --- a/src/Chainweb/ChainValue.hs +++ b/src/Chainweb/ChainValue.hs @@ -1,11 +1,10 @@ {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveFoldable #-} -{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ImportQualifiedPost #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} @@ -31,18 +30,17 @@ module Chainweb.ChainValue ) where import Control.DeepSeq +import Chainweb.ChainId +import Chainweb.Storage.Table +import Chainweb.Utils (HasTextRepresentation(..), EncodingException (TextFormatException)) import Control.Lens - +import Control.Monad.Catch +import Data.Aeson +import Data.Aeson.Types (toJSONKeyText) import Data.Hashable - +import Data.Text qualified as T import GHC.Generics --- internal modules - -import Chainweb.ChainId - -import Chainweb.Storage.Table - -- -------------------------------------------------------------------------- -- -- Tag Values With a ChainId @@ -63,6 +61,24 @@ instance TraversableWithIndex ChainId ChainValue where instance FoldableWithIndex ChainId ChainValue instance FunctorWithIndex ChainId ChainValue +instance HasTextRepresentation a => HasTextRepresentation (ChainValue a) where + toText (ChainValue cid a) = toText cid <> "@" <> toText a + fromText t = case T.breakOn "@" t of + (c, r) + | T.null r -> throwM $ + TextFormatException $ "ChainValue: faialed to parse: " <> t + | otherwise -> ChainValue <$> fromText c <*> fromText (T.tail r) + {-# INLINE toText #-} + {-# INLINE fromText #-} + +instance HasTextRepresentation a => ToJSON (ChainValue a) where + toJSON = String . toText + {-# INLINE toJSON #-} + +instance HasTextRepresentation a => ToJSONKey (ChainValue a) where + toJSONKey = toJSONKeyText toText + {-# INLINE toJSONKey #-} + -- | If a type is already an instance of 'IsCasValue', adding the chain does -- preserve this property. By also wrapping the key it is possible to shard -- the CAS by chain value. diff --git a/src/Chainweb/Chainweb.hs b/src/Chainweb/Chainweb.hs index 28c6246db9..1a042a9259 100644 --- a/src/Chainweb/Chainweb.hs +++ b/src/Chainweb/Chainweb.hs @@ -7,6 +7,7 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE ImportQualifiedPost #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiWayIf #-} {-# LANGUAGE NumericUnderscores #-} @@ -44,13 +45,8 @@ -- module Chainweb.Chainweb ( --- * GC Configuration - ChainDatabaseGcConfig(..) -, chainDatabaseGcToText -, chainDatabaseGcFromText - -- * Chainweb Resources -, Chainweb(..) + Chainweb(..) , chainwebChains , chainwebCutResources , chainwebHostAddress @@ -59,20 +55,20 @@ module Chainweb.Chainweb , chainwebLogger , chainwebSocket , chainwebPeer -, chainwebPayloadDb -, chainwebPactData , chainwebThrottler , chainwebPutPeerThrottler , chainwebMempoolThrottler , chainwebConfig , chainwebServiceSocket , chainwebBackup +, chainwebScheduler +, chainwebManager , StartedChainweb(..) , ChainwebStatus(..) , NowServing(..) -- ** Mempool integration -, Mempool.pact4TransactionConfig +, Mempool.pactTransactionConfig , validatingMempoolConfig , withChainweb @@ -91,10 +87,8 @@ module Chainweb.Chainweb -- * Cut Config , CutConfig(..) -, cutPruneChainDatabase , cutFetchTimeout , cutInitialBlockHeightLimit -, cutFastForwardBlockHeightLimit , defaultCutConfig ) where @@ -102,28 +96,27 @@ module Chainweb.Chainweb import Configuration.Utils hiding (Error, Lens', disabled) import Control.Concurrent (threadDelay) -import Control.Concurrent.Async -import Control.Concurrent.MVar (MVar, readMVar) import Control.DeepSeq +import Control.Exception.Safe import Control.Lens hiding ((.=), (<.>)) import Control.Monad -import Control.Monad.Catch (fromException) +import Control.Monad.IO.Class +import Control.Monad.Trans.Resource hiding (throwM) import Data.Foldable -import Data.Function (on) -import qualified Data.HashMap.Strict as HM -import Data.List (isPrefixOf, sortBy) -import qualified Data.List as L +import Data.HashMap.Strict qualified as HM +import Data.HashSet qualified as HS +import Data.List (isPrefixOf) +import Data.List qualified as L +import Data.LogMessage (LogFunctionText) import Data.Maybe -import qualified Data.Text as T -import Data.These (These(..)) -import qualified Data.Vector as V +import Data.Text qualified as T import Data.Word -import GHC.Generics +import GHC.Generics hiding (to) -import qualified Network.HTTP.Client as HTTP -import qualified Network.HTTP2.Client as HTTP2 +import Network.HTTP.Client qualified as HTTP +import Network.HTTP2.Client qualified as HTTP2 import Network.Socket (Socket) import Network.Wai import Network.Wai.Handler.Warp hiding (Port) @@ -139,84 +132,64 @@ import System.LogLevel -- internal modules import Chainweb.Backup -import Chainweb.BlockHeader import Chainweb.BlockHeaderDB (BlockHeaderDb) +import Chainweb.BlockHeaderDB.PruneForks qualified as PruneForks import Chainweb.ChainId import Chainweb.Chainweb.ChainResources import Chainweb.Chainweb.Configuration import Chainweb.Chainweb.CutResources -import Chainweb.Chainweb.MempoolSyncClient import Chainweb.Chainweb.MinerResources import Chainweb.Chainweb.PeerResources -import Chainweb.Chainweb.PruneChainDatabase import qualified Chainweb.Counter as Counter import Chainweb.Cut import Chainweb.CutDB import Chainweb.HostAddress import Chainweb.Logger -import qualified Chainweb.Mempool.InMemTypes as Mempool -import qualified Chainweb.Mempool.Mempool as Mempool -import Chainweb.Mempool.P2pConfig +import Chainweb.Pact.Mempool.InMem.ValidatingConfig +import Chainweb.Pact.Mempool.Mempool qualified as Mempool import Chainweb.Miner.Config -import qualified Chainweb.OpenAPIValidation as OpenAPIValidation -import Chainweb.Pact.Backend.Types(IntraBlockPersistence(..)) -import Chainweb.Pact.RestAPI.Server (PactServerData(..)) -import Chainweb.Pact.Types (PactServiceConfig(..)) -import Chainweb.Pact4.Validations -import Chainweb.Payload.PayloadStore -import Chainweb.Payload.PayloadStore.RocksDB +import Chainweb.OpenAPIValidation qualified as OpenAPIValidation +import Chainweb.Pact.Transaction qualified as Pact import Chainweb.RestAPI import Chainweb.RestAPI.NetworkID -import qualified Chainweb.Pact4.Transaction as Pact4 +import Chainweb.Scheduler (Scheduler, scheduleEvery) +import Chainweb.Storage.Table.RocksDB import Chainweb.Utils import Chainweb.Utils.RequestLog import Chainweb.Version -import Chainweb.Version.Guards import Chainweb.WebBlockHeaderDB -import Chainweb.WebPactExecutionService - -import Chainweb.Storage.Table.RocksDB - -import Data.LogMessage (LogFunctionText) import P2P.Node.Configuration import P2P.Node.PeerDB (PeerDb) import P2P.Peer -import qualified Pact.Types.ChainMeta as P -import qualified Pact.Types.Command as P - -- -------------------------------------------------------------------------- -- -- Chainweb Resources -data Chainweb logger tbl = Chainweb +data Chainweb logger = Chainweb { _chainwebHostAddress :: !HostAddress - , _chainwebChains :: !(HM.HashMap ChainId (ChainResources logger)) - , _chainwebCutResources :: !(CutResources logger tbl) - , _chainwebMiner :: !(Maybe (MinerResources logger tbl)) - , _chainwebCoordinator :: !(Maybe (MiningCoordination logger tbl)) + , _chainwebChains :: !(ChainMap (ChainResources logger)) + , _chainwebCutResources :: !(CutResources logger) + , _chainwebMiner :: !(Maybe (MinerResources logger)) + , _chainwebCoordinator :: !(Maybe (MiningCoordination logger)) , _chainwebLogger :: !logger , _chainwebPeer :: !(PeerResources logger) - , _chainwebPayloadDb :: !(PayloadDb tbl) , _chainwebManager :: !HTTP.Manager - , _chainwebPactData :: ![(ChainId, PactServerData logger tbl)] + -- , _chainwebPactData :: ![(ChainId, PactServerData logger tbl)] , _chainwebThrottler :: !(Throttle Address) , _chainwebPutPeerThrottler :: !(Throttle Address) , _chainwebMempoolThrottler :: !(Throttle Address) , _chainwebConfig :: !ChainwebConfiguration , _chainwebServiceSocket :: !(Port, Socket) , _chainwebBackup :: !(BackupEnv logger) + , _chainwebScheduler :: !Scheduler } makeLenses ''Chainweb -chainwebSocket :: Getter (Chainweb logger t) Socket +chainwebSocket :: Getter (Chainweb logger) Socket chainwebSocket = chainwebPeer . peerResSocket -instance HasChainwebVersion (Chainweb logger t) where - _chainwebVersion = _chainwebVersion . _chainwebCutResources - {-# INLINE _chainwebVersion #-} - -- Intializes all service API chainweb components but doesn't start any networking. -- withChainweb @@ -224,118 +197,48 @@ withChainweb . Logger logger => ChainwebConfiguration -> logger + -> Scheduler -> RocksDb -> FilePath -> FilePath - -> Bool -> (StartedChainweb logger -> IO ()) -> IO () -withChainweb c logger rocksDb pactDbDir backupDir resetDb inner = - withPeerResources v (view configP2p confWithBootstraps) logger $ \logger' peer -> - withSocket serviceApiPort serviceApiHost $ \serviceSock -> do - let conf' = confWithBootstraps - & set configP2p (_peerResConfig peer) - & set (configServiceApi . serviceApiConfigPort) (fst serviceSock) - withChainwebInternal - conf' - logger' - peer - serviceSock - rocksDb - pactDbDir - backupDir - resetDb - inner +withChainweb c logger sched rocksDb defaultPactDbDir backupDir inner = + withVersion (c ^. configChainwebVersion) $ + withPeerResources (view configP2p confWithBootstraps) logger $ \logger' peerRes -> do + withSocket serviceApiPort serviceApiHost $ \serviceSock -> do + let conf' = confWithBootstraps + & set configP2p (_peerResConfig peerRes) + & set (configServiceApi . serviceApiConfigPort) (fst serviceSock) + withChainwebInternal + conf' + logger' + peerRes + serviceSock + sched + rocksDb + defaultPactDbDir + backupDir + inner where serviceApiPort = _serviceApiConfigPort $ _configServiceApi c serviceApiHost = _serviceApiConfigInterface $ _configServiceApi c - v = _chainwebVersion c - -- Here we inject the hard-coded bootstrap peer infos for the configured -- chainweb version into the configuration. confWithBootstraps | _p2pConfigIgnoreBootstrapNodes (_configP2p c) = c | otherwise = configP2p . p2pConfigKnownPeers - %~ (\x -> L.nub $ x <> _versionBootstraps v) $ c - --- TODO: The type InMempoolConfig contains parameters that should be --- configurable as well as parameters that are determined by the chainweb --- version or the chainweb protocol. These should be separated in to two --- different types. - -validatingMempoolConfig - :: ChainId - -> ChainwebVersion - -> Mempool.GasLimit - -> Mempool.GasPrice - -> MVar PactExecutionService - -> Mempool.InMemConfig Pact4.UnparsedTransaction -validatingMempoolConfig cid v gl gp mv = Mempool.InMemConfig - { Mempool._inmemTxCfg = txcfg - , Mempool._inmemTxBlockSizeLimit = gl - , Mempool._inmemTxMinGasPrice = gp - , Mempool._inmemMaxRecentItems = maxRecentLog - , Mempool._inmemPreInsertPureChecks = preInsertSingle - , Mempool._inmemPreInsertBatchChecks = preInsertBatch - , Mempool._inmemCurrentTxsSize = currentTxsSize - } - where - txcfg = Mempool.pact4TransactionConfig - -- The mempool doesn't provide a chain context to the codec which means - -- that the latest version of the parser is used. - - maxRecentLog = 2048 - - currentTxsSize = 1024 * 1024 -- ~16MB per mempool - -- 1M items is is sufficient for supporing about 12 TPS per chain, which - -- is about 360 tx per block. Larger TPS values would result in false - -- negatives in the set. - - -- | Validation: Is this TX associated with the correct `ChainId`? - -- - preInsertSingle :: Pact4.UnparsedTransaction -> Either Mempool.InsertError Pact4.UnparsedTransaction - preInsertSingle tx = do - let !pay = Pact4.payloadObj . P._cmdPayload $ tx - pcid = P._pmChainId $ P._pMeta pay - sigs = P._cmdSigs tx - ver = P._pNetworkId pay - if | not $ assertParseChainId pcid -> Left $ Mempool.InsertErrorOther "Unparsable ChainId" - | not $ assertChainId cid pcid -> Left Mempool.InsertErrorMetadataMismatch - | not $ assertSigSize sigs -> Left $ Mempool.InsertErrorOther "Too many signatures" - | not $ assertNetworkId v ver -> Left Mempool.InsertErrorMetadataMismatch - | otherwise -> Right tx - - -- | Validation: All checks that should occur before a TX is inserted into - -- the mempool. A rejection at this stage means that something is - -- fundamentally wrong/illegal with the TX, and that it should be rejected - -- completely and not gossiped to other peers. - -- - -- We expect this to be called in two places: once when a new Pact - -- Transaction is submitted via the @send@ endpoint, and once when a new TX - -- is gossiped to us from a peer's mempool. - -- - preInsertBatch - :: V.Vector (T2 Mempool.TransactionHash Pact4.UnparsedTransaction) - -> IO (V.Vector (Either (T2 Mempool.TransactionHash Mempool.InsertError) - (T2 Mempool.TransactionHash Pact4.UnparsedTransaction))) - preInsertBatch txs - | V.null txs = return V.empty - | otherwise = do - pex <- readMVar mv - rs <- _pactPreInsertCheck pex cid (V.map ssnd txs) - pure $ alignWithV f rs txs - where - f (These r (T2 h t)) = case r of - Just e -> Left (T2 h e) - Nothing -> Right (T2 h t) - f (That (T2 h _)) = Left (T2 h $ Mempool.InsertErrorOther "preInsertBatch: align mismatch 0") - f (This _) = Left (T2 (Mempool.TransactionHash "") (Mempool.InsertErrorOther "preInsertBatch: align mismatch 1")) - + %~ (\x -> L.nub $ x <> _versionBootstraps (c ^. configChainwebVersion)) $ c data StartedChainweb logger where - StartedChainweb :: (CanReadablePayloadCas cas, Logger logger) => !(Chainweb logger cas) -> StartedChainweb logger - Replayed :: !Cut -> !(Maybe Cut) -> StartedChainweb logger + StartedChainweb + :: (Logger logger) + => !(Chainweb logger) + -> StartedChainweb logger + RewoundToCut + :: !Cut + -> StartedChainweb logger data ChainwebStatus = ProcessStarted @@ -354,299 +257,259 @@ data ChainwebStatus -- withChainwebInternal :: forall logger - . Logger logger + . Logger logger + => HasVersion => ChainwebConfiguration -> logger -> PeerResources logger -> (Port, Socket) + -> Scheduler -> RocksDb -> FilePath -> FilePath - -> Bool -> (StartedChainweb logger -> IO ()) -> IO () -withChainwebInternal conf logger peer serviceSock rocksDb pactDbDir backupDir resetDb inner = do - - unless (_configOnlySyncPact conf || _configReadOnlyReplay conf) $ - initializePayloadDb v payloadDb - - -- Garbage Collection - -- performed before PayloadDb and BlockHeaderDb used by other components - logFunctionJson logger Info PruningDatabases - when (_cutPruneChainDatabase (_configCuts conf) /= GcNone) $ - logg Info "start pruning databases" - case _cutPruneChainDatabase (_configCuts conf) of - GcNone -> return () - GcHeaders -> - pruneAllChains (pruningLogger "headers") rocksDb v [] - GcHeadersChecked -> - pruneAllChains (pruningLogger "headers-checked") rocksDb v [CheckPayloads, CheckFull] - GcFull -> - fullGc (pruningLogger "full") rocksDb v - when (_cutPruneChainDatabase (_configCuts conf) /= GcNone) $ - logg Info "finished pruning databases" +withChainwebInternal conf logger peerRes serviceSock sched rocksDb defaultPactDbDir backupDir inner = do logFunctionJson logger Info InitializingChainResources - txFailuresCounter <- Counter.newCounter @"txFailures" let monitorTxFailuresCounter = - runForever (logFunctionText logger) "monitor txFailuresCounter" $ do - approximateThreadDelay 60_000_000 {- 1 minute -} + scheduleEvery sched "monitor txFailuresCounter" 60_000_000 {- 1 minute -} $ do Counter.logFunctionCounter logger Info . (:[]) =<< Counter.roll txFailuresCounter logg Debug "start initializing chain resources" - logFunctionText logger Info $ "opening pact db in directory " <> sshow pactDbDir - withAsync monitorTxFailuresCounter $ \_ -> - concurrentWith + logFunctionText logger Info $ "opening pact db in directory " <> sshow defaultPactDbDir + runResourceT $ do + liftIO monitorTxFailuresCounter + allChainResources <- allocateConcurrently + (tabulateChains $ \cid -> -- initialize chains concurrently - (\cid x -> do - let mcfg = validatingMempoolConfig cid v (_configBlockGasLimit conf) (_configMinGasPrice conf) - -- NOTE: the gas limit may be set based on block height in future, so this approach may not be valid. - let maxGasLimit = fromIntegral <$> maxBlockGasLimit v maxBound maxBound - case maxGasLimit of - Just maxGasLimit' - | _configBlockGasLimit conf > maxGasLimit' -> - logg Warn $ T.unwords - [ "configured block gas limit is greater than the" - , "maximum for this chain; the maximum will be used instead" - ] - _ -> return () + -- Initialize all chain resources, including payload providers withChainResources - v + sched + (chainLogger cid) cid rocksDb - (chainLogger cid) - mcfg - payloadDb - pactDbDir - (pactConfig maxGasLimit) - txFailuresCounter - x + (_peerResManager peerRes) + defaultPactDbDir + (_peerResConfig peerRes) + (_configServiceApi conf) + myInfo + peerDb + (_configReorgLimit conf) + initialUnlimitedRewind + (_configPayloadProviders conf) ) - - -- initialize global resources after all chain resources are initialized - (\cs -> do - logg Debug "finished initializing chain resources" - global (HM.fromList $ zip cidsList cs) - ) - cidsList + liftIO $ logg Debug "finished initializing chain resources" + liftIO $ global allChainResources where - pactConfig maxGasLimit = PactServiceConfig - { _pactReorgLimit = _configReorgLimit conf - , _pactPreInsertCheckTimeout = _configPreInsertCheckTimeout conf - , _pactQueueSize = _configPactQueueSize conf - , _pactResetDb = resetDb - , _pactAllowReadsInLocal = _configAllowReadsInLocal conf - , _pactUnlimitedInitialRewind = - isJust (_cutDbParamsInitialHeightLimit cutConfig) || - isJust (_cutDbParamsInitialCutFile cutConfig) - , _pactNewBlockGasLimit = maybe id min maxGasLimit (_configBlockGasLimit conf) - , _pactLogGas = _configLogGas conf - , _pactModuleCacheLimit = _configModuleCacheLimit conf - , _pactEnableLocalTimeout = _configEnableLocalTimeout conf - , _pactFullHistoryRequired = _configFullHistoricPactState conf - , _pactPersistIntraBlockWrites = - if _configFullHistoricPactState conf - then PersistIntraBlockWrites - else DoNotPersistIntraBlockWrites - , _pactTxTimeLimit = Nothing - } - - pruningLogger :: T.Text -> logger - pruningLogger l = addLabel ("sub-component", l) - $ setComponent "database-pruning" logger - - cidsList :: [ChainId] - cidsList = toList cids - - payloadDb :: PayloadDb RocksDbTable - payloadDb = newPayloadDb rocksDb - - chainLogger :: ChainId -> logger - chainLogger cid = addLabel ("chain", toText cid) logger + cids :: HS.HashSet ChainId + cids = chainIds - initLogger :: logger - initLogger = setComponent "init" logger + mgr :: HTTP.Manager + mgr = _peerResManager peerRes - logg :: LogFunctionText - logg = logFunctionText initLogger + peer :: Peer + peer = _peerResPeer peerRes - -- Initialize global resources - global - :: HM.HashMap ChainId (ChainResources logger) - -> IO () - global cs = do - let !webchain = mkWebBlockHeaderDb v (HM.map _chainResBlockHeaderDb cs) - !pact = mkWebPactExecutionService (HM.map _chainResPact cs) - !cutLogger = setComponent "cut" logger - !mgr = _peerResManager peer - - logg Debug "start initializing cut resources" - logFunctionJson logger Info InitializingCutResources - - withCutResources cutConfig peer cutLogger rocksDb webchain payloadDb mgr pact $ \cuts -> do - logg Debug "finished initializing cut resources" - - let !mLogger = setComponent "miner" logger - !mConf = _configMining conf - !mCutDb = _cutResCutDb cuts - !throt = _configThrottling conf - - -- initialize throttler - throttler <- mkGenericThrottler $ _throttlingRate throt - putPeerThrottler <- mkPutPeerThrottler $ _throttlingPeerRate throt - mempoolThrottler <- mkMempoolThrottler $ _throttlingMempoolRate throt - logg Debug "initialized throttlers" - - -- synchronize pact dbs with latest cut before we start the server - -- and clients and begin mining. - -- - -- This is a consistency check that validates the blocks in the - -- current cut. If it fails an exception is raised. Also, if it - -- takes long (for example, when doing a reset to a prior block - -- height) we want this to happen before we go online. - -- - let - pactSyncChains = - case _configSyncPactChains conf of - Just syncChains | _configOnlySyncPact conf || _configReadOnlyReplay conf -> HM.filterWithKey (\k _ -> elem k syncChains) cs - _ -> cs - - if _configReadOnlyReplay conf - then do - logFunctionJson logger Info PactReplayInProgress - -- note that we don't use the "initial cut" from cutdb because its height depends on initialBlockHeightLimit. - highestCut <- - unsafeMkCut v <$> readHighestCutHeaders mCutDb - lowerBoundCut <- - tryLimitCut webchain (fromMaybe 0 $ _cutInitialBlockHeightLimit $ _configCuts conf) highestCut - upperBoundCut <- forM (_cutFastForwardBlockHeightLimit $ _configCuts conf) $ \upperBound -> - tryLimitCut webchain upperBound highestCut - let - replayOneChain :: (ChainResources logger, (BlockHeader, Maybe BlockHeader)) -> IO () - replayOneChain (cr, (l, u)) = do - let chainPact = _chainResPact cr - let logCr = logFunctionText - $ addLabel ("component", "pact") - $ addLabel ("sub-component", "init") - $ _chainResLogger cr - void $ _pactReadOnlyReplay chainPact l u - logCr Info "pact db synchronized" - let bounds = - HM.intersectionWith (,) - pactSyncChains - (HM.mapWithKey - (\cid bh -> - (bh, (HM.! cid) . _cutMap <$> upperBoundCut)) - (_cutMap lowerBoundCut) - ) - mapConcurrently_ replayOneChain bounds - logg Info "finished fast forward replay" - logFunctionJson logger Info PactReplaySuccessful - inner $ Replayed lowerBoundCut upperBoundCut - else if _configOnlySyncPact conf - then do - initialCut <- _cut mCutDb - logg Info "start synchronizing Pact DBs to initial cut" - logFunctionJson logger Info InitialSyncInProgress - synchronizePactDb pactSyncChains initialCut - logg Info "finished synchronizing Pact DBs to initial cut" - logFunctionJson logger Info PactReplayInProgress - logg Info "start replaying Pact DBs to fast forward cut" - fastForwardCutDb mCutDb - newCut <- _cut mCutDb - synchronizePactDb pactSyncChains newCut - logg Info "finished replaying Pact DBs to fast forward cut" - logFunctionJson logger Info PactReplaySuccessful - inner $ Replayed initialCut (Just newCut) - else do - initialCut <- _cut mCutDb - logg Info "start synchronizing Pact DBs to initial cut" - logFunctionJson logger Info InitialSyncInProgress - synchronizePactDb pactSyncChains initialCut - logg Info "finished synchronizing Pact DBs to initial cut" - withPactData cs cuts $ \pactData -> do - logg Debug "start initializing miner resources" - logFunctionJson logger Info InitializingMinerResources - - withMiningCoordination mLogger mConf mCutDb $ \mc -> - - -- Miner resources are used by the test-miner when in-node - -- mining is configured or by the mempool noop-miner (which - -- keeps the mempool updated) in production setups. - -- - withMinerResources mLogger (_miningInNode mConf) cs mCutDb mc $ \m -> do - logFunctionJson logger Info ChainwebStarted - logg Debug "finished initializing miner resources" - let !haddr = _peerConfigAddr $ _p2pConfigPeer $ _configP2p conf - inner $ StartedChainweb Chainweb - { _chainwebHostAddress = haddr - , _chainwebChains = cs - , _chainwebCutResources = cuts - , _chainwebMiner = m - , _chainwebCoordinator = mc - , _chainwebLogger = logger - , _chainwebPeer = peer - , _chainwebPayloadDb = view cutDbPayloadDb $ _cutResCutDb cuts - , _chainwebManager = mgr - , _chainwebPactData = pactData - , _chainwebThrottler = throttler - , _chainwebPutPeerThrottler = putPeerThrottler - , _chainwebMempoolThrottler = mempoolThrottler - , _chainwebConfig = conf - , _chainwebServiceSocket = serviceSock - , _chainwebBackup = BackupEnv - { _backupRocksDb = rocksDb - , _backupDir = backupDir - , _backupPactDbDir = pactDbDir - , _backupChainIds = cids - , _backupLogger = backupLogger - } - } - - withPactData - :: HM.HashMap ChainId (ChainResources logger) - -> CutResources logger tbl - -> ([(ChainId, PactServerData logger tbl)] -> IO b) - -> IO b - withPactData cs cuts m = do - let l = sortBy (compare `on` fst) (HM.toList cs) - m $ l <&> fmap (\cr -> PactServerData - { _pactServerDataCutDb = _cutResCutDb cuts - , _pactServerDataMempool = _chainResMempool cr - , _pactServerDataLogger = _chainResLogger cr - , _pactServerDataPact = _chainResPact cr - }) - - v = _configChainwebVersion conf - cids = chainIds v - backupLogger = addLabel ("component", "backup") logger + myInfo :: PeerInfo + myInfo = _peerInfo peer + + peerDb :: PeerDb + peerDb = _peerResDb peerRes + + p2pConfig :: P2pConfiguration + p2pConfig = _peerResConfig peerRes -- FIXME: make this configurable - cutConfig :: CutDbParams - cutConfig = (defaultCutDbParams v $ _cutFetchTimeout cutConf) + cutDbParams :: CutDbParams + cutDbParams = (defaultCutDbParams $ _cutFetchTimeout cutConf) { _cutDbParamsLogLevel = Info , _cutDbParamsTelemetryLevel = Info , _cutDbParamsInitialHeightLimit = _cutInitialBlockHeightLimit cutConf - , _cutDbParamsFastForwardHeightLimit = _cutFastForwardBlockHeightLimit cutConf - , _cutDbParamsReadOnly = _configOnlySyncPact conf || _configReadOnlyReplay conf + , _cutDbParamsReadOnly = _configReadOnlyReplay conf + , _cutDbParamsInitialCutFile = _cutInitialCutFile cutConf } where cutConf = _configCuts conf - synchronizePactDb :: HM.HashMap ChainId (ChainResources logger) -> Cut -> IO () - synchronizePactDb cs targetCut = do - mapConcurrently_ syncOne $ - HM.intersectionWith (,) (_cutMap targetCut) cs - where - syncOne :: (BlockHeader, ChainResources logger) -> IO () - syncOne (bh, cr) = do - let pact = _chainResPact cr - let logCr = logFunctionText - $ addLabel ("component", "pact") - $ addLabel ("sub-component", "init") - $ _chainResLogger cr - void $ _pactSyncToBlock pact bh - logCr Debug "pact db synchronized" + initialUnlimitedRewind = + isJust (_cutDbParamsInitialHeightLimit cutDbParams) || + isJust (_cutDbParamsInitialCutFile cutDbParams) + + -- Logger + + backupLogger :: logger + backupLogger = addLabel ("component", "backup") logger + + chainLogger :: HasChainId c => c -> logger + chainLogger cid = addLabel ("chain", toText (_chainId cid)) logger + + initLogger :: logger + initLogger = setComponent "init" logger + + logg :: LogFunctionText + logg = logFunctionText initLogger + + -- Initialize global resources + -- TODO: Can this be moved to a top-level function or broken down a bit to + -- avoid excessive indentation? + + global + :: ChainMap (ChainResources logger) + -> IO () + global cs = runResourceT $ do + let !webchain = mkWebBlockHeaderDb rocksDb (fmap _chainResBlockHeaderDb cs) + -- !pact = mkWebPactExecutionService (HM.map _chainResPact cs) + !providers = payloadProvidersForAllChains cs + !cutLogger = setComponent "cut" logger + + liftIO $ logg Debug "start initializing cut resources" + liftIO $ logFunctionJson logger Info InitializingCutResources + + withCutResources cutLogger cutDbParams p2pConfig myInfo peerDb rocksDb webchain providers mgr >>= \case + Left initialCut -> liftIO $ do + logg Info "no cut resources, chainweb will not continue" + inner (RewoundToCut initialCut) + Right cutResources -> do + liftIO $ PruneForks.pruneForksJob + sched + logger + (cutResources ^. cutResCutDb . cut) + (cutResources ^. cutResCutDb . cutDbWebBlockHeaderDb) + (_configPruneCommand $ _configPrune conf) + (int PruneForks.safeDepth) + liftIO $ do + logg Debug "finished initializing cut resources" + + let !mLogger = setComponent "miner" logger + !mConf = _configMining conf + !mCutDb = _cutResCutDb cutResources + !throt = _configThrottling conf + + -- initialize throttler + throttler <- mkGenericThrottler $ _throttlingRate throt + putPeerThrottler <- mkPutPeerThrottler $ _throttlingPeerRate throt + mempoolThrottler <- mkMempoolThrottler $ _throttlingMempoolRate throt + logg Debug "initialized throttlers" + + -- synchronize pact dbs with latest cut before we start the server + -- and clients and begin mining. + -- + -- This is a consistency check that validates the blocks in the + -- current cut. If it fails an exception is raised. Also, if it + -- takes long (for example, when doing a reset to a prior block + -- height) we want this to happen before we go online. + -- + let + -- pactSyncChains = + -- case _configSyncPactChains conf of + -- Just syncChains + -- | _configReadOnlyReplay conf + -- -> HM.filterWithKey (\k _ -> elem k syncChains) cs + -- _ -> cs + + if _configReadOnlyReplay conf + then do + -- FIXME implement replay in payload provider + error "Chainweb.Chainweb.withChainwebInternal: pact replay is not supported" + -- logFunctionJson logger Info PactReplayInProgress + -- -- note that we don't use the "initial cut" from cutdb because its height depends on initialBlockHeightLimit. + -- highestCut <- + -- unsafeMkCut v <$> readHighestCutHeaders v (logFunctionText logger) webchain (cutHashesTable rocksDb) + -- lowerBoundCut <- + -- tryLimitCut webchain (fromMaybe 0 $ _cutInitialBlockHeightLimit $ _configCuts conf) highestCut + -- upperBoundCut <- forM (_cutFastForwardBlockHeightLimit $ _configCuts conf) $ \upperBound -> + -- tryLimitCut webchain upperBound highestCut + -- let + -- replayOneChain :: (ChainResources logger, (BlockHeader, Maybe BlockHeader)) -> IO () + -- replayOneChain (cr, (l, u)) = do + -- let chainPact = _chainResPact cr + -- let logCr = logFunctionText + -- $ addLabel ("component", "pact") + -- $ addLabel ("sub-component", "init") + -- $ _chainResLogger cr + -- void $ _pactReadOnlyReplay chainPact l u + -- logCr Info "pact db synchronized" + -- let bounds = + -- HM.intersectionWith (,) + -- pactSyncChains + -- (HM.mapWithKey + -- (\cid bh -> + -- (bh, (HM.! cid) . _cutMap <$> upperBoundCut)) + -- (_cutMap lowerBoundCut) + -- ) + -- mapConcurrently_ replayOneChain bounds + -- logg Info "finished fast forward replay" + -- logFunctionJson logger Info PactReplaySuccessful + -- inner $ Replayed lowerBoundCut upperBoundCut + else do + logg Debug "start initializing miner resources" + logFunctionJson logger Info InitializingMinerResources + + withMiningCoordination mLogger mConf mCutDb $ \mc -> + + -- Miner resources are used by the test-miner when in-node + -- mining is configured or by the mempool noop-miner (which + -- keeps the mempool updated) in production setups. + -- + withMinerResources mLogger (_miningInNode mConf) cs mCutDb mc $ \m -> do + logFunctionJson logger Info ChainwebStarted + logg Debug "finished initializing miner resources" + let !haddr = _peerConfigAddr $ _p2pConfigPeer $ _configP2p conf + inner $ StartedChainweb Chainweb + { _chainwebHostAddress = haddr + , _chainwebChains = cs + , _chainwebCutResources = cutResources + , _chainwebMiner = m + , _chainwebCoordinator = mc + , _chainwebLogger = logger + , _chainwebPeer = peerRes + , _chainwebManager = mgr + -- , _chainwebPactData = pactData + , _chainwebThrottler = throttler + , _chainwebPutPeerThrottler = putPeerThrottler + , _chainwebMempoolThrottler = mempoolThrottler + , _chainwebConfig = conf + , _chainwebServiceSocket = serviceSock + , _chainwebBackup = BackupEnv + { _backupRocksDb = rocksDb + , _backupDir = backupDir + , _backupPactDbDir = defaultPactDbDir + , _backupChainIds = cids + , _backupLogger = backupLogger + } + , _chainwebScheduler = sched + } + + -- synchronizePactDb :: HM.HashMap ChainId (ChainResources logger) -> Cut -> IO () + -- synchronizePactDb cs targetCut = do + -- mapConcurrently_ syncOne $ + -- HM.intersectionWith (,) (_cutMap targetCut) cs + -- where + -- syncOne :: (BlockHeader, ChainResources logger) -> IO () + -- syncOne (bh, cr) = do + -- let pact = _chainResPact cr + -- let logCr = logFunctionText + -- $ addLabel ("component", "pact") + -- $ addLabel ("sub-component", "init") + -- $ _chainResLogger cr + -- void $ _pactSyncToBlock pact bh + -- logCr Debug "pact db synchronized" + + -- withPactData + -- :: HM.HashMap ChainId (ChainResources logger) + -- -> CutResources + -- -> ([(ChainId, PactServerData logger tbl)] -> IO b) + -- -> IO b + -- withPactData cs cuts m = do + -- let l = sortBy (compare `on` fst) (HM.toList cs) + -- m $ l <&> fmap (\cr -> PactServerData + -- { _pactServerDataCutDb = _cutResCutDb cuts + -- , _pactServerDataMempool = _chainResMempool cr + -- , _pactServerDataLogger = _chainResLogger cr + -- , _pactServerDataPact = _chainResPact cr + -- , _pactServerDataPayloadDb = _chainResPayloadDb cr + -- }) -- -------------------------------------------------------------------------- -- -- Throttling @@ -699,33 +562,38 @@ makeLenses ''NowServing -- | Starts server and runs all network clients -- runChainweb - :: forall logger tbl + :: forall logger . Logger logger - => CanReadablePayloadCas tbl - => Chainweb logger tbl + => HasVersion + => Chainweb logger -> ((NowServing -> NowServing) -> IO ()) -> IO () runChainweb cw nowServing = do logg Debug "start chainweb node" + + -- Create OpenAPI Validation Middlewars mkValidationMiddleware <- interleaveIO $ - OpenAPIValidation.mkValidationMiddleware (_chainwebLogger cw) (_chainwebVersion cw) (_chainwebManager cw) + OpenAPIValidation.mkValidationMiddleware (_chainwebLogger cw) (_chainwebManager cw) p2pValidationMiddleware <- if _p2pConfigValidateSpec (_configP2p $ _chainwebConfig cw) then do - logg Warn $ "OpenAPI spec validation enabled on P2P API, make sure this is what you want" + logg Warn "OpenAPI spec validation enabled on P2P API, make sure this is what you want" mkValidationMiddleware else return id serviceApiValidationMiddleware <- if _serviceApiConfigValidateSpec (_configServiceApi $ _chainwebConfig cw) then do - logg Warn $ "OpenAPI spec validation enabled on service API, make sure this is what you want" + logg Warn "OpenAPI spec validation enabled on service API, make sure this is what you want" mkValidationMiddleware else return id + clientClosedConnectionsCounter <- Counter.newCounter + monitorConnectionsClosedByClient clientClosedConnectionsCounter + concurrentlies_ - -- 1. Start serving Rest API - [ (if tls then serve else servePlain) + -- 1. Start serving P2P Rest API + [ (\mw -> (if tls then serve else servePlain) clientClosedConnectionsCounter mw) $ httpLog . throttle (_chainwebPutPeerThrottler cw) . throttle (_chainwebMempoolThrottler cw) @@ -736,7 +604,7 @@ runChainweb cw nowServing = do -- 2. Start Clients (with a delay of 500ms) , threadDelay 500000 >> clients - -- 3. Start serving local API + -- 3. Start serving local service API , threadDelay 500000 >> do serveServiceApi $ serviceHttpLog @@ -750,11 +618,10 @@ runChainweb cw nowServing = do clients :: IO () clients = do - mpClients <- mempoolSyncClients concurrentlies_ $ concat [ miner - , cutNetworks mgr (_chainwebCutResources cw) - , mpClients + , cutNetworks (_chainwebCutResources cw) + , runP2pNodesOfAllChains (_chainwebChains cw) ] logg :: LogFunctionText @@ -762,31 +629,27 @@ runChainweb cw nowServing = do -- chains chains :: [(ChainId, ChainResources logger)] - chains = HM.toList (_chainwebChains cw) - - chainVals :: [ChainResources logger] - chainVals = map snd chains + chains = itoList (_chainwebChains cw) - -- collect server resources - proj :: forall a . (ChainResources logger -> a) -> [(ChainId, a)] - proj f = chains & mapped . _2 %~ f - - chainDbsToServe :: [(ChainId, BlockHeaderDb)] - chainDbsToServe = proj _chainResBlockHeaderDb - - mempoolsToServe :: [(ChainId, Mempool.MempoolBackend Pact4.UnparsedTransaction)] - mempoolsToServe = proj _chainResMempool - - peerDb = _peerResDb (_chainwebPeer cw) - - memP2pToServe :: [(NetworkId, PeerDb)] - memP2pToServe = (\(i, _) -> (MempoolNetwork i, peerDb)) <$> chains + -- FIXME export the SomeServer instead of DBs? + -- I.e. the handler would be created in the chain resource. + -- Similar to how it is done with the payload provider APIs. + -- + chainDbsToServe :: ChainMap BlockHeaderDb + chainDbsToServe = _chainResBlockHeaderDb <$> _chainwebChains cw - payloadDbsToServe :: [(ChainId, PayloadDb tbl)] - payloadDbsToServe = itoList (view chainwebPayloadDb cw <$ _chainwebChains cw) + mempoolsToServe :: ChainMap (Mempool.MempoolBackend Pact.Transaction) + -- mempoolsToServe = proj _chainResMempool + mempoolsToServe = mempty - pactDbsToServe :: [(ChainId, PactServerData logger tbl)] - pactDbsToServe = _chainwebPactData cw + -- As long as all Pact payload providers live within the consensus node, it + -- probably makes sense to serve the P2P network for mempools through the + -- consensus node API. + -- TODO: only include the mempools for enabled payload providers + -- + memP2pPeersToServe :: [(NetworkId, PeerDb)] + -- memP2pToServe = (\(i, _) -> (MempoolNetwork i, peerDb)) <$> chains + memP2pPeersToServe = [] loggServerError msg (Just r) e = "HTTP server error (" <> msg <> "): " <> sshow e <> ". Request: " <> sshow r @@ -816,49 +679,43 @@ runChainweb cw nowServing = do monitorConnectionsClosedByClient :: Counter.Counter "clientClosedConnections" -> IO () monitorConnectionsClosedByClient clientClosedConnectionsCounter = - runForever logg "ConnectionClosedByClient.counter" $ do - approximateThreadDelay 60_000_000 {- 1 minute -} + scheduleEvery (_chainwebScheduler cw) "ConnectionClosedByClient.counter" 60_000_000 {- 1 minute -} $ do Counter.logFunctionCounter (_chainwebLogger cw) Info . (:[]) =<< Counter.roll clientClosedConnectionsCounter - serve :: Middleware -> IO () - serve mw = do - clientClosedConnectionsCounter <- Counter.newCounter - concurrently_ - (serveChainwebSocketTls - (serverSettings clientClosedConnectionsCounter) - (_peerCertificateChain $ _peerResPeer $ _chainwebPeer cw) - (_peerKey $ _peerResPeer $ _chainwebPeer cw) - (_peerResSocket $ _chainwebPeer cw) - (_chainwebConfig cw) - ChainwebServerDbs - { _chainwebServerCutDb = Just cutDb - , _chainwebServerBlockHeaderDbs = chainDbsToServe - , _chainwebServerMempools = mempoolsToServe - , _chainwebServerPayloadDbs = payloadDbsToServe - , _chainwebServerPeerDbs = (CutNetwork, cutPeerDb) : memP2pToServe - } - mw) - (monitorConnectionsClosedByClient clientClosedConnectionsCounter) + chainwebServerDbs :: ChainwebServerDbs logger Pact.Transaction + chainwebServerDbs = ChainwebServerDbs + { _chainwebServerCutDb = Just cutDb + , _chainwebServerBlockHeaderDbs = chainDbsToServe + , _chainwebServerMempools = mempoolsToServe + -- , _chainwebServerPayloads = payloadsToServeOnP2pApi chains + , _chainwebServerPayloads = ChainMap $ HM.fromList $ payloadsToServeOnP2pApi chains + , _chainwebServerPeerDbs + = (CutNetwork, cutPeerDb) + : memP2pPeersToServe + <> payloadP2pPeersToServe chains + } + + serve :: Counter.Counter "clientClosedConnections" -> Middleware -> IO () + serve clientClosedConnectionsCounter mw = + serveChainwebSocketTls + (serverSettings clientClosedConnectionsCounter) + (_peerCertificateChain $ _peerResPeer $ _chainwebPeer cw) + (_peerKey $ _peerResPeer $ _chainwebPeer cw) + (_peerResSocket $ _chainwebPeer cw) + (_chainwebConfig cw) + chainwebServerDbs + mw -- serve without tls - servePlain :: Middleware -> IO () - servePlain mw = do - clientClosedConnectionsCounter <- Counter.newCounter - concurrently_ - (serveChainwebSocket - (serverSettings clientClosedConnectionsCounter) - (_peerResSocket $ _chainwebPeer cw) - (_chainwebConfig cw) - ChainwebServerDbs - { _chainwebServerCutDb = Just cutDb - , _chainwebServerBlockHeaderDbs = chainDbsToServe - , _chainwebServerMempools = mempoolsToServe - , _chainwebServerPayloadDbs = payloadDbsToServe - , _chainwebServerPeerDbs = (CutNetwork, cutPeerDb) : memP2pToServe - } - mw) - (monitorConnectionsClosedByClient clientClosedConnectionsCounter) + servePlain :: Counter.Counter "clientClosedConnections" -> Middleware -> IO () + servePlain clientClosedConnectionsCounter mw = + serveChainwebSocket + (serverSettings clientClosedConnectionsCounter) + (_peerResSocket $ _chainwebPeer cw) + (_chainwebConfig cw) + chainwebServerDbs + mw -- Request size limit for the service API -- @@ -907,17 +764,18 @@ runChainweb cw nowServing = do serveServiceApiSocket (serviceApiServerSettings clientClosedConnectionsCounter (fst $ _chainwebServiceSocket cw) serviceApiHost) (snd $ _chainwebServiceSocket cw) - (_chainwebVersion cw) ChainwebServerDbs { _chainwebServerCutDb = Just cutDb , _chainwebServerBlockHeaderDbs = chainDbsToServe , _chainwebServerMempools = mempoolsToServe - , _chainwebServerPayloadDbs = payloadDbsToServe - , _chainwebServerPeerDbs = (CutNetwork, cutPeerDb) : memP2pToServe + , _chainwebServerPayloads = ChainMap $ HM.fromList $ payloadsToServeOnServiceApi chains + + -- We do not want to serve peer APIs on the service API. + -- If at all we could serve the GET endpoints. + , _chainwebServerPeerDbs = [] } - pactDbsToServe (_chainwebCoordinator cw) - (HeaderStream . _configHeaderStream $ _chainwebConfig cw) + (HeaderStream . _serviceApiConfigHeaderStream . _configServiceApi $ _chainwebConfig cw) (_chainwebBackup cw <$ guard backupApiEnabled) (_serviceApiPayloadBatchLimit . _configServiceApi $ _chainwebConfig cw) mw @@ -929,40 +787,14 @@ runChainweb cw nowServing = do -- Cut DB and Miner - cutDb :: CutDb tbl + cutDb :: CutDb logger cutDb = _cutResCutDb $ _chainwebCutResources cw cutPeerDb :: PeerDb - cutPeerDb = _peerResDb $ _cutResPeer $ _chainwebCutResources cw + cutPeerDb = _cutResPeerDb $ _chainwebCutResources cw miner :: [IO ()] - miner = maybe [] (\m -> [ runMiner (_chainwebVersion cw) m ]) $ _chainwebMiner cw - - -- Configure Clients - - mgr :: HTTP.Manager - mgr = view chainwebManager cw - - -- Mempool - - mempoolP2pConfig :: EnableConfig MempoolP2pConfig - mempoolP2pConfig = _configMempoolP2p $ _chainwebConfig cw - - -- | Decide whether to enable the mempool sync clients. - -- - mempoolSyncClients :: IO [IO ()] - mempoolSyncClients = case enabledConfig mempoolP2pConfig of - Nothing -> disabled - Just c - | cw ^. chainwebVersion . versionDefaults . disableMempoolSync -> disabled - | otherwise -> enabled c - where - disabled = do - logg Info "Mempool p2p sync disabled" - return [] - enabled conf = do - logg Info "Mempool p2p sync enabled" - return $ map (runMempoolSyncClient mgr conf (_chainwebPeer cw)) chainVals + miner = maybe [] (\m -> [ runMiner m ]) $ _chainwebMiner cw serviceRequestSizeLimit :: Maybe Word64 serviceRequestSizeLimit = Just $ 2 * 1024 * 1024 -- 2 MB diff --git a/src/Chainweb/Chainweb/ChainResources.hs b/src/Chainweb/Chainweb/ChainResources.hs index 02573d1b1c..685bff285a 100644 --- a/src/Chainweb/Chainweb/ChainResources.hs +++ b/src/Chainweb/Chainweb/ChainResources.hs @@ -1,14 +1,24 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE ImportQualifiedPost #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeAbstractions #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE DataKinds #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE NumericUnderscores #-} +{-# LANGUAGE RecursiveDo #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} -- | -- Module: Chainweb.Chainweb.ChainResources @@ -20,99 +30,600 @@ -- Allocate chainweb resources for individual chains -- module Chainweb.Chainweb.ChainResources -( ChainResources(..) +( +-- * Chain Resources + ChainResources(..) , chainResBlockHeaderDb -, chainResMempool , chainResLogger -, chainResPact +, chainResPayloadProvider , withChainResources -) where +, payloadsToServeOnP2pApi +, payloadsToServeOnServiceApi +, payloadP2pPeersToServe +, payloadProvidersForAllChains +, runP2pNodesOfAllChains -import Control.Concurrent.MVar -import Control.Lens hiding ((.=), (<.>)) +-- * Payload Provider +, ProviderResources(..) +, withPayloadProviderResources +, providerResPayloadProvider +, providerResServiceApi +, providerResP2pApiResources -import Data.Maybe +-- * Payload Provider P2P Resources +, PayloadP2pResources(..) +, payloadP2pResources +, runPayloadP2pNodes +-- * Payload Provider Service API Resources +, PayloadServiceApiResources(..) +, payloadServiceApiResources +) where +import Control.Applicative ((<|>)) +import Control.Lens hiding ((.=), (<.>)) +import Control.Monad.IO.Class +import Control.Monad.Trans.Resource +import Data.Foldable +import Data.Maybe +import Data.PQueue (PQueue) +import Data.Singletons +import Data.Text qualified as T +import Network.HTTP.Client qualified as HTTP +import P2P.Node +import P2P.Node.Configuration +import P2P.Node.PeerDB (PeerDb) +import P2P.Peer (PeerInfo) +import P2P.Session +import P2P.TaskQueue import Prelude hiding (log) - - --- internal modules +import System.LogLevel import Chainweb.BlockHeaderDB +import Chainweb.BlockPayloadHash import Chainweb.ChainId +import Chainweb.Chainweb.Configuration + -- FIXME this module should not depend on the global configuration import Chainweb.Logger -import qualified Chainweb.Mempool.Consensus as MPCon -import qualified Chainweb.Mempool.InMem as Mempool -import qualified Chainweb.Mempool.InMemTypes as Mempool -import Chainweb.Mempool.Mempool (MempoolBackend) -import Chainweb.Pact.Service.PactInProcApi +import Chainweb.Pact.Mempool.InMem qualified as Mempool +import Chainweb.Pact.Mempool.InMem.ValidatingConfig qualified as Mempool +import Chainweb.Pact.PactService qualified as Pact +import Chainweb.Pact.RestAPI.Server qualified as Pact.RestAPI.Server import Chainweb.Pact.Types -import Chainweb.Payload.PayloadStore -import qualified Chainweb.Pact4.Transaction as Pact4 +import qualified Chainweb.Pact.Payload.PayloadStore as Pact.Payload.PayloadStore +import qualified Chainweb.Pact.Payload.PayloadStore.RocksDB as Pact.Payload.PayloadStore.RocksDB +import qualified Chainweb.Pact.Payload.RestAPI.Server as Pact.Payload.RestAPI.Server +import qualified Chainweb.Pact.Payload.RestAPI as Pact.Payload.RestAPI +import Chainweb.PayloadProvider +import Chainweb.PayloadProvider.EVM +import Chainweb.PayloadProvider.Minimal +import Chainweb.PayloadProvider.P2P +import Chainweb.PayloadProvider.P2P.RestAPI +import Chainweb.PayloadProvider.P2P.RestAPI.Server +import Chainweb.PayloadProvider.Pact +import Chainweb.PayloadProvider.Pact.Configuration +import Chainweb.PayloadProvider.Pact.Genesis qualified as Pact +import Chainweb.RestAPI.NetworkID +import Chainweb.RestAPI.Utils +import Chainweb.Scheduler (Scheduler) +import Chainweb.Storage.Table +import Chainweb.Storage.Table.RocksDB +import Chainweb.Time +import Chainweb.Utils import Chainweb.Version -import Chainweb.WebPactExecutionService +import Chainweb.Version.Guards (maxBlockGasLimit) +import Pact.Core.Gas qualified as Pact +import Control.Monad (forM) -import Chainweb.Storage.Table.RocksDB -import Chainweb.Counter +-- -------------------------------------------------------------------------- -- +-- Payload P2P Network Resources +-- +-- The following is the default implementation that works for the current +-- providers. It is not necessarily true that all payload providers use this. + +-- | Payload P2P network resources. +-- +-- This includes both client and server components. +-- +data PayloadP2pResources = PayloadP2pResources + { _payloadResPeerDb :: !PeerDb + -- ^ The respective Peer resources for the payload P2P network + , _payloadResP2pNode :: !P2pNode + -- ^ The P2P Network for fetching payloads + -- + -- The network doesn't restrict the API network endpoints that are used + -- in the client sessions. + , _payloadResP2pServer :: !SomeServer + -- ^ API endpoints that are are served by the node P2P API + } + +payloadP2pResources + :: forall (v :: ChainwebVersionT) (c :: ChainIdT) (p :: PayloadProviderType) logger tbl + . Logger logger + => HasVersion + => ReadableTable tbl RankedBlockPayloadHash (PayloadType p) + => KnownChainwebVersionSymbol v + => KnownChainIdSymbol c + => IsPayloadProvider p + => logger + -> P2pConfiguration + -> PeerInfo + -> PeerDb + -> tbl + -- Payload Table + -> PQueue (Task ClientEnv (PayloadType p)) + -- ^ task queue for scheduling tasks with the task server + -> HTTP.Manager + -> IO PayloadP2pResources +payloadP2pResources logger p2pConfig myInfo peerDb tbl queue mgr = do + p2pNode <- mkP2pNode False "payload" (session 10 queue) + -- FIXME add a node for regularly synchronizing peers + return $ PayloadP2pResources + { _payloadResPeerDb = peerDb + , _payloadResP2pNode = p2pNode + , _payloadResP2pServer = somePayloadServer @_ @v @c @p (PayloadBatchLimit 20) tbl + } + where + p2pLogger = addLabel ("sub-component", "p2p") logger + + mkP2pNode :: Bool -> T.Text -> P2pSession -> IO P2pNode + mkP2pNode doPeerSync label s = p2pCreateNode $ P2pNodeParameters + { _p2pNodeParamsMyPeerInfo = myInfo + , _p2pNodeParamsSession = s + , _p2pNodeParamsSessionTimeout = _p2pConfigSessionTimeout p2pConfig + , _p2pNodeParamsMaxSessionCount = _p2pConfigMaxSessionCount p2pConfig + , _p2pNodeParamsIsPrivate = _p2pConfigPrivate p2pConfig + , _p2pNodeParamsDoPeerSync = doPeerSync + , _p2pNodeParamsManager = mgr + , _p2pNodeParamsPeerDb = peerDb + , _p2pNodeParamsLogFunction = logFunction (addLabel ("session", label) p2pLogger) + , _p2pNodeParamsNetworkId = CutNetwork + } + +-- Pact is still using the old payload client/API. So, for now, we need to serve both. +pactPayloadP2pResources + :: forall (v :: ChainwebVersionT) (c :: ChainIdT) logger tbl + . Logger logger + => HasVersion + => Pact.Payload.PayloadStore.CanReadablePayloadCas tbl + => KnownChainwebVersionSymbol v + => KnownChainIdSymbol c + => logger + -> P2pConfiguration + -> PeerInfo + -> PeerDb + -> Pact.Payload.PayloadStore.PayloadDb tbl + -- Payload Table + -> PQueue (Task ClientEnv (PayloadType 'PactProvider)) + -- ^ task queue for scheduling tasks with the task server + -> HTTP.Manager + -> IO PayloadP2pResources +pactPayloadP2pResources logger p2pConfig myInfo peerDb tbl queue mgr = do + p2pNode <- mkP2pNode False "payload" (session 10 queue) + -- FIXME add a node for regularly synchronizing peers + return $ PayloadP2pResources + { _payloadResPeerDb = peerDb + , _payloadResP2pNode = p2pNode + , _payloadResP2pServer = + somePayloadServer @_ @v @c @'PactProvider (PayloadBatchLimit 20) tbl + <> Pact.Payload.RestAPI.Server.somePayloadServer + (Pact.Payload.RestAPI.PayloadBatchLimit 20) + (Pact.Payload.RestAPI.SomePayloadDb (Pact.Payload.RestAPI.PayloadDb' @_ @v @c tbl)) + } + where + p2pLogger = addLabel ("sub-component", "p2p") logger + + mkP2pNode :: Bool -> T.Text -> P2pSession -> IO P2pNode + mkP2pNode doPeerSync label s = p2pCreateNode $ P2pNodeParameters + { _p2pNodeParamsMyPeerInfo = myInfo + , _p2pNodeParamsSession = s + , _p2pNodeParamsSessionTimeout = _p2pConfigSessionTimeout p2pConfig + , _p2pNodeParamsMaxSessionCount = _p2pConfigMaxSessionCount p2pConfig + , _p2pNodeParamsIsPrivate = _p2pConfigPrivate p2pConfig + , _p2pNodeParamsDoPeerSync = doPeerSync + , _p2pNodeParamsManager = mgr + , _p2pNodeParamsPeerDb = peerDb + , _p2pNodeParamsLogFunction = logFunction (addLabel ("session", label) p2pLogger) + , _p2pNodeParamsNetworkId = CutNetwork + } + + +-- | IO actions for running Payload P2p Nodes +-- +runPayloadP2pNodes :: HasVersion => PayloadP2pResources -> [IO ()] +runPayloadP2pNodes r = [ p2pRunNode (_payloadResP2pNode r) ] + +-- -------------------------------------------------------------------------- -- +-- Payload Service API Resources + +newtype PayloadServiceApiResources = PayloadServiceApiResources + { _payloadResServiceServer :: SomeServer + } + deriving newtype (Semigroup, Monoid) + +payloadServiceApiResources + :: forall (v :: ChainwebVersionT) (c :: ChainIdT) (p :: PayloadProviderType) tbl + . IsPayloadProvider p + => KnownChainwebVersionSymbol v + => KnownChainIdSymbol c + => ReadableTable tbl RankedBlockPayloadHash (PayloadType p) + => ServiceApiConfig + -> tbl + -> PayloadServiceApiResources +payloadServiceApiResources config pdb = PayloadServiceApiResources + { _payloadResServiceServer = somePayloadServer @_ @v @c @p batchLimit pdb + } + where + batchLimit = int $ _serviceApiPayloadBatchLimit config + +-- we keep around the old payload server too for Pact to avoid breaking consumers. +pactPayloadServiceApiResources + :: forall (v :: ChainwebVersionT) (c :: ChainIdT) tbl + . HasVersion + => KnownChainwebVersionSymbol v + => KnownChainIdSymbol c + => Pact.Payload.PayloadStore.CanReadablePayloadCas tbl + => ServiceApiConfig + -> Pact.Payload.PayloadStore.PayloadDb tbl + -> PayloadServiceApiResources +pactPayloadServiceApiResources config pdb = PayloadServiceApiResources + { _payloadResServiceServer = + Pact.Payload.RestAPI.Server.somePayloadServer @_ batchLimit + (Pact.Payload.RestAPI.SomePayloadDb (Pact.Payload.RestAPI.PayloadDb' @_ @v @c pdb)) + <> somePayloadServer @_ @v @c @'PactProvider (int batchLimit) pdb + } + where + batchLimit = int $ _serviceApiPayloadBatchLimit config + +-- -------------------------------------------------------------------------- -- +-- Payload Provider Resources + +-- | Payload Provider Resources +-- +data ProviderResources = ProviderResources + { _providerResPayloadProvider :: !ConfiguredPayloadProvider + , _providerResServiceApi :: !(Maybe PayloadServiceApiResources) + , _providerResP2pApiResources :: !(Maybe PayloadP2pResources) + } + +makeLenses ''ProviderResources + +withPayloadProviderResources + :: Logger logger + => HasVersion + => Scheduler + -> logger + -> ChainId + -> ServiceApiConfig + -> Maybe (P2pConfiguration, PeerInfo, PeerDb, HTTP.Manager) + -> RocksDb + -> RewindLimit + -- ^ the reorg limit for the payload providers + -> Bool + -- ^ whether to allow unlimited rewind on startup + -> FilePath + -- ^ default database directory for pact databases. As long as Pact + -- payload providers live within chainweb-consensus they inherit the + -- default db location from the chainweb configuration. + -> PayloadProviderConfig + -> ResourceT IO ProviderResources +withPayloadProviderResources sched logger cid serviceApiConfig peerStuff rdb rewindLimit initialUnlimitedRewind defaultPactDbDir configs = do + SomeChainwebVersionT @v' _ <- return $ someChainwebVersionVal + SomeChainIdT @c' _ <- return $ someChainIdVal cid + withSomeSing provider $ \case + SMinimalProvider -> do + + -- FIXME this should be better abstracted. + -- Should we put the api and server into the payload provider + -- itself? Would it be an issue if the payload provider would keep a + -- reference to it? + -- + -- It would allow the server to be integrated more closely with the + -- provider. + + let config = _payloadProviderConfigMinimal configs + p <- liftIO $ newMinimalPayloadProvider logger cid rdb (view _4 <$> peerStuff) config + let pdb = view minimalPayloadDb p + let queue = view minimalPayloadQueue p + p2pRes <- liftIO $ forM peerStuff $ \(p2pConfig, myPeerInfo, peerDb, mgr) -> + payloadP2pResources @v' @c' @'MinimalProvider + logger p2pConfig myPeerInfo peerDb pdb queue mgr + let serviceRes = + payloadServiceApiResources @v' @c' @'MinimalProvider serviceApiConfig pdb + return ProviderResources + { _providerResPayloadProvider = ConfiguredPayloadProvider p + , _providerResServiceApi = Just serviceRes + , _providerResP2pApiResources = p2pRes + } + + SPactProvider -> case _payloadProviderConfigPact configs ^. at cid of + Just conf -> do + -- , _pactGenesisPayload = Pact.genesisPayload v ^?! atChain chain + + -- let mcfg = validatingMempoolConfig cid v (_configBlockGasLimit conf) (_configMinGasPrice conf) + + -- FIXME move the following to the pact provider initialization + + let maxGasLimit = Pact.GasLimit . Pact.Gas . fromIntegral + <$> maxBlockGasLimit maxBound maxBound + case maxGasLimit of + Just maxGasLimit' + | _pactConfigBlockGasLimit conf > maxGasLimit' -> + liftIO $ logFunction logger Warn $ T.unwords + [ "configured block gas limit is greater than the" + , "maximum for this chain; the maximum will be used instead" + ] + _ -> return () + + let pactConfig = PactServiceConfig + { _pactReorgLimit = rewindLimit + , _pactPreInsertCheckTimeout = _pactConfigPreInsertCheckTimeout conf + , _pactAllowReadsInLocal = _pactConfigAllowReadsInLocal conf + , _pactUnlimitedInitialRewind = initialUnlimitedRewind + , _pactNewBlockGasLimit = maybe id min maxGasLimit (_pactConfigBlockGasLimit conf) + , _pactLogGas = _pactConfigLogGas conf + , _pactEnableLocalTimeout = _pactConfigEnableLocalTimeout conf + , _pactFullHistoryRequired = _pactConfigFullHistoricPactState conf + , _pactTxTimeLimit = Nothing + , _pactMiner = _pactConfigMiner conf + , _pactBlockRefreshInterval = Micros 5_000_000 + } + + let pdb = Pact.Payload.PayloadStore.RocksDB.newPayloadDb rdb + let pactDbDir = case _pactConfigDatabaseDirectory conf of + Just x -> x + Nothing -> defaultPactDbDir + rec + pp <- + withPactPayloadProvider + cid + rdb + (view _4 <$> peerStuff) + logger + Nothing + mpa + pdb + pactDbDir + pactConfig + (Pact.genesisPayload cid <|> _pactConfigGenesisPayload conf) + let mempoolConfig = + Mempool.validatingMempoolConfig + cid + (_pactNewBlockGasLimit pactConfig) + (_pactConfigMinGasPrice conf) + (\txs -> + Pact.execPreInsertCheckReq + (pactPayloadProviderLogger pp) + (pactPayloadProviderServiceEnv pp) txs + ) + mempool <- Mempool.withInMemoryMempool sched (setComponent "mempool" logger) mempoolConfig + let mpa = pactMemPoolAccess mempool $ addLabel ("sub-component", "MempoolAccess") logger + let queue = _payloadStoreQueue $ _psPdb $ pactPayloadProviderServiceEnv pp + p2pRes <- liftIO $ forM peerStuff $ \(p2pConfig, myPeerInfo, peerDb, mgr) -> + pactPayloadP2pResources @v' @c' logger p2pConfig myPeerInfo peerDb pdb queue mgr + let serviceApiPayloadServer = + pactPayloadServiceApiResources @v' @c' serviceApiConfig pdb + let pactServerData = Pact.RestAPI.Server.PactServerData + { Pact.RestAPI.Server._pactServerDataLogger = + pactPayloadProviderLogger pp + , Pact.RestAPI.Server._pactServerDataMempool = + mempool + , Pact.RestAPI.Server._pactServerDataPact = + pactPayloadProviderServiceEnv pp + } + -- this is a bit of a misnomer, as it's not a payload API. + let pactServer = PayloadServiceApiResources $ + Pact.RestAPI.Server.somePactServer (Pact.RestAPI.Server.somePactServerData cid pactServerData) + return ProviderResources + { _providerResPayloadProvider = ConfiguredPayloadProvider pp + , _providerResServiceApi = Just $ pactServer <> serviceApiPayloadServer + , _providerResP2pApiResources = p2pRes + } + + _ -> return $ ProviderResources DisabledPayloadProvider Nothing Nothing + + SEvmProvider @n _ -> case _payloadProviderConfigEvm configs ^. at cid of + Just config -> do + -- This assumes that the respective execution client is available + -- and answering API requests. + -- It also starts to awaiting and devlivering new payloads if mining + -- is enabled. + p <- withEvmPayloadProvider logger cid rdb (view _4 <$> peerStuff) config + let pdb = view evmPayloadDb p + let queue = view evmPayloadQueue p + apiRes <- liftIO $ forM peerStuff $ \(p2pConfig, myPeerInfo, peerDb, mgr) -> do + p2pRes <- + payloadP2pResources @v' @c' @('EvmProvider n) + logger p2pConfig myPeerInfo peerDb pdb queue mgr + let + serviceRes = + payloadServiceApiResources @v' @c' @('EvmProvider n) serviceApiConfig pdb + return (p2pRes, serviceRes) + + return ProviderResources + { _providerResPayloadProvider = ConfiguredPayloadProvider p + , _providerResServiceApi = snd <$> apiRes + , _providerResP2pApiResources = fst <$> apiRes + } + _ -> return $ ProviderResources DisabledPayloadProvider Nothing Nothing + + where + provider :: PayloadProviderType + provider = payloadProviderTypeForChain cid -- -------------------------------------------------------------------------- -- -- Single Chain Resources +-- | FIXME: What do we need to include here to support Rest API? +-- data ChainResources logger = ChainResources { _chainResBlockHeaderDb :: !BlockHeaderDb , _chainResLogger :: !logger - , _chainResMempool :: !(MempoolBackend Pact4.UnparsedTransaction) - , _chainResPact :: PactExecutionService + , _chainResPayloadProvider :: !ProviderResources } makeLenses ''ChainResources -instance HasChainwebVersion (ChainResources logger) where - _chainwebVersion = _chainwebVersion . _chainResBlockHeaderDb - {-# INLINE _chainwebVersion #-} +_chainResP2pApiResources + :: ChainResources logger + -> Maybe PayloadP2pResources +_chainResP2pApiResources = _providerResP2pApiResources . _chainResPayloadProvider + +_chainResServiceApiResources + :: ChainResources logger + -> Maybe PayloadServiceApiResources +_chainResServiceApiResources = _providerResServiceApi . _chainResPayloadProvider instance HasChainId (ChainResources logger) where _chainId = _chainId . _chainResBlockHeaderDb {-# INLINE _chainId #-} --- | Intializes all local Chain resources, but doesn't start any networking. --- withChainResources :: Logger logger - => CanReadablePayloadCas tbl - => ChainwebVersion + => HasVersion + => Scheduler + -> logger -> ChainId -> RocksDb - -> logger - -> (MVar PactExecutionService -> Mempool.InMemConfig Pact4.UnparsedTransaction) - -> PayloadDb tbl + -> HTTP.Manager -> FilePath - -- ^ database directory for checkpointer - -> PactServiceConfig - -> Counter "txFailures" - -> (ChainResources logger -> IO a) - -> IO a -withChainResources - v cid rdb logger mempoolCfg0 payloadDb pactDbDir pactConfig txFailuresCounter inner = - withBlockHeaderDb rdb v cid $ \cdb -> do - pexMv <- newEmptyMVar - let mempoolCfg = mempoolCfg0 pexMv - Mempool.withInMemoryMempool (setComponent "mempool" logger) mempoolCfg v $ \mempool -> do - mpc <- MPCon.mkMempoolConsensus mempool cdb $ Just payloadDb - withPactService v cid logger (Just txFailuresCounter) mpc cdb - payloadDb pactDbDir pactConfig $ \requestQ -> do - let pex = pes requestQ - putMVar pexMv pex - - -- run inner - inner $ ChainResources - { _chainResBlockHeaderDb = cdb - , _chainResLogger = logger - , _chainResMempool = mempool - , _chainResPact = pex - } + -- ^ default database directory for pact databases. As long as Pact + -- payload providers live within chainweb-consensus they inherit the + -- default db location from the chainweb configuration. + -> P2pConfiguration + -> ServiceApiConfig + -> PeerInfo + -> PeerDb + -> RewindLimit + -- ^ the reorg limit for the payload providers + -> Bool + -- ^ whether to allow unlimited rewind on startup + -> PayloadProviderConfig + -> ResourceT IO (ChainResources logger) +withChainResources sched logger cid rdb mgr defaultPactDbDir p2pConf serviceConf myInfo peerDb rewindLimit initialUnlimitedRewind configs = do + + -- This uses the the CutNetwork for fetching block headers. + cdb <- withBlockHeaderDb rdb cid + + -- Payload Providers are using per chain payload networks for fetching + -- block headers. + provider <- withPayloadProviderResources + sched providerLogger cid serviceConf (Just (p2pConf, myInfo, peerDb, mgr)) + rdb rewindLimit initialUnlimitedRewind defaultPactDbDir configs + + return ChainResources + { _chainResBlockHeaderDb = cdb + , _chainResPayloadProvider = provider + , _chainResLogger = logger + } where - pes requestQ - | v ^. versionCheats . disablePact = emptyPactExecutionService - | otherwise = mkPactExecutionService requestQ + providerType = payloadProviderTypeForChain cid + providerLogger = logger + & setComponent "payload-provider" + & addLabel ("provider", toText providerType) + +-- | Return P2P Payload Servers for all enabled payload providers +-- +payloadsToServeOnP2pApi + :: [(ChainId, ChainResources logger)] + -> [(ChainId, SomeServer)] +payloadsToServeOnP2pApi chains = catMaybes + $ mapM (fmap _payloadResP2pServer . _chainResP2pApiResources) + <$> chains + +-- | Return Service API Payload Servers for all enabled payload providers +-- +payloadsToServeOnServiceApi + :: [(ChainId, ChainResources logger)] + -> [(ChainId, SomeServer)] +payloadsToServeOnServiceApi chains = catMaybes + $ mapM (fmap _payloadResServiceServer . _chainResServiceApiResources) + <$> chains + +payloadP2pPeersToServe + :: [(ChainId, ChainResources logger)] + -> [(NetworkId, PeerDb)] +payloadP2pPeersToServe chains = + catMaybes + $ fmap sequence + $ (\(cid, x) -> (ChainNetwork cid, _payloadResPeerDb <$> _chainResP2pApiResources x)) + <$> chains + +-- | Return the configured payload providers for all chains +-- +payloadProvidersForAllChains + :: ChainMap (ChainResources logger) + -> ChainMap ConfiguredPayloadProvider +payloadProvidersForAllChains chains = + (_providerResPayloadProvider . _chainResPayloadProvider) + <$> chains + +-- | Returns actions for running the P2P nodes for all chains. +-- +runP2pNodesOfAllChains + :: Foldable l + => HasVersion + => l (ChainResources logger) + -> [IO ()] +runP2pNodesOfAllChains + = fmap p2pRunNode + . fmap _payloadResP2pNode + . catMaybes + . fmap _providerResP2pApiResources + . fmap _chainResPayloadProvider + . toList + +-- -------------------------------------------------------------------------- -- +-- ATTIC (mostly pact related) +-- +-- FIXME: use the following to create withPact initialization function for +-- pact chains + +-- data PactResources logger = PactResources +-- { _pactResBlockHeaderDb :: !BlockHeaderDb +-- , _pactResLogger :: !logger +-- , _pactResMempool :: !(MempoolBackend Pact4.UnparsedTransaction) +-- , _pactResPact :: PactExecutionService +-- , _pactResPayloadDb :: _ +-- } + +-- | Intializes all local Chain resources, but doesn't start any networking. +-- +-- withChainResources +-- :: Logger logger +-- => CanReadablePayloadCas tbl +-- => ChainwebVersion +-- -> ChainId +-- -> RocksDb +-- -> logger +-- -> (MVar PactExecutionService -> Mempool.InMemConfig Pact4.UnparsedTransaction) +-- -> PayloadDb tbl +-- -> FilePath +-- -- ^ database directory for checkpointer +-- -> PactServiceConfig +-- -> Counter "txFailures" +-- -> (ChainResources logger -> IO a) +-- -> IO a +-- withChainResources +-- v cid rdb logger mempoolCfg0 payloadDb pactDbDir pactConfig txFailuresCounter inner = +-- withBlockHeaderDb rdb v cid $ \cdb -> do +-- pexMv <- newEmptyMVar +-- let mempoolCfg = mempoolCfg0 pexMv +-- Mempool.withInMemoryMempool (setComponent "mempool" logger) mempoolCfg v $ \mempool -> do +-- mpc <- MPCon.mkMempoolConsensus mempool cdb $ Just payloadDb +-- withPactService v cid logger (Just txFailuresCounter) mpc cdb +-- payloadDb pactDbDir pactConfig $ \requestQ -> do +-- let pex = pes requestQ +-- putMVar pexMv pex +-- +-- -- run inner +-- inner $ ChainResources +-- { _chainResBlockHeaderDb = cdb +-- , _chainResLogger = logger +-- , _chainResMempool = mempool +-- , _chainResPact = pex +-- } +-- where +-- pes requestQ +-- | v ^. versionCheats . disablePact = emptyPactExecutionService +-- | otherwise = mkPactExecutionService requestQ diff --git a/src/Chainweb/Chainweb/CheckReachability.hs b/src/Chainweb/Chainweb/CheckReachability.hs index 1480ef00f5..42b223943d 100644 --- a/src/Chainweb/Chainweb/CheckReachability.hs +++ b/src/Chainweb/Chainweb/CheckReachability.hs @@ -51,6 +51,7 @@ import Chainweb.Utils import Chainweb.Version import P2P.Node.PeerDB +import P2P.Node.RestAPI.Client import P2P.Peer -- -------------------------------------------------------------------------- -- @@ -79,16 +80,16 @@ instance Exception ReachabilityException -- checkReachability :: Logger logger + => HasVersion => Socket -> HTTP.Manager - -> ChainwebVersion -> logger -> PeerDb -> [PeerInfo] -> Peer -> Double -> IO () -checkReachability sock mgr v logger pdb peers peer threshold = do +checkReachability sock mgr logger pdb peers peer threshold = do nis <- if null peers then return [] else withPeerDbServer $ do @@ -122,17 +123,20 @@ checkReachability sock mgr v logger pdb peers peer threshold = do logg = logFunctionText logger run p = runClientM - (peerPutClient v CutNetwork pinf) + (peerPutClient CutNetwork pinf) (peerInfoClientEnv mgr p) withPeerDbServer inner = withAsync servePeerDb $ const inner + -- Is the really what we want? I think, the other side is trying to connect + -- to the cut endpoint. It probably does not matter, because only the + -- response headers are checked. + -- servePeerDb = servePeerDbSocketTls serverSettings (_peerCertificateChain peer) (_peerKey peer) sock - v CutNetwork pdb id -- TODO add middleware for request logging? diff --git a/src/Chainweb/Chainweb/Configuration.hs b/src/Chainweb/Chainweb/Configuration.hs index fcbca2c303..65ff322e44 100644 --- a/src/Chainweb/Chainweb/Configuration.hs +++ b/src/Chainweb/Chainweb/Configuration.hs @@ -2,6 +2,7 @@ {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE ImportQualifiedPost #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NumericUnderscores #-} {-# LANGUAGE OverloadedStrings #-} @@ -20,23 +21,25 @@ -- module Chainweb.Chainweb.Configuration ( +-- * Payload Provider Config + PayloadProviderConfig(..) +, payloadProviderConfigMinimal +, payloadProviderConfigPact +, payloadProviderConfigEvm +, defaultPayloadProviderConfig +, validatePayloadProviderConfig + -- * Throttling Configuration - ThrottlingConfig(..) +, ThrottlingConfig(..) , throttlingRate , throttlingPeerRate , throttlingMempoolRate , defaultThrottlingConfig -- * Cut Configuration -, ChainDatabaseGcConfig(..) -, chainDatabaseGcToText -, chainDatabaseGcFromText - , CutConfig(..) -, cutPruneChainDatabase , cutFetchTimeout , cutInitialBlockHeightLimit -, cutFastForwardBlockHeightLimit , defaultCutConfig , pCutConfig @@ -44,6 +47,7 @@ module Chainweb.Chainweb.Configuration , ServiceApiConfig(..) , serviceApiConfigPort , serviceApiConfigInterface +, serviceApiConfigHeaderStream , defaultServiceApiConfig , pServiceApiConfig @@ -53,77 +57,252 @@ module Chainweb.Chainweb.Configuration , BackupConfig(..) , defaultBackupConfig +-- * Pruning configuration +, PruneConfig(..) +, defaultPruneConfig + -- * Chainweb Configuration , ChainwebConfiguration(..) , configChainwebVersion , configCuts , configMining -, configHeaderStream -, configReintroTxs , configP2p -, configBlockGasLimit -, configMinGasPrice , configThrottling , configReorgLimit -, configFullHistoricPactState , configBackup , configServiceApi -, configOnlySyncPact -, configSyncPactChains -, configEnableLocalTimeout +, configReadOnlyReplay +, configSyncChains +, configPayloadProviders +, configBackgroundJobsPoolSize , defaultChainwebConfiguration , pChainwebConfiguration , validateChainwebConfiguration ) where +import Chainweb.BlockHeaderDB.PruneForks qualified as PruneForks +import Chainweb.BlockHeight +import Chainweb.Difficulty +import Chainweb.HostAddress +import Chainweb.Miner.Config +import Chainweb.Pact.Types (RewindLimit) +import Chainweb.Pact.Types (defaultReorgLimit) +import Chainweb.Pact.Payload.RestAPI (PayloadBatchLimit(..), defaultServicePayloadBatchLimit) +import Chainweb.PayloadProvider.EVM (EvmProviderConfig, pEvmProviderConfig, defaultEvmProviderConfig, validateEvmProviderConfig) +import Chainweb.PayloadProvider.Minimal (MinimalProviderConfig, defaultMinimalProviderConfig, pMinimalProviderConfig) +import Chainweb.PayloadProvider.Pact.Configuration +import Chainweb.Utils +import Chainweb.Version +import Chainweb.Version.Development +import Chainweb.Version.EvmDevelopment +import Chainweb.Version.EvmDevelopmentSingleton +import Chainweb.Version.Mainnet +import Chainweb.Version.RecapDevelopment +import Chainweb.Version.Registry (findKnownVersion, knownVersions) import Configuration.Utils hiding (Error, Lens', disabled) - import Control.Lens hiding ((.=), (<.>)) import Control.Monad -import Control.Monad.Catch (MonadThrow, throwM) import Control.Monad.Except import Control.Monad.Writer - +import Data.Aeson.Key qualified as K +import Data.Aeson.KeyMap qualified as KM import Data.Foldable -import qualified Data.HashMap.Strict as HM -import qualified Data.HashSet as HS +import Data.HashMap.Strict qualified as HM +import Data.HashSet qualified as HS +import Data.List qualified as L import Data.Maybe -import qualified Data.Text as T +import Data.Text qualified as T +import Data.Text.Read qualified as T +import GHC.Generics hiding (from, to) +import GHC.Natural (Natural) +import Network.Wai.Handler.Warp hiding (Port) +import P2P.Node.Configuration +import Prelude hiding (log) +import System.Directory -import GHC.Generics hiding (from) +-- -------------------------------------------------------------------------- -- +-- Payload Provider Configuration -import Network.Wai.Handler.Warp hiding (Port) +-- | Payload Provider Configurations +-- +-- There is only a single Default Minimal Payload Provider Configuration. +-- Minimal payload provider cannot be disabled. +-- +-- The default configuration for the pact and evm payload providers is to be +-- disabled. +-- +-- When a payload provider is enabled for a chain it must match the payload +-- provider type for the respective chain. +-- +data PayloadProviderConfig = PayloadProviderConfig + { _payloadProviderConfigMinimal :: !MinimalProviderConfig + , _payloadProviderConfigPact :: !(ChainMap PactProviderConfig) + , _payloadProviderConfigEvm :: !(ChainMap EvmProviderConfig) + } + deriving (Show, Eq, Generic) -import Numeric.Natural (Natural) +makeLenses ''PayloadProviderConfig -import qualified Pact.JSON.Encode as J +-- | By default only the minimal payload provider is enabled. For the pact and +-- evm chains the payload providers are disabled by default. +-- +defaultPayloadProviderConfig :: PayloadProviderConfig +defaultPayloadProviderConfig = PayloadProviderConfig + { _payloadProviderConfigMinimal = defaultMinimalProviderConfig + , _payloadProviderConfigPact = mempty + , _payloadProviderConfigEvm = mempty + } -import Prelude hiding (log) +validatePayloadProviderConfig :: HasVersion => ConfigValidation PayloadProviderConfig [] +validatePayloadProviderConfig conf = do + void $ itraverse checkPactProvider $ _payloadProviderConfigPact conf + void $ itraverse checkEvmProvider $ _payloadProviderConfigEvm conf + where + checkPactProvider cid _conf = case payloadProviderTypeForChain cid of + PactProvider -> return () -- FIXME implement validation + e -> do + tell [ "Pact provider configured for chain " <> sshow cid <> ": " <> sshow conf ] + throwError $ mconcat $ + [ "Wrong payload provider type configuration for chain " <> sshow cid + , ". Expected " <> sshow e <> " but found Pact" + ] + + checkEvmProvider cid _conf = case payloadProviderTypeForChain cid of + EvmProvider _ -> validateEvmProviderConfig cid _conf + e -> do + tell [ "EVM provider configured for chain " <> sshow cid <> ": " <> sshow conf ] + throwError $ mconcat $ + [ "Wrong payload provider type configuration for chain " <> sshow cid + , ". Expected " <> sshow e <> " but found EVM" + ] + + +instance ToJSON PayloadProviderConfig where + toJSON o = object + $ ("default" .= _payloadProviderConfigMinimal o) + : others + where + pacts = + [ key c .= tag "pact" v + | (c, v) <- itoList (_payloadProviderConfigPact o) + ] + evms = + [ key c .= tag "evm" v + | (c, v) <- itoList (_payloadProviderConfigEvm o) + ] + others = L.sort $ pacts <> evms -import System.Directory + tag :: ToJSON v => T.Text -> v -> Value + tag t v = case toJSON v of + Object l -> Object $ KM.insert "type" (toJSON t) l + x -> x --- internal modules + key :: ChainId -> Key + key cid = K.fromText $ "chain-" <> toText cid -import Chainweb.BlockHeight -import Chainweb.Difficulty -import Chainweb.HostAddress -import qualified Chainweb.Mempool.Mempool as Mempool -import Chainweb.Mempool.P2pConfig -import Chainweb.Miner.Config -import Chainweb.Pact.Types (defaultReorgLimit, defaultModuleCacheLimit, defaultPreInsertCheckTimeout) -import Chainweb.Pact.Types (RewindLimit(..)) -import Chainweb.Payload.RestAPI (PayloadBatchLimit(..), defaultServicePayloadBatchLimit) -import Chainweb.Utils -import Chainweb.Version -import Chainweb.Version.Development -import Chainweb.Version.RecapDevelopment -import Chainweb.Version.Mainnet -import Chainweb.Version.Registry -import Chainweb.Time +-- | Configuration parser for the payload provider configuration. +-- +-- * if the value for a chain is Null, then the provider is disabled +-- * if the value is an object, then +-- * the provider is enabled +-- * the value updates a given value or the default value if no +-- previous value is present +-- +instance FromJSON (PayloadProviderConfig -> PayloadProviderConfig) where + parseJSON = withObject "PayloadProviderConfig" $ \o -> do + updateMinimal <- payloadProviderConfigMinimal %.: "default" % o + ifoldlM go updateMinimal (KM.toMapText o) + where + parseKey k = case T.stripPrefix "chain-" k of + Nothing -> fail $ "failed to parse chain key: " <> sshow k + Just x -> case T.decimal x of + Left e -> fail $ "failed to parse chain value: " <> e + Right (n, "") -> return $ unsafeChainId n + Right _ -> fail $ "trailng garabage when parsing chain value: " <> sshow x + + go "default" c _ = return c + go k c v = do + cid <- parseKey k + go2 cid c v + + -- disable provider: + go2 cid c Null = return $ (payloadProviderConfigPact . at cid .~ Nothing) . c + + -- enabled provider: + go2 cid c v = flip (withObject ("ProviderConfig for chain " <> sshow cid)) v $ \o -> do + (o .: "type") >>= \case + "pact" -> do + x <- parseJSON (Object o) + let f Nothing = Just (x defaultPactProviderConfig) + f (Just y) = Just (x y) + return $ (payloadProviderConfigPact . at cid %~ f) . c + "evm" -> do + x <- parseJSON (Object o) + let f Nothing = Just (x defaultEvmProviderConfig) + f (Just y) = Just (x y) + return $ (payloadProviderConfigEvm . at cid %~ f) . c + (x :: T.Text) -> fail $ "unknown payload provider type: " <> sshow x + +-- | Command line option parser for the payload provider configuration. +-- +-- * if --disable-chain-X is set: disable provider +-- * otherwise parse update function and return a with function +-- f Nothing = Just (x defaultValue), if --enable-chain-X is set +-- f Nothing = Nothing, if --enable-chain-X is not set +-- f (Just y) = Just (x y), i.e. if the payload provider is already enabled +-- +-- Note, that --disable-chain-X takes precendence over --enable-chain-X. +-- +pPayloadProviderConfig :: MParser PayloadProviderConfig +pPayloadProviderConfig = id + <$< parserOptionGroup "Minimal Payload Provider" + (payloadProviderConfigMinimal %:: pMinimalProviderConfig) + <*< pevm + where + cids = [ unsafeChainId i | i <- [0..100]] + -- FIXME this is is ugly. At least use the largest know graph. Ideally, + -- we would use the chainweb version -- but we don't know it yet. + -- For the help message we just display options for chain 0. + pevm = foldr (\a b -> a . b) id <$> traverse go cids + go cid + = parserOptionGroup "EVM [only options for chain 0 are shown]" evmChains + <|> parserOptionGroup "Pact [only for chain 0 are shown]" pactChains + where + evmChains = (payloadProviderConfigEvm . at cid %~) + <$> providerOpt "evm" cid defaultEvmProviderConfig pEvmProviderConfig + pactChains = (payloadProviderConfigPact . at cid %~) + <$> providerOpt "pact" cid defaultPactProviderConfig pPactProviderConfig -import P2P.Node.Configuration -import Chainweb.Pact.Backend.DbCache (DbCacheLimitBytes) +-- | Utility for parsing payload provider options: +-- +providerOpt + :: forall a + . String + -- ^ name of provider + -> ChainId + -> a + -- default value + -> (ChainId -> MParser a) + -- option parser for the payload provider + -> MParser (Maybe a) +providerOpt prov cid a p = f <$> dis <*> ena <*> p cid + where + f :: Bool -> Bool -> (a -> a) -> Maybe a -> Maybe a + f True _ _ _ = Nothing + f False False _ Nothing = Nothing + f False True update Nothing = Just (update a) + f False _ update (Just y) = Just (update y) + + ena = switch + % long ("enable-chain-" <> T.unpack (toText cid) <> "-" <> prov) + <> help ("enable the payload provider for this chain") + <> mconcat [ hidden <> internal | chainIdInt @Int cid /= 0 ] + + dis = switch + % long ("disable-chain-" <> T.unpack (toText cid) <> "-" <> prov) + <> help ("disabled the payload provider for this chain") + <> mconcat [ hidden <> internal | chainIdInt @Int cid /= 0 ] -- -------------------------------------------------------------------------- -- -- Throttling Configuration @@ -164,97 +343,46 @@ instance FromJSON (ThrottlingConfig -> ThrottlingConfig) where -- -------------------------------------------------------------------------- -- -- Cut Configuration -data ChainDatabaseGcConfig - = GcNone - | GcHeaders - | GcHeadersChecked - | GcFull - deriving (Show, Eq, Ord, Enum, Bounded, Generic) - -chainDatabaseGcToText :: ChainDatabaseGcConfig -> T.Text -chainDatabaseGcToText GcNone = "none" -chainDatabaseGcToText GcHeaders = "headers" -chainDatabaseGcToText GcHeadersChecked = "headers-checked" -chainDatabaseGcToText GcFull = "full" - -chainDatabaseGcFromText :: MonadThrow m => T.Text -> m ChainDatabaseGcConfig -chainDatabaseGcFromText t = case T.toCaseFold t of - "none" -> return GcNone - "headers" -> return GcHeaders - "headers-checked" -> return GcHeadersChecked - "full" -> return GcFull - x -> throwM $ TextFormatException $ "unknown value for database pruning configuration: " <> sshow x - -instance HasTextRepresentation ChainDatabaseGcConfig where - toText = chainDatabaseGcToText - fromText = chainDatabaseGcFromText - {-# INLINE toText #-} - {-# INLINE fromText #-} - -instance ToJSON ChainDatabaseGcConfig where - toJSON = toJSON . chainDatabaseGcToText - {-# INLINE toJSON #-} - -instance FromJSON ChainDatabaseGcConfig where - parseJSON v = parseJsonFromText "ChainDatabaseGcConfig" v <|> legacy v - where - legacy = withBool "ChainDatabaseGcConfig" $ \case - True -> return GcHeaders - False -> return GcNone - {-# INLINE parseJSON #-} - data CutConfig = CutConfig - { _cutPruneChainDatabase :: !ChainDatabaseGcConfig - , _cutFetchTimeout :: !Int + { _cutFetchTimeout :: !Int , _cutInitialBlockHeightLimit :: !(Maybe BlockHeight) - , _cutFastForwardBlockHeightLimit :: !(Maybe BlockHeight) + , _cutInitialCutFile :: !(Maybe FilePath) } deriving (Eq, Show) makeLenses ''CutConfig instance ToJSON CutConfig where toJSON o = object - [ "pruneChainDatabase" .= _cutPruneChainDatabase o - , "fetchTimeout" .= _cutFetchTimeout o + [ "fetchTimeout" .= _cutFetchTimeout o , "initialBlockHeightLimit" .= _cutInitialBlockHeightLimit o - , "fastForwardBlockHeightLimit" .= _cutFastForwardBlockHeightLimit o + , "initialCutFile" .= _cutInitialCutFile o ] instance FromJSON (CutConfig -> CutConfig) where parseJSON = withObject "CutConfig" $ \o -> id - <$< cutPruneChainDatabase ..: "pruneChainDatabase" % o - <*< cutFetchTimeout ..: "fetchTimeout" % o + <$< cutFetchTimeout ..: "fetchTimeout" % o <*< cutInitialBlockHeightLimit ..: "initialBlockHeightLimit" % o - <*< cutFastForwardBlockHeightLimit ..: "fastForwardBlockHeightLimit" % o + <*< cutInitialCutFile ..: "initialCutFile" % o defaultCutConfig :: CutConfig defaultCutConfig = CutConfig - { _cutPruneChainDatabase = GcNone - , _cutFetchTimeout = 3_000_000 + { _cutFetchTimeout = 4_125_000 , _cutInitialBlockHeightLimit = Nothing - , _cutFastForwardBlockHeightLimit = Nothing + , _cutInitialCutFile = Nothing } pCutConfig :: MParser CutConfig pCutConfig = id - <$< cutPruneChainDatabase .:: textOption - % long "prune-chain-database" - <> help - ( "How to prune the chain database on startup." - <> " This can take several hours." - ) - <> metavar "none|headers|headers-checked|full" - <*< cutFetchTimeout .:: option auto + <$< cutFetchTimeout .:: option auto % long "cut-fetch-timeout" <> help "The timeout for processing new cuts in microseconds" <*< cutInitialBlockHeightLimit .:: fmap (Just . BlockHeight) . option auto % long "initial-block-height-limit" <> help "Reset initial cut to this block height." <> metavar "INT" - <*< cutFastForwardBlockHeightLimit .:: fmap (Just . BlockHeight) . option auto - % long "fast-forward-block-height-limit" - <> help "When --only-sync-pact is given fast forward to this height. Ignored otherwise." - <> metavar "INT" + <*< cutInitialCutFile .:: fmap Just . textOption + % long "initial-cut-file" + <> help "When --initial-cut-file is given, use the cut in the given file as the initial cut. Note that this will not contact the P2P network." -- -------------------------------------------------------------------------- -- -- Service API Configuration @@ -275,7 +403,9 @@ data ServiceApiConfig = ServiceApiConfig , _serviceApiPayloadBatchLimit :: PayloadBatchLimit -- ^ maximum size for payload batches on the service API. Default is - -- 'Chainweb.Payload.RestAPI.defaultServicePayloadBatchLimit'. + -- 'Chainweb.Pact.Payload.RestAPI.defaultServicePayloadBatchLimit'. + , _serviceApiConfigHeaderStream :: !Bool + -- ^ whether to serve a header update stream endpoint. } deriving (Show, Eq, Generic) @@ -287,6 +417,7 @@ defaultServiceApiConfig = ServiceApiConfig , _serviceApiConfigInterface = "*" , _serviceApiConfigValidateSpec = False , _serviceApiPayloadBatchLimit = defaultServicePayloadBatchLimit + , _serviceApiConfigHeaderStream = False } instance ToJSON ServiceApiConfig where @@ -295,6 +426,7 @@ instance ToJSON ServiceApiConfig where , "interface" .= hostPreferenceToText (_serviceApiConfigInterface o) , "validateSpec" .= _serviceApiConfigValidateSpec o , "payloadBatchLimit" .= _serviceApiPayloadBatchLimit o + , "headerStream" .= _serviceApiConfigHeaderStream o ] instance FromJSON (ServiceApiConfig -> ServiceApiConfig) where @@ -303,6 +435,7 @@ instance FromJSON (ServiceApiConfig -> ServiceApiConfig) where <*< setProperty serviceApiConfigInterface "interface" (parseJsonFromText "interface") o <*< serviceApiConfigValidateSpec ..: "validateSpec" % o <*< serviceApiPayloadBatchLimit ..: "payloadBatchLimit" % o + <*< serviceApiConfigHeaderStream ..: "headerStream" % o pServiceApiConfig :: MParser ServiceApiConfig pServiceApiConfig = id @@ -317,6 +450,10 @@ pServiceApiConfig = id <*< serviceApiConfigValidateSpec .:: enableDisableFlag % prefixLong service "validate-spec" <> internal -- hidden option, for expert use + <*< serviceApiConfigHeaderStream .:: boolOption_ + % prefixLong service "header-stream" + <> help "whether to enable an endpoint for streaming block updates" + where service = Just "service" @@ -375,6 +512,34 @@ pBackupConfig = id where backup = Just "backup" +-- -------------------------------------------------------------------------- -- +-- Pruning Configuration + +data PruneConfig = PruneConfig + { _configPruneCommand :: PruneForks.DoPrune + } + deriving (Show, Eq) + +defaultPruneConfig :: PruneConfig +defaultPruneConfig = PruneConfig + { _configPruneCommand = PruneForks.Prune + } +makeLenses ''PruneConfig + +instance ToJSON PruneConfig where + toJSON cfg = object [ "command" .= _configPruneCommand cfg ] +instance FromJSON PruneConfig where + parseJSON = withObject "PruneConfig" $ \o -> + PruneConfig <$> o .: "command" +instance FromJSON (PruneConfig -> PruneConfig) where + parseJSON = withObject "PruneConfig" $ \o -> id + <$< configPruneCommand ..: "command" % o + +pPruneConfig :: MParser PruneConfig +pPruneConfig = id + <$< parserOptionGroup "Pruning" + (configPruneCommand .:: textOption (long "pruning-command")) + -- -------------------------------------------------------------------------- -- -- Chainweb Configuration @@ -382,46 +547,47 @@ data ChainwebConfiguration = ChainwebConfiguration { _configChainwebVersion :: !ChainwebVersion , _configCuts :: !CutConfig , _configMining :: !MiningConfig - , _configHeaderStream :: !Bool - , _configReintroTxs :: !Bool , _configP2p :: !P2pConfiguration , _configThrottling :: !ThrottlingConfig - , _configMempoolP2p :: !(EnableConfig MempoolP2pConfig) - , _configBlockGasLimit :: !Mempool.GasLimit - , _configLogGas :: !Bool - , _configMinGasPrice :: !Mempool.GasPrice - , _configPactQueueSize :: !Natural , _configReorgLimit :: !RewindLimit - , _configPreInsertCheckTimeout :: !Micros - , _configAllowReadsInLocal :: !Bool - , _configFullHistoricPactState :: !Bool , _configBackup :: !BackupConfig , _configServiceApi :: !ServiceApiConfig + , _configPayloadProviders :: PayloadProviderConfig + , _configPrune :: !PruneConfig + + -- The following properties are deprecated: history replay should not be + -- part of normal operation mode. It should probably use a completely + -- separate configuration. + , _configReadOnlyReplay :: !Bool -- ^ do a read-only replay using the cut db params for the block heights - , _configOnlySyncPact :: !Bool - -- ^ exit after synchronizing pact dbs to the latest cut - , _configSyncPactChains :: !(Maybe [ChainId]) + , _configSyncChains :: !(Maybe [ChainId]) -- ^ the only chains to be synchronized on startup to the latest cut. -- if unset, all chains will be synchronized. - , _configModuleCacheLimit :: !DbCacheLimitBytes - -- ^ module cache size limit in bytes - , _configEnableLocalTimeout :: !Bool + + , _configBackgroundJobsPoolSize :: !(Maybe Natural) + -- ^ the number of worker threads of the scheduler for background + -- jobs. If unset, a default of 'max 1 (getNumCapabilities div 2)' + -- is used. + } deriving (Show, Eq, Generic) makeLenses ''ChainwebConfiguration -instance HasChainwebVersion ChainwebConfiguration where - _chainwebVersion = _configChainwebVersion - {-# INLINE _chainwebVersion #-} - validateChainwebConfiguration :: ConfigValidation ChainwebConfiguration [] validateChainwebConfiguration c = do - validateMinerConfig (_configChainwebVersion c) (_configMining c) - validateBackupConfig (_configBackup c) - unless (c ^. chainwebVersion . versionDefaults . disablePeerValidation) $ - validateP2pConfiguration (_configP2p c) validateChainwebVersion (_configChainwebVersion c) + withVersion (_configChainwebVersion c) $ do + validateMinerConfig (_configMining c) + validateBackupConfig (_configBackup c) + unless (c ^. configChainwebVersion . versionDefaults . disablePeerValidation) $ + validateP2pConfiguration (_configP2p c) + validatePayloadProviderConfig (_configPayloadProviders c) + mapM_ checkBackgroundJobsPoolSize (_configBackgroundJobsPoolSize c) + where + checkBackgroundJobsPoolSize n = + unless (n >= 1) $ + throwError "background jobs pool size must be at least 1" validateChainwebVersion :: ConfigValidation ChainwebVersion [] validateChainwebVersion v = do @@ -432,7 +598,10 @@ validateChainwebVersion v = do , sshow (_versionName v) ] where - isDevelopment = _versionCode v `elem` [_versionCode dv | dv <- [recapDevnet, devnet]] + isDevelopment = _versionCode v `elem` + [_versionCode dv | dv <- + [recapDevnet, devnet, evmDevnet, evmDevnetSingleton, evmDevnetPair] + ] validateBackupConfig :: ConfigValidation BackupConfig [] validateBackupConfig c = @@ -447,26 +616,16 @@ defaultChainwebConfiguration v = ChainwebConfiguration { _configChainwebVersion = v , _configCuts = defaultCutConfig , _configMining = defaultMining - , _configHeaderStream = False - , _configReintroTxs = True , _configP2p = defaultP2pConfiguration , _configThrottling = defaultThrottlingConfig - , _configMempoolP2p = defaultEnableConfig defaultMempoolP2pConfig - , _configBlockGasLimit = 150_000 - , _configLogGas = False - , _configMinGasPrice = 1e-8 - , _configPactQueueSize = 2000 , _configReorgLimit = defaultReorgLimit - , _configPreInsertCheckTimeout = defaultPreInsertCheckTimeout - , _configAllowReadsInLocal = False - , _configFullHistoricPactState = True , _configServiceApi = defaultServiceApiConfig - , _configOnlySyncPact = False , _configReadOnlyReplay = False - , _configSyncPactChains = Nothing + , _configPrune = defaultPruneConfig + , _configSyncChains = Nothing , _configBackup = defaultBackupConfig - , _configModuleCacheLimit = defaultModuleCacheLimit - , _configEnableLocalTimeout = False + , _configPayloadProviders = defaultPayloadProviderConfig + , _configBackgroundJobsPoolSize = Nothing } instance ToJSON ChainwebConfiguration where @@ -474,26 +633,16 @@ instance ToJSON ChainwebConfiguration where [ "chainwebVersion" .= _versionName (_configChainwebVersion o) , "cuts" .= _configCuts o , "mining" .= _configMining o - , "headerStream" .= _configHeaderStream o - , "reintroTxs" .= _configReintroTxs o , "p2p" .= _configP2p o , "throttling" .= _configThrottling o - , "mempoolP2p" .= _configMempoolP2p o - , "gasLimitOfBlock" .= J.toJsonViaEncode (_configBlockGasLimit o) - , "logGas" .= _configLogGas o - , "minGasPrice" .= J.toJsonViaEncode (_configMinGasPrice o) - , "pactQueueSize" .= _configPactQueueSize o , "reorgLimit" .= _configReorgLimit o - , "preInsertCheckTimeout" .= _configPreInsertCheckTimeout o - , "allowReadsInLocal" .= _configAllowReadsInLocal o - , "fullHistoricPactState" .= _configFullHistoricPactState o , "serviceApi" .= _configServiceApi o - , "onlySyncPact" .= _configOnlySyncPact o , "readOnlyReplay" .= _configReadOnlyReplay o - , "syncPactChains" .= _configSyncPactChains o + , "syncChains" .= _configSyncChains o , "backup" .= _configBackup o - , "moduleCacheLimit" .= _configModuleCacheLimit o - , "enableLocalTimeout" .= _configEnableLocalTimeout o + , "payloadProviders" .= _configPayloadProviders o + , "pruning" .= _configPrune o + , "backgroundJobsPoolSize" .= _configBackgroundJobsPoolSize o ] instance FromJSON ChainwebConfiguration where @@ -505,86 +654,44 @@ instance FromJSON (ChainwebConfiguration -> ChainwebConfiguration) where (findKnownVersion <=< parseJSON) o <*< configCuts %.: "cuts" % o <*< configMining %.: "mining" % o - <*< configHeaderStream ..: "headerStream" % o - <*< configReintroTxs ..: "reintroTxs" % o <*< configP2p %.: "p2p" % o <*< configThrottling %.: "throttling" % o - <*< configMempoolP2p %.: "mempoolP2p" % o - <*< configBlockGasLimit ..: "gasLimitOfBlock" % o - <*< configLogGas ..: "logGas" % o - <*< configMinGasPrice ..: "minGasPrice" % o - <*< configPactQueueSize ..: "pactQueueSize" % o <*< configReorgLimit ..: "reorgLimit" % o - <*< configAllowReadsInLocal ..: "allowReadsInLocal" % o - <*< configPreInsertCheckTimeout ..: "preInsertCheckTimeout" % o - <*< configFullHistoricPactState ..: "fullHistoricPactState" % o <*< configServiceApi %.: "serviceApi" % o - <*< configOnlySyncPact ..: "onlySyncPact" % o <*< configReadOnlyReplay ..: "readOnlyReplay" % o - <*< configSyncPactChains ..: "syncPactChains" % o + <*< configSyncChains ..: "syncChains" % o <*< configBackup %.: "backup" % o - <*< configModuleCacheLimit ..: "moduleCacheLimit" % o - <*< configEnableLocalTimeout ..: "enableLocalTimeout" % o + <*< configPayloadProviders %.: "payloadProviders" % o + <*< configPrune %.: "pruning" % o + <*< configBackgroundJobsPoolSize ..: "backgroundJobsPoolSize" % o pChainwebConfiguration :: MParser ChainwebConfiguration pChainwebConfiguration = id <$< configChainwebVersion %:: parseVersion - <*< configHeaderStream .:: boolOption_ - % long "header-stream" - <> help "whether to enable an endpoint for streaming block updates" - <*< configReintroTxs .:: enableDisableFlag - % long "tx-reintro" - <> help "whether to enable transaction reintroduction from losing forks" - <*< configP2p %:: pP2pConfiguration - <*< configMempoolP2p %:: - pEnableConfig "mempool-p2p" pMempoolP2pConfig - <*< configBlockGasLimit .:: jsonOption - % long "block-gas-limit" - <> help "the sum of all transaction gas fees in a block must not exceed this number" - <*< configLogGas .:: boolOption_ - % long "log-gas" - <> help "log gas consumed by Pact commands" - <*< configMinGasPrice .:: jsonOption - % long "min-gas-price" - <> help "the gas price of an individual transaction in a block must not be beneath this number" - <*< configPactQueueSize .:: jsonOption - % long "pact-queue-size" - <> help "max size of pact internal queue" + <*< parserOptionGroup "P2P" (configP2p %:: pP2pConfiguration) <*< configReorgLimit .:: jsonOption % long "reorg-limit" <> help "Max allowed reorg depth.\ \ Consult https://github.com/kadena-io/chainweb-node/blob/master/docs/RecoveringFromDeepForks.md for\ \ more information. " - <*< configPreInsertCheckTimeout .:: jsonOption - % long "pre-insert-check-timeout" - <> help "Max allowed time in microseconds for the transactions validation in the PreInsertCheck command." - <*< configAllowReadsInLocal .:: boolOption_ - % long "allowReadsInLocal" - <> help "Enable direct database reads of smart contract tables in local queries." - <*< configFullHistoricPactState .:: boolOption_ - % long "full-historic-pact-state" - <> help "Write full historic Pact state; only enable for custodial or archival nodes." - <*< configCuts %:: pCutConfig - <*< configServiceApi %:: pServiceApiConfig - <*< configMining %:: pMiningConfig - <*< configOnlySyncPact .:: boolOption_ - % long "only-sync-pact" - <> help "Terminate after synchronizing the pact databases to the latest cut" + <*< parserOptionGroup "Cut Processing" (configCuts %:: pCutConfig) + <*< parserOptionGroup "Service API" (configServiceApi %:: pServiceApiConfig) + <*< parserOptionGroup "Mining Coordination" (configMining %:: pMiningConfig) <*< configReadOnlyReplay .:: boolOption_ % long "read-only-replay" <> help "Replay the block history non-destructively" - <*< configSyncPactChains .:: fmap Just % jsonOption - % long "sync-pact-chains" + <*< configSyncChains .:: fmap Just % jsonOption + % long "sync-chains" <> help "The only Pact databases to synchronize. If empty or unset, all chains will be synchronized." <> metavar "JSON list of chain ids" - <*< configBackup %:: pBackupConfig - <*< configModuleCacheLimit .:: option auto - % long "module-cache-limit" - <> help "Maximum size of the per-chain checkpointer module cache in bytes" - <> metavar "INT" - <*< configEnableLocalTimeout .:: option auto - % long "enable-local-timeout" - <> help "Enable timeout support on /local endpoints" + <*< parserOptionGroup "Backup" (configBackup %:: pBackupConfig) + + -- FIXME support payload providers + <*< configPayloadProviders %:: pPayloadProviderConfig + <*< configPrune %:: pPruneConfig + <*< configBackgroundJobsPoolSize .:: fmap Just % option auto + % prefixLong (Just "background-jobs") "pool-size" + <> suffixHelp (Just "background-jobs") "size of the thread pool for the background jobs scheduler" parseVersion :: MParser ChainwebVersion parseVersion = constructVersion @@ -593,6 +700,8 @@ parseVersion = constructVersion % long "chainweb-version" <> short 'v' <> help "the chainweb version that this node is using" + <> metavar (T.unpack $ + "[" <> T.intercalate "," (getChainwebVersionName . _versionName <$> knownVersions) <> "]") ) <*> optional (textOption @Fork (long "fork-upper-bound" <> help "(development mode only) the latest fork the node will enable")) <*> optional (BlockDelay <$> textOption (long "block-delay" <> help "(development mode only) the block delay in seconds per block")) @@ -603,7 +712,7 @@ parseVersion = constructVersion & versionForks %~ HM.filterWithKey (\fork _ -> fork <= fromMaybe maxBound fub) & versionUpgrades .~ maybe (_versionUpgrades winningVersion) (\fub' -> - OnChains $ HM.mapWithKey + ChainMap $ HM.mapWithKey (\cid _ -> let currentUpgrades = winningVersion ^?! versionUpgrades . atChain cid in case winningVersion ^?! versionForks . at fub' . _Just . atChain cid of @@ -612,7 +721,7 @@ parseVersion = constructVersion ForkAtGenesis -> winningVersion ^?! versionUpgrades . atChain cid ForkAtForkNumber _ -> currentUpgrades -- For now, version upgrades were only allowed at block heights ) - (HS.toMap (chainIds winningVersion)) + (HS.toMap (withVersion winningVersion chainIds)) ) fub & versionCheats . disablePow .~ disablePow' where diff --git a/src/Chainweb/Chainweb/CutResources.hs b/src/Chainweb/Chainweb/CutResources.hs index e9ee1a4969..fa3e3ba796 100644 --- a/src/Chainweb/Chainweb/CutResources.hs +++ b/src/Chainweb/Chainweb/CutResources.hs @@ -1,5 +1,6 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ImportQualifiedPost #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} @@ -21,189 +22,114 @@ -- should be kept after intialization of the node is complete. -- module Chainweb.Chainweb.CutResources -( CutSyncResources(..) -, CutResources(..) -, cutsCutDb +( CutResources(..) +, cutResPeerDb +, cutResCutDb +, cutResCutP2pNode +, cutResHeaderP2pNode , withCutResources , cutNetworks ) where -import Control.Lens hiding ((.=), (<.>)) -import Control.Monad -import Control.Monad.Catch - -import qualified Data.Text as T +import Control.Lens +import Control.Monad (forM) +import Control.Monad.IO.Class +import Control.Monad.Trans.Resource import Prelude hiding (log) -import qualified Network.HTTP.Client as HTTP - -import System.LogLevel +import Network.HTTP.Client qualified as HTTP -- internal modules -import Chainweb.Chainweb.PeerResources +import Chainweb.Cut (Cut) import Chainweb.CutDB -import qualified Chainweb.CutDB.Sync as C +import Chainweb.CutDB.Sync qualified as C import Chainweb.Logger -import Chainweb.Payload.PayloadStore import Chainweb.RestAPI.NetworkID import Chainweb.Sync.WebBlockHeaderStore import Chainweb.Version import Chainweb.WebBlockHeaderDB -import Chainweb.WebPactExecutionService import Chainweb.Storage.Table.RocksDB import P2P.Node +import P2P.Node.Configuration import P2P.Peer -import P2P.Session import P2P.TaskQueue +import Chainweb.PayloadProvider +import Data.Text qualified as T +import P2P.Session (P2pSession) +import P2P.Node.PeerDB (PeerDb) -- -------------------------------------------------------------------------- -- -- Cuts Resources -data CutSyncResources logger = CutSyncResources - { _cutResSyncSession :: !P2pSession - , _cutResSyncLogger :: !logger - } - -data CutResources logger tbl = CutResources - { _cutResCutConfig :: !CutDbParams - , _cutResPeer :: !(PeerResources logger) - , _cutResCutDb :: !(CutDb tbl) - , _cutResLogger :: !logger - , _cutResCutSync :: !(CutSyncResources logger) - , _cutResHeaderSync :: !(CutSyncResources logger) - , _cutResPayloadSync :: !(CutSyncResources logger) +data CutResources l = CutResources + { _cutResPeerDb :: !PeerDb + , _cutResCutDb :: !(CutDb l) + , _cutResCutP2pNode :: !P2pNode + -- ^ P2P Network for pushing and synchronizing cuts. + , _cutResHeaderP2pNode :: !P2pNode + -- ^ P2P Network for fetching block headers on demand via a task queue. } -makeLensesFor - [ ("_cutResCutDb", "cutsCutDb") - ] ''CutResources - -instance HasChainwebVersion (CutResources logger tbl) where - _chainwebVersion = _chainwebVersion . _cutResCutDb - {-# INLINE _chainwebVersion #-} +makeLenses ''CutResources withCutResources :: Logger logger - => CanPayloadCas tbl - => CutDbParams - -> PeerResources logger - -> logger + => HasVersion + => logger + -> CutDbParams + -> P2pConfiguration + -> PeerInfo + -> PeerDb -> RocksDb -> WebBlockHeaderDb - -> PayloadDb tbl + -> ChainMap ConfiguredPayloadProvider -> HTTP.Manager - -> WebPactExecutionService - -> (forall tbl' . CanReadablePayloadCas tbl' => CutResources logger tbl' -> IO a) - -> IO a -withCutResources cutDbParams peer logger rdb webchain payloadDb mgr pact f = do + -> ResourceT IO (Either Cut (CutResources logger)) +withCutResources logger cutDbParams p2pConfig myInfo peerDb rdb webchain providers mgr = do -- initialize blockheader store - headerStore <- newWebBlockHeaderStore mgr webchain (logFunction logger) - - -- initialize payload store - payloadStore <- newWebPayloadStore mgr pact payloadDb (logFunction logger) + headerStore <- liftIO $ newWebBlockHeaderStore mgr webchain logger -- initialize cutHashes store let cutHashesStore = cutHashesTable rdb - withCutDb cutDbParams (logFunction logger) headerStore payloadStore cutHashesStore $ \cutDb -> - f $ CutResources - { _cutResCutConfig = cutDbParams - , _cutResPeer = peer + initialCutOrCutDb <- withCutDb cutDbParams logger headerStore providers cutHashesStore + forM initialCutOrCutDb $ \cutDb -> do + cutP2pNode <- liftIO $ mkP2pNode True "cut" $ + C.syncSession myInfo cutDb + headerP2pNode <- liftIO $ mkP2pNode False "header" $ + session 10 (_webBlockHeaderStoreQueue headerStore) + return CutResources + { _cutResPeerDb = peerDb , _cutResCutDb = cutDb - , _cutResLogger = logger - , _cutResCutSync = CutSyncResources - { _cutResSyncSession = C.syncSession v (_peerInfo $ _peerResPeer peer) cutDb - , _cutResSyncLogger = addLabel ("sync", "cut") syncLogger - } - , _cutResHeaderSync = CutSyncResources - { _cutResSyncSession = session 10 (_webBlockHeaderStoreQueue headerStore) - , _cutResSyncLogger = addLabel ("sync", "header") syncLogger - } - , _cutResPayloadSync = CutSyncResources - { _cutResSyncSession = session 10 (_webBlockPayloadStoreQueue payloadStore) - , _cutResSyncLogger = addLabel ("sync", "payload") syncLogger - } + , _cutResCutP2pNode = cutP2pNode + , _cutResHeaderP2pNode = headerP2pNode } where - v = _chainwebVersion webchain syncLogger = addLabel ("sub-component", "sync") logger + mkP2pNode :: Bool -> T.Text -> P2pSession -> IO P2pNode + mkP2pNode doPeerSync label s = p2pCreateNode $ P2pNodeParameters + { _p2pNodeParamsMyPeerInfo = myInfo + , _p2pNodeParamsSession = s + , _p2pNodeParamsSessionTimeout = _p2pConfigSessionTimeout p2pConfig + , _p2pNodeParamsMaxSessionCount = _p2pConfigMaxSessionCount p2pConfig + , _p2pNodeParamsIsPrivate = _p2pConfigPrivate p2pConfig + , _p2pNodeParamsDoPeerSync = doPeerSync + , _p2pNodeParamsManager = mgr + , _p2pNodeParamsPeerDb = peerDb + , _p2pNodeParamsLogFunction = logFunction (addLabel ("sync", label) syncLogger) + , _p2pNodeParamsNetworkId = CutNetwork + } + -- | The networks that are used by the cut DB. -- -cutNetworks - :: Logger logger - => HTTP.Manager - -> CutResources logger tbl - -> [IO ()] -cutNetworks mgr cuts = - [ runCutNetworkCutSync mgr cuts - , runCutNetworkHeaderSync mgr cuts - , runCutNetworkPayloadSync mgr cuts +cutNetworks :: HasVersion => CutResources l -> [IO ()] +cutNetworks cuts = + [ p2pRunNode (_cutResCutP2pNode cuts) + , p2pRunNode (_cutResHeaderP2pNode cuts) ] - --- | P2P Network for pushing Cuts --- -runCutNetworkCutSync - :: Logger logger - => HTTP.Manager - -> CutResources logger tbl - -> IO () -runCutNetworkCutSync mgr c - = mkCutNetworkSync mgr True c "cut sync" $ _cutResCutSync c - --- | P2P Network for Block Headers --- -runCutNetworkHeaderSync - :: Logger logger - => HTTP.Manager - -> CutResources logger tbl - -> IO () -runCutNetworkHeaderSync mgr c - = mkCutNetworkSync mgr False c "block header sync" $ _cutResHeaderSync c - --- | P2P Network for Block Payloads --- -runCutNetworkPayloadSync - :: Logger logger - => HTTP.Manager - -> CutResources logger tbl - -> IO () -runCutNetworkPayloadSync mgr c - = mkCutNetworkSync mgr False c "block payload sync" $ _cutResPayloadSync c - --- | P2P Network for Block Payloads --- --- This uses the 'CutNetwork' for syncing peers. The network doesn't restrict --- the API network endpoints that are used in the client sessions. --- -mkCutNetworkSync - :: Logger logger - => HTTP.Manager - -> Bool - -- ^ Do peer synchronization - -> CutResources logger tbl - -> T.Text - -> CutSyncResources logger - -> IO () -mkCutNetworkSync mgr doPeerSync cuts label cutSync = bracket create destroy $ \n -> - p2pStartNode (_peerResConfig $ _cutResPeer cuts) n - where - v = _chainwebVersion cuts - peer = _peerResPeer $ _cutResPeer cuts - logger = _cutResSyncLogger cutSync - peerDb = _peerResDb $ _cutResPeer cuts - s = _cutResSyncSession cutSync - - create = do - !n <- p2pCreateNode v CutNetwork peer (logFunction logger) peerDb mgr doPeerSync s - logFunctionText logger Debug $ label <> ": initialized" - return n - - destroy n = do - p2pStopNode n - logFunctionText logger Info $ label <> ": stopped" diff --git a/src/Chainweb/Chainweb/MempoolSyncClient.hs b/src/Chainweb/Chainweb/MempoolSyncClient.hs index 953c2cdcdc..cc0f63bb78 100644 --- a/src/Chainweb/Chainweb/MempoolSyncClient.hs +++ b/src/Chainweb/Chainweb/MempoolSyncClient.hs @@ -19,44 +19,37 @@ module Chainweb.Chainweb.MempoolSyncClient import Chainweb.Time -import Control.Lens hiding ((.=), (<.>)) -import Control.Monad -import Control.Monad.Catch - -import qualified Data.Text as T - import qualified Network.HTTP.Client as HTTP import Prelude hiding (log) -import System.LogLevel - -- internal modules -import Chainweb.ChainId import Chainweb.Chainweb.ChainResources import Chainweb.Chainweb.PeerResources import Chainweb.Logger -import qualified Chainweb.Mempool.Mempool as Mempool -import Chainweb.Mempool.P2pConfig -import qualified Chainweb.Mempool.RestAPI.Client as MPC -import Chainweb.RestAPI.NetworkID -import Chainweb.Utils +import Chainweb.Pact.Mempool.P2pConfig import Chainweb.Version -import P2P.Node.Configuration import P2P.Session -import P2P.Node - -import qualified Servant.Client as Sv -- -------------------------------------------------------------------------- -- -- Mempool sync. +-- FIXME this should be moved into Pact. +-- +-- While Pact is still part of the chainweb-node process, the pact networks will +-- be run via the global p2p infrastructure. +-- +-- However, These network should show up in the node initialization under +-- payloadProviderNetworks and should probably be bundled with the payload +-- networks from pact. + -- | Synchronize the local mempool over the P2P network. -- runMempoolSyncClient :: Logger logger + => HasVersion => HTTP.Manager -- ^ HTTP connection pool -> MempoolP2pConfig @@ -64,50 +57,59 @@ runMempoolSyncClient -> ChainResources logger -- ^ chain resources -> IO () -runMempoolSyncClient mgr memP2pConfig peerRes chain = bracket create destroy go - where - create = do - logg Debug "starting mempool p2p sync" - p2pCreateNode v netId peer (logFunction syncLogger) peerDb mgr True $ - mempoolSyncP2pSession chain (_mempoolP2pConfigPollInterval memP2pConfig) - go n = do - -- Run P2P client node - logg Debug "mempool sync p2p node initialized, starting session" - p2pStartNode p2pConfig n - - destroy n = p2pStopNode n `finally` logg Debug "mempool sync p2p node stopped" - - v = _chainwebVersion chain - peer = _peerResPeer peerRes - p2pConfig = _peerResConfig peerRes - & set p2pConfigMaxSessionCount (_mempoolP2pConfigMaxSessionCount memP2pConfig) - & set p2pConfigSessionTimeout (_mempoolP2pConfigSessionTimeout memP2pConfig) - peerDb = _peerResDb peerRes - netId = MempoolNetwork $ _chainId chain - - logg = logFunctionText syncLogger - syncLogger = setComponent "mempool-sync" $ _chainResLogger chain +runMempoolSyncClient _mgr _memP2pConfig _peerRes _chain = + error "Chainweb.Chainweb.MempoolSyncClient.mempoolSyncClient: only supported for pact service which is currently disabled" +-- bracket create destroy go +-- where +-- create = do +-- logg Debug "starting mempool p2p sync" +-- p2pCreateNode v netId peer (logFunction syncLogger) peerDb mgr True $ +-- mempoolSyncP2pSession chain (_mempoolP2pConfigPollInterval memP2pConfig) +-- go n = do +-- -- Run P2P client node +-- logg Debug "mempool sync p2p node initialized, starting session" +-- p2pStartNode p2pConfig n +-- +-- destroy n = p2pStopNode n `finally` logg Debug "mempool sync p2p node stopped" +-- +-- v = _chainwebVersion chain +-- peer = _peerResPeer peerRes +-- p2pConfig = _peerResConfig peerRes +-- & set p2pConfigMaxSessionCount (_mempoolP2pConfigMaxSessionCount memP2pConfig) +-- & set p2pConfigSessionTimeout (_mempoolP2pConfigSessionTimeout memP2pConfig) +-- peerDb = _peerResDb peerRes +-- netId = MempoolNetwork $ _chainId chain +-- +-- logg = logFunctionText syncLogger +-- syncLogger = setComponent "mempool-sync" $ _chainResLogger chain -mempoolSyncP2pSession - :: ChainResources logger +-- | FIXME: +-- +-- the mempool should be part of pact. The API can be published to the node API +-- in the same way the Payload APIs are published. +-- +_mempoolSyncP2pSession + :: HasVersion + => ChainResources logger -> Seconds -> P2pSession -mempoolSyncP2pSession chain (Seconds pollInterval) logg0 env _ = do - logg Debug "mempool sync session starting" - Mempool.syncMempools' logg syncIntervalUs pool peerMempool - logg Debug "mempool sync session finished" - return True - where - peerMempool = MPC.toMempool v cid txcfg env - - -- FIXME Potentially dangerous down-cast. - syncIntervalUs :: Int - syncIntervalUs = int pollInterval * 500000 - - remote = T.pack $ Sv.showBaseUrl $ Sv.baseUrl env - logg d m = logg0 d $ T.concat ["[mempool sync@", remote, "]:", m] - - pool = _chainResMempool chain - txcfg = Mempool.mempoolTxConfig pool - cid = _chainId chain - v = _chainwebVersion chain +_mempoolSyncP2pSession _chain (Seconds _pollInterval) _logg0 _env _ = do + error "Chainweb.Chainweb.MempoolSyncClient.mempoolSyncP2pSession: only supported for pact service which is currently disabled" +-- logg Debug "mempool sync session starting" +-- Mempool.syncMempools' logg syncIntervalUs pool peerMempool +-- logg Debug "mempool sync session finished" +-- return True +-- where +-- peerMempool = MPC.toMempool v cid txcfg env +-- +-- -- FIXME Potentially dangerous down-cast. +-- syncIntervalUs :: Int +-- syncIntervalUs = int pollInterval * 500000 +-- +-- remote = T.pack $ Sv.showBaseUrl $ Sv.baseUrl env +-- logg d m = logg0 d $ T.concat ["[mempool sync@", remote, "]:", m] +-- +-- pool = _chainResMempool chain +-- txcfg = Mempool.mempoolTxConfig pool +-- cid = _chainId chain +-- v = _chainwebVersion chain diff --git a/src/Chainweb/Chainweb/MinerResources.hs b/src/Chainweb/Chainweb/MinerResources.hs index af646a56bf..3eeb2e2d15 100644 --- a/src/Chainweb/Chainweb/MinerResources.hs +++ b/src/Chainweb/Chainweb/MinerResources.hs @@ -1,12 +1,8 @@ -{-# LANGUAGE BangPatterns #-} {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE NumericUnderscores #-} -{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE ImportQualifiedPost #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} -- | @@ -31,266 +27,60 @@ module Chainweb.Chainweb.MinerResources , withMiningCoordination ) where -import Control.Concurrent (threadDelay) -import Control.Concurrent.Async -import Control.Concurrent.STM (atomically) -import Control.Concurrent.STM.TVar -import Control.Lens -import Control.Monad - -import Data.HashMap.Strict (HashMap) -import qualified Data.HashMap.Strict as HM -import qualified Data.HashSet as HS -import Data.IORef (IORef, atomicWriteIORef, newIORef, readIORef) -import qualified Data.Map.Strict as M -import Data.Maybe -import qualified Data.Set as S -import qualified Data.Vector as V - -import System.LogLevel (LogLevel(..)) -import qualified System.Random.MWC as MWC - --- internal modules - -import Chainweb.BlockHeader import Chainweb.ChainId import Chainweb.Chainweb.ChainResources -import Chainweb.Cut (_cutMap) -import Chainweb.CutDB (CutDb, awaitNewBlock, cutDbPactService, _cut) +import Chainweb.CutDB import Chainweb.Logger import Chainweb.Miner.Config import Chainweb.Miner.Coordinator import Chainweb.Miner.Miners -import Chainweb.Miner.Pact (Miner(..), minerId) -import Chainweb.Pact.Types -import Chainweb.Pact.Utils -import Chainweb.Payload -import Chainweb.Payload.PayloadStore -import Chainweb.Sync.WebBlockHeaderStore -import Chainweb.Time -import Chainweb.Utils import Chainweb.Version -import Chainweb.WebPactExecutionService -import Utils.Logging.Trace - -import Data.LogMessage (JsonLog(..), LogFunction) - -import Numeric.AffineSpace +import Control.Concurrent.Async +import Control.Lens +import Data.LogMessage (LogFunction) +import System.Random.MWC qualified as MWC -- -------------------------------------------------------------------------- -- -- Miner +-- | Setup and Start Mining Coordination. +-- +-- Provides the payload caches that can be filled by payload providers and +-- listens on new payloads and cuts and creates and delivers work to the mining +-- clients. +-- +-- FIXME: We may hide the constructors of MiningCoordination and only expose +-- what is useful to other components +-- withMiningCoordination :: Logger logger + => HasVersion => logger -> MiningConfig - -> CutDb tbl - -> (Maybe (MiningCoordination logger tbl) -> IO a) + -> CutDb logger + -> (Maybe (MiningCoordination logger) -> IO a) -> IO a withMiningCoordination logger conf cdb inner | not (_coordinationEnabled coordConf) = inner Nothing | otherwise = do - cut <- _cut cdb - t <- newTVarIO mempty - initialPw <- fmap (PrimedWork . HM.fromList) $ - forM miners $ \miner -> - let mid = view minerId miner - in fmap ((mid,) . HM.fromList) $ - forM cids $ \cid -> do - let bh = fromMaybe (genesisBlockHeader v cid) (HM.lookup cid (_cutMap cut)) - newBlock <- throwIfNoHistory =<< getPayload cid miner (ParentHeader bh) - return (cid, WorkReady newBlock) - - m <- newTVarIO initialPw - c503 <- newIORef 0 - c403 <- newIORef 0 - l <- newIORef (_coordinationUpdateStreamLimit coordConf) - fmap thd . runConcurrently $ (,,) - <$> Concurrently (prune t m c503 c403) - <*> Concurrently (mapConcurrently_ (primeWork m) cids) - <*> Concurrently (inner . Just $ MiningCoordination - { _coordLogger = logger - , _coordCutDb = cdb - , _coordState = t - , _coordLimit = _coordinationReqLimit coordConf - , _coord503s = c503 - , _coord403s = c403 - , _coordConf = coordConf - , _coordUpdateStreamCount = l - , _coordPrimedWork = m - , _coordTargetFork = - if _coordinationTargetForkOverride coordConf - then pred $ max 1 (_versionForkNumber v) - else _versionForkNumber v - }) + coord <- newMiningCoordination logger coordConf cdb + withAsync (runCoordination coord) $ \_ -> + inner (Just coord) where + -- providers = view cutDbPayloadProviders cdb coordConf = _miningCoordination conf - inNodeConf = _miningInNode conf - v = _chainwebVersion cdb - - cids :: [ChainId] - cids = HS.toList (chainIds v) - - !miners = S.toList (_coordinationMiners coordConf) - <> [ _nodeMiner inNodeConf | _nodeMiningEnabled inNodeConf ] - - chainLogger cid = addLabel ("chain", toText cid) - - -- we assume that this path always exists in PrimedWork and never delete it. - workForMiner :: Miner -> ChainId -> Traversal' PrimedWork WorkState - workForMiner miner cid = _Wrapped' . ix (view minerId miner) . ix cid - - periodicallyRefreshPayload :: TVar PrimedWork -> ChainId -> Miner -> IO a - periodicallyRefreshPayload tpw cid ourMiner = forever $ do - let delay = - timeSpanToMicros $ _coordinationPayloadRefreshDelay coordConf - threadDelay (fromIntegral @Micros @Int delay) - when (not $ v ^. versionCheats . disablePact) $ do - -- "stale" in the sense of not having all of the transactions - -- that it could. it still has the latest possible parent - mContinuableBlockInProgress <- atomically $ do - primed <- readTVar tpw <&> (^?! workForMiner ourMiner cid) - case primed of - WorkReady (NewBlockInProgress bip) -> return (Just bip) - WorkReady (NewBlockPayload {}) -> - error "periodicallyRefreshPayload: encountered NewBlockPayload in PrimedWork, which cannot be refreshed" - WorkAlreadyMined {} -> return Nothing - WorkStale -> return Nothing - - forM_ mContinuableBlockInProgress $ \continuableBlockInProgress -> do - maybeNewBlock <- case continuableBlockInProgress of - ForPact4 block -> fmap ForPact4 <$> _pactContinueBlock pact cid block - ForPact5 block -> fmap ForPact5 <$> _pactContinueBlock pact cid block - -- if continuing returns NoHistory then the parent header - -- isn't available in the checkpointer right now. - -- in that case we just mark the payload as not stale. - let newBlock = case maybeNewBlock of - NoHistory -> continuableBlockInProgress - Historical b -> b - - logFunctionText (chainLogger cid logger) Debug - $ "refreshed block, old and new tx count: " - <> sshow - ( forAnyPactVersion (V.length . _transactionPairs . _blockInProgressTransactions) continuableBlockInProgress - , forAnyPactVersion (V.length . _transactionPairs . _blockInProgressTransactions) newBlock - ) - - atomically $ modifyTVar' tpw $ - workForMiner ourMiner cid .~ WorkReady (NewBlockInProgress newBlock) - - -- | THREAD: Keep a live-updated cache of Payloads for specific miners, such - -- that when they request new work, the block can be instantly constructed - -- without interacting with the Pact Queue. - -- - primeWork :: TVar PrimedWork -> ChainId -> IO () - primeWork tpw cid = - forConcurrently_ miners $ \miner -> - runForever (logFunction (chainLogger cid logger)) "primeWork" (go miner) - where - go :: Miner -> IO () - go miner = do - pw <- readTVarIO tpw - let - -- we assume that this path always exists in PrimedWork and never delete it. - ourMiner :: Traversal' PrimedWork WorkState - ourMiner = workForMiner miner cid - let !outdatedPayload = fromJuste $ pw ^? ourMiner - let outdatedParentHash = case outdatedPayload of - WorkReady outdatedBlock -> view _1 (newBlockParent outdatedBlock) - WorkAlreadyMined outdatedBlockHash -> outdatedBlockHash - WorkStale -> error "primeWork loop: Invariant Violation: Stale work should be an impossibility" - - newParent <- either ParentHeader id <$> race - -- wait for a block different from what we've got primed work for - (awaitNewBlock cdb cid outdatedParentHash) - -- in the meantime, periodically refresh the payload to make sure - -- it has all of the transactions it can have - (periodicallyRefreshPayload tpw cid miner) - - -- Temporarily block this chain from being considered for queries - atomically $ modifyTVar' tpw (ourMiner .~ WorkStale) - - -- Get a payload for the new block - getPayload cid miner newParent >>= \case - NoHistory -> do - logFunctionText (addLabel ("chain", toText cid) logger) Warn - "current block is not in the checkpointer; halting primed work loop temporarily" - approximateThreadDelay 1_000_000 - atomically $ modifyTVar' tpw (ourMiner .~ outdatedPayload) - Historical newBlock -> - atomically $ modifyTVar' tpw (ourMiner .~ WorkReady newBlock) - - getPayload :: ChainId -> Miner -> ParentHeader -> IO (Historical NewBlock) - getPayload cid m ph = - if v ^. versionCheats . disablePact - -- if pact is disabled, we must keep track of the latest header - -- ourselves. otherwise we use the header we get from newBlock as the - -- real parent. newBlock may return a header in the past due to a race - -- with rocksdb though that shouldn't cause a problem, just wasted work, - -- see docs for - -- Chainweb.Pact.PactService.Checkpointer.findLatestValidBlockHeader' - then return $ Historical $ - NewBlockPayload ph emptyPayload - else trace (logFunction (chainLogger cid logger)) - "Chainweb.Chainweb.MinerResources.withMiningCoordination.newBlock" - () 1 (_pactNewBlock pact cid m NewBlockFill ph) - - pact :: PactExecutionService - pact = _webPactExecutionService $ view cutDbPactService cdb - - -- | THREAD: Periodically clear out the cached payloads kept for Mining - -- Coordination. - -- - prune :: TVar MiningState -> TVar PrimedWork -> IORef Int -> IORef Int -> IO () - prune t tpw c503 c403 = runForever (logFunction logger) "MinerResources.prune" $ do - let !d = 30_000_000 -- 30 seconds - let !maxAge = (5 :: Int) `scaleTimeSpan` minute -- 5 minutes - threadDelay d - ago <- (.-^ maxAge) <$> getCurrentTimeIntegral - m@(MiningState ms) <- atomically $ do - ms <- readTVar t - modifyTVar' t . over miningState $ M.filter (f ago) - pure ms - count503 <- readIORef c503 - count403 <- readIORef c403 - PrimedWork pw <- readTVarIO tpw - atomicWriteIORef c503 0 - atomicWriteIORef c403 0 - logFunction logger Info . JsonLog $ MiningStats - { _statsCacheSize = M.size ms - , _stats503s = count503 - , _stats403s = count403 - , _statsAvgTxs = avgTxs m - , _statsPrimedSize = HM.foldl' (\acc xs -> acc + HM.size xs) 0 pw } - - -- Filter for work items that are not older than maxAge - -- - -- NOTE: Should difficulty ever become that hard that five minutes aren't - -- sufficient to mine a block this constant must be changed in order to - -- recover. - -- - f :: Time Micros -> T3 a b (Time Micros) -> Bool - f ago (T3 _ _ added) = added > ago - - avgTxs :: MiningState -> Int - avgTxs (MiningState ms) = summed `div` max 1 (M.size ms) - where - summed :: Int - summed = M.foldl' (\acc (T3 _ ps _) -> acc + g ps) 0 ms - - g :: PayloadWithOutputs -> Int - g = V.length . _payloadWithOutputsTransactions +-- -------------------------------------------------------------------------- -- -- | Miner resources are used by the test-miner when in-node mining is -- configured or by the mempool noop-miner (which keeps the mempool updated) in -- production setups. -- -data MinerResources logger tbl = MinerResources +data MinerResources logger = MinerResources { _minerResLogger :: !logger - , _minerResCutDb :: !(CutDb tbl) - , _minerChainResources :: !(HashMap ChainId (ChainResources logger)) + , _minerResCutDb :: !(CutDb logger) + , _minerChainResources :: !(ChainMap (ChainResources logger)) , _minerResConfig :: !NodeMiningConfig - , _minerResCoordination :: !(Maybe (MiningCoordination logger tbl)) + , _minerResCoordination :: !(Maybe (MiningCoordination logger)) -- ^ The primed work cache. This is Nothing when coordination is -- disabled. It is needed by the in-node test miner. The mempoolNoopMiner -- does not use it. @@ -299,10 +89,10 @@ data MinerResources logger tbl = MinerResources withMinerResources :: logger -> NodeMiningConfig - -> HashMap ChainId (ChainResources logger) - -> CutDb tbl - -> Maybe (MiningCoordination logger tbl) - -> (Maybe (MinerResources logger tbl) -> IO a) + -> ChainMap (ChainResources logger) + -> CutDb logger + -> Maybe (MiningCoordination logger) + -> (Maybe (MinerResources logger) -> IO a) -> IO a withMinerResources logger conf chainRes cutDb tpw inner = inner . Just $ MinerResources @@ -317,26 +107,31 @@ withMinerResources logger conf chainRes cutDb tpw inner = -- -- When mining coordination is disabled, this function exits with an error. -- +-- FIXME: is the above true? I think, the mempoolNoopMiner is important for +-- keeping the mempools up to date when mining coordination is disabled. +-- runMiner - :: forall logger tbl + :: forall logger . Logger logger - => CanReadablePayloadCas tbl - => ChainwebVersion - -> MinerResources logger tbl + => HasVersion + => MinerResources logger -> IO () -runMiner v mr +runMiner mr | enabled = case _minerResCoordination mr of Nothing -> error "Mining coordination must be enabled in order to use the in-node test miner" - Just coord -> case v ^. versionCheats . disablePow of + Just coord -> case implicitVersion ^. versionCheats . disablePow of True -> testMiner coord False -> powMiner coord - | otherwise = mempoolNoopMiner lf (_chainResMempool <$> _minerChainResources mr) + | otherwise = return () + -- FIXME: this is needed / possible only for pact chain + -- (and should be handled internally by pact service) + -- mempoolNoopMiner lf (_chainResMempool <$> _minerChainResources mr) where enabled = _nodeMiningEnabled $ _minerResConfig mr - cdb :: CutDb tbl + cdb :: CutDb logger cdb = _minerResCutDb mr conf :: NodeMiningConfig @@ -347,6 +142,6 @@ runMiner v mr testMiner coord = do gen <- MWC.createSystemRandom - localTest lf v coord (_nodeMiner conf) cdb gen (_nodeTestMiners conf) + localTest lf coord cdb gen (_nodeTestMiners conf) - powMiner coord = localPOW lf coord (_nodeMiner conf) cdb + powMiner coord = localPOW lf coord cdb diff --git a/src/Chainweb/Chainweb/PeerResources.hs b/src/Chainweb/Chainweb/PeerResources.hs index 242778728e..3acaff1ad9 100644 --- a/src/Chainweb/Chainweb/PeerResources.hs +++ b/src/Chainweb/Chainweb/PeerResources.hs @@ -122,16 +122,15 @@ makeLenses ''PeerResources -- withPeerResources :: Logger logger - => ChainwebVersion - -> P2pConfiguration + => HasVersion + => P2pConfiguration -> logger -> (logger -> PeerResources logger -> IO a) -> IO a -withPeerResources v conf logger inner = withPeerSocket conf $ \(conf', sock) -> do - withPeerDb_ v conf' $ \peerDb -> do +withPeerResources conf logger inner = withPeerSocket conf $ \(conf', sock) -> do + withPeerDb_ conf' $ \peerDb -> do (!mgr, !counter) <- connectionManager (conf ^. p2pDisableCertVerification) peerDb - withHost mgr v conf' logger $ \conf'' -> do - + withHost mgr conf' logger $ \conf'' -> do peer <- unsafeCreatePeer $ _p2pConfigPeer conf'' let pinf = _peerInfo peer @@ -152,7 +151,7 @@ withPeerResources v conf logger inner = withPeerSocket conf $ \(conf', sock) -> let peers = filter (((/=) `on` _peerAddr) pinf) $ _p2pConfigKnownPeers conf - checkReachability sock mgr v logger' localDb peers + checkReachability sock mgr logger' localDb peers peer (_p2pConfigBootstrapReachability conf'') @@ -170,24 +169,24 @@ withPeerResources v conf logger inner = withPeerSocket conf $ \(conf', sock) -> -- withHost :: Logger logger + => HasVersion => HTTP.Manager - -> ChainwebVersion -> P2pConfiguration -> logger -> (P2pConfiguration -> IO a) -> IO a -withHost mgr v conf logger f +withHost mgr conf logger f | null peers = do - logFunctionText logger Warn + logFunctionText logger Info $ "Unable to verify configured host " <> toText confHost <> ": No peers are available." f (set (p2pConfigPeer . peerConfigHost) confHost conf) | anyIpv4 == confHost = do - h <- getHost mgr v logger peers >>= \case + h <- getHost mgr logger peers >>= \case Right x -> return x Left e -> error $ "withHost failed: " <> T.unpack e f (set (p2pConfigPeer . peerConfigHost) h conf) | otherwise = do - getHost mgr v logger peers >>= \case + getHost mgr logger peers >>= \case Left e -> logFunctionText logger Warn $ "Failed to verify configured host " <> toText confHost <> ": " <> e @@ -204,14 +203,14 @@ withHost mgr v conf logger f getHost :: Logger logger + => HasVersion => HTTP.Manager - -> ChainwebVersion -> logger -> [PeerInfo] -> IO (Either T.Text Hostname) -getHost mgr ver logger peers = do +getHost mgr logger peers = do nis <- forConcurrently peers $ \p -> - tryAllSynchronous (requestRemoteNodeInfo mgr (_versionName ver) (_peerAddr p) Nothing) >>= \case + tryAllSynchronous (requestRemoteNodeInfo mgr (_versionName implicitVersion) (_peerAddr p) Nothing) >>= \case Right x -> Just x <$ do logFunctionText logger Info $ "got remote info from " <> toText (_peerAddr p) @@ -219,7 +218,7 @@ getHost mgr ver logger peers = do Left e -> Nothing <$ do logFunctionText logger Warn $ "failed to get remote info from " <> toText (_peerAddr p) - <> ": " <> sshow e + <> ": " <> T.pack (displayException e) -- TODO: use quorum here? Fitler out local network addresses? let hostnames = L.nub $ L.sort $ view remoteNodeInfoHostname <$> catMaybes nis @@ -232,7 +231,7 @@ getHost mgr ver logger peers = do -- Allocate Socket withPeerSocket :: P2pConfiguration -> ((P2pConfiguration, Socket) -> IO a) -> IO a -withPeerSocket conf act = withSocket port interface $ \(p, s) -> +withPeerSocket conf act = withSocket port interface $ \(p, s) -> do act (set (p2pConfigPeer . peerConfigPort) p conf, s) where port = _peerConfigPort $ _p2pConfigPeer conf @@ -241,16 +240,17 @@ withPeerSocket conf act = withSocket port interface $ \(p, s) -> -- -------------------------------------------------------------------------- -- -- Run PeerDb for a Chainweb Version -startPeerDb_ :: ChainwebVersion -> P2pConfiguration -> IO PeerDb -startPeerDb_ v = startPeerDb v nids +startPeerDb_ :: HasVersion => P2pConfiguration -> IO PeerDb +startPeerDb_ c = + startPeerDb nids (_p2pConfigPrivate c) (_p2pConfigKnownPeers c) where nids = HS.singleton CutNetwork `HS.union` HS.map MempoolNetwork cids `HS.union` HS.map ChainNetwork cids - cids = chainIds v + cids = chainIds -withPeerDb_ :: ChainwebVersion -> P2pConfiguration -> (PeerDb -> IO a) -> IO a -withPeerDb_ v conf = bracket (startPeerDb_ v conf) (stopPeerDb conf) +withPeerDb_ :: HasVersion => P2pConfiguration -> (PeerDb -> IO a) -> IO a +withPeerDb_ conf = bracket (startPeerDb_ conf) stopPeerDb -- -------------------------------------------------------------------------- -- -- Connection Manager @@ -367,6 +367,6 @@ withConnectionLogger logger counter inner = runLogClientConnections umask = do umask logClientConnections `catchAllSynchronous` \e -> do - logFunctionText logger Error ("Connection manager logger failed: " <> sshow e) + logFunctionText logger Error ("Connection manager logger failed: " <> T.pack (displayException e)) logFunctionText logger Info "Restarting connection manager logger" runLogClientConnections umask diff --git a/src/Chainweb/Chainweb/PruneChainDatabase.hs b/src/Chainweb/Chainweb/PruneChainDatabase.hs deleted file mode 100644 index 08963bef0e..0000000000 --- a/src/Chainweb/Chainweb/PruneChainDatabase.hs +++ /dev/null @@ -1,580 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} - --- | --- Module: Chainweb.Chainweb.PruneChainDatabase --- Copyright: Copyright © 2020 Kadena LLC. --- License: MIT --- Maintainer: Lars Kuhtz --- Stability: experimental --- --- There are four modes for pruning the database: --- --- * `none`: pruning is skipped --- * `headers`: only block headers of stale forks below are certain depth are --- pruned. The payload db is left unchanged. --- * `headers-checked`: like `headers` but block headers are also validated and --- the existence and consistency of the respective paylaods is checked. --- * `full`: like `headers` but additionally garbage collection is performed --- on payload database. --- --- The `headers-checked` mode does a verification of the complete Merkle tree of --- the chain. --- --- There is a block header database for each chain, but only a single shared --- payload database. Payloads or parts thereof can be shared between blocks --- on the same chain and on different chains. Therefore garbage collection is --- implemented as mark and sweep, using a probabilistic set representation --- for marking. --- --- This is an offline implementation. There must be no concurrent writes during --- database pruning. Although, if needed it could (relatively easily) be --- extended for online garbage collection. --- --- /Implementation:/ --- --- The algorithm is probabilistic. Some small percentage of unreachable data --- remains in the database. The datastructure for marking used entries is uses a --- random seed, such that repeated pruning will delete an increasing amount of --- items. --- --- For marking Cuckoo filters are used. Cuckoo filters have the disadvantage --- that they don't support concurrent insertion. Also merging cuckoo filters is --- slow. We use seperate filters for each chain and query them individually. We --- may explore other techniques to represent set membership in the future. --- --- The algorithm works top down on the hiearchical structure of the data. It --- guarantees that the database is consistent even if an exception occurs during --- a sweep phase. In that case some extra garbage would remain in the database, --- but there will be no dangling references. --- --- /NOTE: READ BEFORE MAKING A CHANGE TO THE ALGORITHM:/ --- --- For the algorithm to maintain database "deep" consistency (no dangling --- references) it is madatory that GC proceedes in stages. For instance, it is --- tempting to merge all marking phases into a single traversal of the --- BlockPaylaod store. However, due to the probabilistic nature of marking, some --- BlockPayloads are marked that are not reachable from a block header and will --- thus remain in the database. Hence, marking of the lower-level BlockOutputs --- and BlockTransactions must be based on what is /actually/ kept in the store --- and not just on what is reachable from a block header. --- --- /TODO:/ --- --- * implement incremental pruning (which can't be used with mark and sweep, --- though) --- --- * implement online garbage collection --- --- * Consider changing the database format to store the transactions with the --- block payloads and eliminate sharing. Sharing is benefitial only when most --- blocks are empty and the there's only a small number of pools. However, in --- that case storage requirements are moderate anyways. When most block --- contain transactions the benefits of sharing become marginal, but the --- saving during GC (in particular incremental GC) become larger. --- -module Chainweb.Chainweb.PruneChainDatabase -( PruningChecks(..) -, pruneAllChains -, fullGc -, DatabaseCheckException(..) -) where - -import Chainweb.BlockHeader - -import Control.Concurrent.Async -import Control.Lens (view) -import Control.Monad -import Control.Monad.Catch - -import Data.Aeson hiding (Error) -import qualified Data.ByteArray as BA -import qualified Data.ByteString as B -import Data.Cuckoo -import Data.Foldable - -import GHC.Generics - -import Numeric.Natural - -import qualified Streaming.Prelude as S - -import System.LogLevel -import System.Random - --- internal modules - -import Chainweb.BlockHash -import Chainweb.BlockHeader.Validation -import Chainweb.BlockHeaderDB -import Chainweb.BlockHeaderDB.PruneForks -import Chainweb.BlockHeight -import Chainweb.ChainValue -import Chainweb.Graph -import Chainweb.Logger -import Chainweb.Payload -import Chainweb.Payload.PayloadStore -import Chainweb.Payload.PayloadStore.RocksDB -import Chainweb.Time -import Chainweb.TreeDB -import Chainweb.Utils -import Chainweb.Version -import Chainweb.WebBlockHeaderDB - -import Chainweb.Storage.Table -import Chainweb.Storage.Table.RocksDB - -import Data.LogMessage - --- -------------------------------------------------------------------------- -- --- Fork Pruning - --- | Different consistency checks that can be piggybacked onto database pruning. --- --- The following runtimes were measured on a mac book pro at a block height of --- about 820,000: --- --- * `[]`: 10s --- * `[CheckInductive]`: 2min --- * `[CheckIntrinsic, CheckPayloadsExist]`: 4min --- * `[CheckFull, CheckPayloads]`: 8min --- * `[CheckFull, CheckPayloadsExist]`: 8min --- -data PruningChecks - = CheckIntrinsic - -- ^ Performs intrinsic validation on all block headers. - | CheckInductive - -- ^ Performs all intrinsic and inductive block header validations. - | CheckFull - -- ^ Performs full block header validation. This includes intrinsic, - -- inductive, and braiding validation. - | CheckPayloads - -- ^ checks that all payload components exist in the payload and can be - -- decoded and the Merkle Trees are consitent. - | CheckPayloadsExist - -- ^ only checks the existence of the payload hash in the - -- BlockPayloadStore, which is faster than fully checking payloads. - deriving (Show, Eq, Ord, Enum, Bounded) - --- | Prune all chains. This doesn't clean up Payloads. --- --- Note: this assumes that the payload db is already initialized, i.e. that --- genesis headers have been injected. --- -pruneAllChains - :: Logger logger - => logger - -> RocksDb - -> ChainwebVersion - -> [PruningChecks] - -> IO () -pruneAllChains logger rdb v checks = do - now <- getCurrentTimeIntegral - wdb <- initWebBlockHeaderDb rdb v - forConcurrently_ (toList $ chainIds v) (pruneChain now wdb) - where - diam = diameter $ chainGraphAt v (maxBound @BlockHeight) - pruneChain now wdb cid = do - let chainLogger = addLabel ("chain", toText cid) logger - chainLogg = logFunctionText chainLogger - cdb <- getWebBlockHeaderDb wdb cid - chainLogg Info "start pruning block header database" - x <- pruneForksLogg chainLogger cdb (1 + diam * 3) (callback now wdb cdb) - chainLogg Info $ "finished pruning block header database. Deleted " <> sshow x <> " block headers." - - pdb = newPayloadDb rdb - - callback now wdb cdb d h = mapM_ (\c -> run c d h) checks - where - run CheckIntrinsic = checkIntrinsic now - run CheckInductive = checkInductive now cdb - run CheckPayloadsExist = checkPayloadsExist pdb - run CheckPayloads = checkPayloads pdb - run CheckFull = checkFull now wdb - --- -------------------------------------------------------------------------- -- --- Fork Pruning callbacks - -data DatabaseCheckException - = MissingPayloadException BlockHeader - | InconsistentPaylaod BlockHeader PayloadWithOutputs - deriving (Show, Generic) - -instance Exception DatabaseCheckException - --- | Verify existance and consistency of payloads for all block headers that are --- not deleted. --- --- Adds about 4 minutes of overhead at block height 800,000 on a mac bock pro. --- -checkPayloads :: PayloadDb RocksDbTable -> Bool -> BlockHeader -> IO () -checkPayloads _ True _ = return () -checkPayloads pdb False h = lookupPayloadWithHeight pdb (Just $ view blockHeight h) (view blockPayloadHash h) >>= \case - Just p - | verifyPayloadWithOutputs p -> return () - | otherwise -> throwM $ InconsistentPaylaod h p - Nothing -> throwM $ MissingPayloadException h -{-# INLINE checkPayloads #-} - --- | Just check the existence of the Payload in the Database but don't check --- that it can actually be decoded and is consistent. --- --- This is faster than 'checkPayload' because only the top-level 'PayloadData' --- structure is queried -- and immediately discarded. --- -checkPayloadsExist :: PayloadDb RocksDbTable -> Bool -> BlockHeader -> IO () -checkPayloadsExist _ True _ = return () -checkPayloadsExist pdb False h = do - lookupPayloadDataWithHeight pdb (Just $ view blockHeight h) (view blockPayloadHash h) >>= \case - Just _ -> return () - Nothing -> throwM $ MissingPayloadException h -{-# INLINE checkPayloadsExist #-} - --- | Intrinsically validate all block headers that are not deleted. --- --- Adds less than 1 minute of overhead at block height 800,000 on a mac bock pro. --- -checkIntrinsic :: Time Micros -> Bool -> BlockHeader -> IO () -checkIntrinsic _ True _ = return () -checkIntrinsic now False h = validateIntrinsicM now h -{-# INLINE checkIntrinsic #-} - --- | Intrinsically validate all block headers that are not deleted. --- -checkInductive :: Time Micros -> BlockHeaderDb -> Bool -> BlockHeader -> IO () -checkInductive _ _ True _ = return () -checkInductive now cdb False h = do - validateInductiveChainM (tableLookup cdb) h - validateIntrinsicM now h -{-# INLINE checkInductive #-} - --- | Perform complete block header validation for all block that are not deleted. --- --- Adds about 5 minutes of overhead at block height 800,000 on a mac book pro --- -checkFull :: Time Micros -> WebBlockHeaderDb -> Bool -> BlockHeader -> IO () -checkFull _ _ True = const $ return () -checkFull now wdb False = void . validateBlockHeaderM now ctx - where - ctx :: ChainValue BlockHash -> IO (Maybe BlockHeader) - ctx cv = fmap _chainValueValue <$> tableLookup wdb cv -{-# INLINE checkFull #-} - --- -------------------------------------------------------------------------- -- --- Full GC - --- | Prune all chains and clean up payloads. --- --- Note: this assumes that the payload db is already initialized, i.e. that --- genesis headers have been injected. --- -fullGc - :: Logger logger - => logger - -> RocksDb - -> ChainwebVersion - -> IO () -fullGc logger rdb v = do - logg Info $ "Starting chain database garbage collection" - - -- 1. Concurrently prune chain dbs (TODO use a pool to limit concurrency) - markedPayloads <- forConcurrently (toList $ chainIds v) pruneChain - logg Info $ "Finished pruning block headers" - - -- TODO: parallelize he the sweep payload phase to use all available cores. - - -- Sweep Payloads and mark transactions - (markedTrans, markedOutputs) <- sweepPayloads logg db markedPayloads - - -- Sweep transactions - -- (these are reasonably fast, prossibly because they only iterate over the keys) - concurrently_ - (sweepTransactions logg db markedTrans) - (sweepOutputs logg db markedOutputs) - - logg Info $ "Finished chain database garbage collection" - - where - logg = logFunctionText logger - diam = diameter $ chainGraphAt v (maxBound @BlockHeight) - depth = diam * 3 - - db = newPayloadDb rdb - - -- Prune a single chain and return the sets of marked payloads - -- - pruneChain cid = withBlockHeaderDb rdb v cid $ \cdb -> do - let chainLogger = addLabel ("chain", toText cid) logger - chainLogg = logFunctionText chainLogger - - m <- maxRank cdb - markedPayloads <- mkFilter (round $ (1024 + int @_ @Double m) * 1.1) - - chainLogg Info $ "Allocated " - <> sshow (sizeInAllocatedBytes markedPayloads `div` (1024 * 1024)) - <> "MB for marking database entries" - - -- Mark all entries down to the requested depth, so they don't get GCed - -- - -- Blocks at (maxRank - depth) are used as pivots and pruning and marking starts at - -- (depth - 1) - -- - let keptBound = MinRank $ int $ m - min m depth - void $ entries cdb Nothing Nothing (Just keptBound) Nothing - $ S.mapM_ (markPayload markedPayloads) - - chainLogg Info "start pruning block header database" - x <- pruneForksLogg chainLogger cdb depth $ \isDeleted hdr -> case isDeleted of - True -> chainLogg Debug - $ "pruned header " <> toText (view blockHash hdr) - <> " at height " <> sshow (view blockHeight hdr) - False -> markPayload markedPayloads hdr - - chainLogg Info $ "finished pruning block header database. Deleted " <> sshow x <> " block headers." - return markedPayloads - --- -------------------------------------------------------------------------- -- --- Payload Mark and Sweep - --- | Mark Payloads of non-deleted block headers. --- -markPayload :: Filter BlockPayloadHash -> BlockHeader -> IO () -markPayload f = tryInsert f "payload hash" . view blockPayloadHash -{-# INLINE markPayload #-} - --- | Mark Payload Transactions --- -markTransactions :: Filter BlockTransactionsHash -> BlockPayload -> IO () -markTransactions f - = tryInsert f "transactions hash" . _blockPayloadTransactionsHash -{-# INLINE markTransactions #-} - --- | Mark Payload Outputs --- -markOutputs :: Filter BlockOutputsHash -> BlockPayload -> IO () -markOutputs f - = tryInsert f "outputs hash" . _blockPayloadOutputsHash -{-# INLINE markOutputs #-} - --- | Sweep payload and mark all transactions that are kept --- -sweepPayloads - :: LogFunctionText - -> PayloadDb RocksDbTable - -> [Filter BlockPayloadHash] - -> IO (Filter BlockTransactionsHash, Filter BlockOutputsHash) -sweepPayloads logg db markedPayloads = do - logg Info "Sweeping BlockPayloads" - - -- create filter with sufficient capacity - m <- sum <$> mapM itemCount markedPayloads - markedTrans <- mkFilter (round $ int @_ @Double m * 1.1) - - logg Info $ "Allocated " - <> sshow (sizeInAllocatedBytes markedTrans `div` (1024 * 1024)) - <> "MB for marking transaction hashes entries" - - markedOutputs <- mkFilter (round $ int @_ @Double m * 1.1) - logg Info $ "Allocated " - <> sshow (sizeInAllocatedBytes markedOutputs `div` (1024 * 1024)) - <> "MB for marking outputs hashes entries" - - -- traverse all payloads, both old and new tables - c0 <- withTableIterator newPayloadsTable - $ S.sum_ @_ @Int . S.mapM (go markedTrans markedOutputs) . iterToValueStream - logg Info $ "Swept entries for " <> sshow c0 <> " NEW block payload hashes" - - c1 <- withTableIterator oldPayloadsTable - $ S.sum_ @_ @Int . S.mapM (go markedTrans markedOutputs) . iterToValueStream - logg Info $ "Swept entries for " <> sshow c1 <> " OLD block payload hashes" - - return (markedTrans, markedOutputs) - where - go mt mo x = checkMark markedPayloads (_blockPayloadPayloadHash x) >>= \case - True -> 0 <$ markTransactions mt x <* markOutputs mo x - False -> 1 <$ deleteBlockPayload logg db x - - -- Extract RocksDB Tables from Payload Db - newPayloadsTable :: RocksDbTable (BlockHeight, BlockPayloadHash) BlockPayload - newPayloadsTable = _newTransactionDbBlockPayloadsTbl $ _transactionDb db - - oldPayloadsTable :: RocksDbTable BlockPayloadHash BlockPayload - oldPayloadsTable = unCasify (_oldTransactionDbBlockPayloadsTbl $ _transactionDb db) - --- | Sweep Transations --- -sweepTransactions - :: LogFunctionText - -> PayloadDb RocksDbTable - -> Filter BlockTransactionsHash - -> IO () -sweepTransactions logg db marked = do - logg Info "Sweeping BlockTransactions" - c1 <- withTableIterator (_newTransactionDbBlockTransactionsTbl $ _transactionDb db) $ - S.sum_ @_ @Int . S.mapM (\(bh, hsh) -> go (Just bh, hsh)) . iterToKeyStream - logg Info $ "Swept " <> sshow c1 <> " block transactions hashes (new table)" - c2 <- withTableIterator (_oldTransactionDbBlockTransactionsTbl $ _transactionDb db) $ - S.sum_ @_ @Int . S.mapM (\hsh -> go (Nothing, hsh)) . iterToKeyStream - logg Info $ "Swept " <> sshow c2 <> " block transactions hashes (old table)" - where - go (h, x) = member marked (GcHash x) >>= \case - True -> return 0 - False -> 1 <$ deleteBlockTransactions logg db h x - --- | Sweep Outputs --- -sweepOutputs - :: LogFunctionText - -> PayloadDb RocksDbTable - -> Filter BlockOutputsHash - -> IO () -sweepOutputs logg db marked = do - logg Info "Sweeping BlockOutputss" - c1 <- withTableIterator (_newBlockOutputsTbl $ _payloadCacheBlockOutputs $ _payloadCache db) $ - S.sum_ @_ @Int . S.mapM (\(bh, hsh) -> go (Just bh, hsh)) . iterToKeyStream - logg Info $ "Swept " <> sshow c1 <> " block output hashes (new table)" - c2 <- withTableIterator (_oldBlockOutputsTbl $ _payloadCacheBlockOutputs $ _payloadCache db) $ - S.sum_ @_ @Int . S.mapM (curry go Nothing) . iterToKeyStream - logg Info $ "Swept " <> sshow c2 <> " block output hashes (new table)" - where - go (h, x) = member marked (GcHash x) >>= \case - True -> return 0 - False -> 1 <$ deleteBlockOutputs logg db h x - --- -------------------------------------------------------------------------- -- --- Utils for Mark and sweep GC for Payloads --- - --- | Wraps a MerkleLogHash for usage with a Cuckoo filter. --- -newtype GcHash a = GcHash a - deriving newtype (Show, ToJSON) - -instance BA.ByteArrayAccess a => CuckooFilterHash (GcHash a) where - cuckooHash (Salt s) (GcHash a) = - saltedFnv1aByteString s (B.take 8 $ BA.convert a) - cuckooFingerprint (Salt s) (GcHash a) = - saltedSipHashByteString s (B.take 8 $ BA.convert a) - {-# INLINE cuckooHash #-} - {-# INLINE cuckooFingerprint #-} - -type Filter a = CuckooFilterIO 4 10 (GcHash a) - -mkFilter :: Natural -> IO (Filter a) -mkFilter n = do - s <- randomIO - newCuckooFilter (Salt s) $ max 128 n - --- | inserting a somewhat larger number (I think, it's actually 7) of --- equal elements causes the filter to fail. --- -tryInsert :: BA.ByteArrayAccess a => Filter a -> [Char] -> a -> IO () -tryInsert cf k a = unlessM (member cf $ GcHash a) $ - unlessM (insert cf $ GcHash a) $ error - $ "failed to insert item " <> k <> " in cuckoo filter" - <> ": while very rare this can happen. Usually it is resolve by retrying." -{-# INLINE tryInsert #-} - --- TODO: consider using bloom fiters instead that can be merged. Alternatively, --- implement concurrent insertion for cuckoo filters, where the hashing is done --- concurrently and a lock is used only for the actual modification of the --- underlying buffer. Or do fine grained locking on the filter. --- -checkMark :: BA.ByteArrayAccess a => [Filter a] -> a -> IO Bool -checkMark fs a = go fs - where - go [] = return False - go (h : t) = member h (GcHash a) >>= \case - True -> return True - False -> go t - {-# INLINE go #-} - --- -------------------------------------------------------------------------- -- --- Delete Payload --- --- Payload Components are deleted in a way such that it is guaranteed that there --- are no dangling references. --- --- /Tables:/ --- --- BlockPayloadStore - BlockPayload: --- *BlockPayloadHash, BlockTransactionsHash, BlockOutputsHash --- --- BlockTransactionStore - BlockTransactions: --- *BlockTransactionsHash, Vector Transactions, MinerData --- --- BlockOutputsStore - BlockOutputs: --- *BlockOutputsHash, Vector TransactionOutput, CoinbaseOutput --- --- TransactionTreeStore - TransactionTree: --- *BlockTransactionsHash, MerkleTree --- --- OutputTreeStore - OutputTree --- *BlockOutputsHash, MerkleTree --- - --- | delete BlockPayload --- -deleteBlockPayload - :: CanPayloadCas tbl - => LogFunctionText - -> PayloadDb tbl - -> BlockPayload - -> IO () -deleteBlockPayload logg db p = do - logg Debug $ "Delete PayloadHash for " <> encodeToText (_blockPayloadPayloadHash p) - deletePayload db p - --- | Delete BlockOutputs and OutputTree --- -deleteBlockOutputs - :: CanPayloadCas tbl - => LogFunctionText - -> PayloadDb tbl - -> Maybe BlockHeight - -> BlockOutputsHash - -> IO () -deleteBlockOutputs logg db mh p = do - logg Debug $ "Delete BlockOutputs for " <> encodeToText p - case mh of - Just h -> do - flip tableDelete (h, p) $ - _newOutputTreeStoreTbl $ _payloadCacheOutputTrees $ _payloadCache db - flip tableDelete (h, p) $ - _newBlockOutputsTbl $ _payloadCacheBlockOutputs $ _payloadCache db - Nothing -> do - flip tableDelete p $ - _oldOutputTreeStoreTbl $ _payloadCacheOutputTrees $ _payloadCache db - flip tableDelete p $ - _oldBlockOutputsTbl $ _payloadCacheBlockOutputs $ _payloadCache db - --- | Delete BlockTransactions and TransactionsTree --- -deleteBlockTransactions - :: CanPayloadCas tbl - => LogFunctionText - -> PayloadDb tbl - -> Maybe BlockHeight - -> BlockTransactionsHash - -> IO () -deleteBlockTransactions logg db mh p = do - logg Debug $ "Delete BlockTransactions for " <> encodeToText p - case mh of - Just h -> do - flip tableDelete (h, p) $ - _newTransactionDbBlockTransactionsTbl $ _transactionDb db - flip tableDelete (h, p) $ - _newTransactionTreeStoreTbl $ _payloadCacheTransactionTrees $ _payloadCache db - Nothing -> do - flip tableDelete p $ - _oldTransactionDbBlockTransactionsTbl $ _transactionDb db - flip tableDelete p $ - _oldTransactionTreeStoreTbl $ _payloadCacheTransactionTrees $ _payloadCache db diff --git a/src/Chainweb/Core/Brief.hs b/src/Chainweb/Core/Brief.hs new file mode 100644 index 0000000000..66448c5773 --- /dev/null +++ b/src/Chainweb/Core/Brief.hs @@ -0,0 +1,198 @@ +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE UndecidableInstances #-} + +-- | +-- Module: Chainweb.Core.Brief +-- Copyright: Copyright © 2025 Kadena LLC. +-- License: MIT +-- Maintainer: Lars Kuhtz +-- Stability: experimental +-- +module Chainweb.Core.Brief +( Brief(..) +, toTextShort + +-- * Utils +, briefJson +, BriefJson +, briefValue +) where + +import Chainweb.BlockHash +import Chainweb.BlockHeader +import Chainweb.BlockHeight +import Chainweb.ChainId +import Chainweb.Core.CryptoHash +import Chainweb.Cut +import Chainweb.Cut.CutHashes +import Chainweb.Parent +import Chainweb.PayloadProvider +import Chainweb.Ranked +import Chainweb.Utils +import Control.Lens +import Data.Aeson +import Data.ByteString qualified as B +import Data.ByteString.Short qualified as BS +import Data.Coerce +import Data.Hash.Class.Mutable +import Data.Hash.SHA2 (Sha2_512_256(..) {- Coercible AdjacentsHashAlgorithm BS.ShortByteString -}) +import Data.Foldable +import Data.HashMap.Strict qualified as HM +import Data.List qualified as L +import Data.List.NonEmpty (NonEmpty) +import Data.Text qualified as T +import Numeric.Natural +import Data.These + +-- -------------------------------------------------------------------------- -- +-- Adhoc class for brief logging output + +class Brief a where + brief :: a -> T.Text + +toTextShort :: HasTextRepresentation a => a -> T.Text +toTextShort = T.take 6 . toText + +-- -------------------------------------------------------------------------- -- +-- Generic Instances + +instance (Brief a, Brief b) => Brief (a,b) where + brief (a,b) = "(" <> brief a <> "," <> brief b <> ")" + +instance (Brief a, Brief b, Brief c) => Brief (a,b,c) where + brief (a,b,c) = "(" <> brief a <> "," <> brief b <> "," <> brief c <> ")" + +instance (Brief a, Brief b) => Brief (Either a b) where + brief (Left a) = "left:" <> brief a + brief (Right b) = "right:" <> brief b + +instance (Brief a, Brief b) => Brief (These a b) where + brief (This a) = "this:" <> brief a + brief (That b) = "that:" <> brief b + brief (These a b) = "these:(" <> brief a <> "):(" <> brief b <> ")" + +instance Brief a => Brief (Maybe a) where + brief (Just a) = brief a + brief Nothing = "nothing" + +instance Brief a => Brief [a] where + brief l + | length l < 50 = mconcat ["[", T.intercalate "," (brief <$> l), "]"] + | otherwise = mconcat + [ "[" + , T.intercalate "," (brief <$> take 20 l) + , " ... " + , T.intercalate "," (brief <$> drop (length l - 20) l) + , "]" + ] + +instance Brief Int where + brief = sshow + +instance Brief a => Brief (NonEmpty a) where + brief = brief . toList + +instance Brief a => Brief (Parent a) where + brief = brief . unwrapParent + +-- -------------------------------------------------------------------------- -- +-- Core Chainweb Types + +instance Brief a => Brief (Ranked a) where + brief (Ranked r h) = sshow r <> ":" <> brief h + +instance Brief CutHeight where brief = toText . int @_ @Natural +instance Brief BlockHeight where brief = toText . int @_ @Natural +instance Brief CutId where brief = toTextShort +instance Brief ChainId where brief = toText +instance Brief BlockHash where brief = toTextShort +instance Brief BlockPayloadHash where brief = toTextShort +instance Brief BlockHeader where + brief bh = + brief (view chainId bh) <> "@" + <> brief (view blockHeight bh) + <> "." <> brief (view blockHash bh) +instance Brief (Parent BlockHeader) where brief = brief . unwrapParent +deriving + via (CryptoHash AdjacentsHashAlgorithm) + instance Brief AdjacentsHash +instance Brief ConsensusPayload where + brief = brief . _consensusPayloadHash +instance Brief p => Brief (EvaluationCtx p) where + brief ec = + "payload:" <> brief (_evaluationCtxPayload ec) + <> "/parent:" <> brief (_evaluationCtxRankedParentHash ec) + +deriving + via (BriefText (CryptoHash a)) + instance (IncrementalHash a, Coercible a BS.ShortByteString) => Brief (CryptoHash a) + +instance Brief CutHashes where + brief c = brief (_cutHashesHeight c) + <> "." <> brief (_cutHashesId c) + <> ":" <> brief (L.sort $ HM.toList $ _cutHashes c) + +instance Brief Cut where + brief = brief . cutToCutHashes Nothing + +instance Brief NewPayload where + brief np = brief (_newPayloadChainId np) + <> "@" <> brief (_newPayloadRankedParentHash np) + +instance Brief SyncState where + brief ss = brief (_syncStateHeight ss) + <> "." <> brief (_syncStateBlockHash ss) + <> "." <> brief (_syncStateBlockPayloadHash ss) + +instance Brief ConsensusState where + brief cs = + "{ \"latest\": \"" <> brief (_consensusStateLatest cs) + <> "\", \"safe\": \"" <> brief (_consensusStateSafe cs) + <> "\", \"final\": \"" <> brief (_consensusStateFinal cs) + <> "\" }" + +-- -------------------------------------------------------------------------- -- +-- Utils + +newtype BriefJson a = BriefJson a + +instance ToJSON a => ToJSON (BriefJson a) where + toJSON (BriefJson a) = briefValue $ toJSON a + +briefJson :: ToJSON a => a -> T.Text +briefJson = encodeToText . BriefJson + +briefValue :: Value -> Value +briefValue (Object o) = Object (briefValue <$> o) +briefValue (Array a) = Array (briefValue <$> a) +briefValue (String t) = String (toTextShort t) +briefValue n = n + +-- -------------------------------------------------------------------------- -- +-- Tools for Deriving Via + +newtype ShowBrief a = ShowBrief a +instance Show a => Brief (ShowBrief a) where + brief (ShowBrief a) = T.take 6 $ T.pack $ show a + +newtype BriefBase64ByteString = BriefBase64ByteString B.ByteString +instance Brief BriefBase64ByteString where + brief (BriefBase64ByteString bytes) = T.take 6 + $ encodeB64UrlNoPaddingText bytes + +newtype BriefBase64ShortByteString = BriefBase64ShortByteString BS.ShortByteString +instance Brief BriefBase64ShortByteString where + brief (BriefBase64ShortByteString bytes) = T.take 6 + $ encodeB64UrlNoPaddingText + $ BS.fromShort bytes + +newtype BriefText a = BriefText a +instance HasTextRepresentation a => Brief (BriefText a) where + brief (BriefText t) = toTextShort t + diff --git a/src/Chainweb/Core/CryptoHash.hs b/src/Chainweb/Core/CryptoHash.hs new file mode 100644 index 0000000000..fd3fc4d320 --- /dev/null +++ b/src/Chainweb/Core/CryptoHash.hs @@ -0,0 +1,135 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} + +-- | +-- Module: Chainweb.Core.CryptoHash +-- Copyright: Copyright © 2025 Kadena LLC. +-- License: MIT +-- Maintainer: Lars Kuhtz +-- Stability: experimental +-- +-- Base type for cryptographic hashes in Chainweb +-- +module Chainweb.Core.CryptoHash +( CryptoHash(..) +, unsafeMkCryptoHash +, encodeCryptoHash +, decodeCryptoHash +, cryptoHashBytes +, cryptoHashToText +, cryptoHashFromText +) where + +import Data.ByteString.Short qualified as BS +import Chainweb.Utils +import Chainweb.Utils.Serialization +import Control.DeepSeq (NFData, rnf) +import Control.Monad.Catch +import Data.Aeson +import Data.ByteString qualified as B +import Data.Coerce +import Data.Hash.Class.Mutable +import Data.Hashable (Hashable(..)) +import Data.String (IsString) +import Data.Text qualified as T +import GHC.Exts (Int(I#), indexIntArray#) +import GHC.Generics (Generic) +import GHC.Stack + +-- ----------------------------------------------------------------------------- +-- | Base Type for Cryptographic Hashes in Chainweb. +-- +-- This is mostly useful for use with deriving Via. +-- +-- It also provides a few convenience functions for working with cryptographic +-- hashes. +-- +newtype CryptoHash a = CryptoHash a + deriving (Show, Generic) + deriving newtype (Eq, Ord, IncrementalHash, Hash, ResetableHash, IsString) + +unsafeMkCryptoHash + :: HasCallStack + => Coercible a BS.ShortByteString + => IncrementalHash a + => B.ByteString + -> CryptoHash a +unsafeMkCryptoHash = fromJuste . runGetS decodeCryptoHash +{-# INLINE unsafeMkCryptoHash #-} + +encodeCryptoHash :: Coercible a BS.ShortByteString => CryptoHash a -> Put +encodeCryptoHash (CryptoHash w) = putByteString $ BS.fromShort $ coerce w +{-# INLINE encodeCryptoHash #-} + +cryptoHashBytes + :: Coercible a BS.ShortByteString + => CryptoHash a + -> BS.ShortByteString +cryptoHashBytes = coerce +{-# INLINE cryptoHashBytes #-} + +decodeCryptoHash + :: forall a + . Coercible a BS.ShortByteString + => IncrementalHash a + => Get (CryptoHash a) +decodeCryptoHash = coerce . BS.toShort + <$> getByteString (digestSize @(CryptoHash a)) +{-# INLINE decodeCryptoHash #-} + +cryptoHashToText + :: Coercible a BS.ShortByteString + => CryptoHash a + -> T.Text +cryptoHashToText = encodeB64UrlNoPaddingText . runPutS . encodeCryptoHash +{-# INLINE cryptoHashToText #-} + +cryptoHashFromText + :: Coercible a BS.ShortByteString + => IncrementalHash a + => MonadThrow m + => T.Text + -> m (CryptoHash a) +cryptoHashFromText t = either (throwM . TextFormatException . sshow) return + $ runGetS decodeCryptoHash =<< decodeB64UrlNoPaddingText t +{-# INLINE cryptoHashFromText #-} + +instance Coercible a BS.ShortByteString => NFData (CryptoHash a) where + rnf = rnf . cryptoHashBytes + {-# INLINE rnf #-} + +instance (Coercible a BS.ShortByteString, Eq a) => Hashable (CryptoHash a) where + -- CryptoHashs are already cryptographically strong hashes + -- that include the chain id. + hashWithSalt s h = + hashWithSalt s $ I# $ indexIntArray# arr# 0# + where + !(BS.SBS arr#) = coerce h + {-# INLINE hashWithSalt #-} + +instance Coercible a BS.ShortByteString => ToJSON (CryptoHash a) where + toJSON = toJSON . encodeB64UrlNoPaddingText . runPutS . encodeCryptoHash + toEncoding = b64UrlNoPaddingTextEncoding . runPutS . encodeCryptoHash + {-# INLINE toJSON #-} + {-# INLINE toEncoding #-} + +instance (Coercible a BS.ShortByteString, IncrementalHash a) => FromJSON (CryptoHash a) where + parseJSON = withText "CryptoHash" $ \t -> + either (fail . show) return + $ runGetS decodeCryptoHash =<< decodeB64UrlNoPaddingText t + {-# INLINE parseJSON #-} + +instance (IncrementalHash a, Coercible a BS.ShortByteString) => HasTextRepresentation (CryptoHash a) where + toText = encodeB64UrlNoPaddingText . runPutS . encodeCryptoHash + fromText = fmap unsafeMkCryptoHash . decodeB64UrlNoPaddingText + {-# INLINE toText #-} + {-# INLINE fromText #-} + diff --git a/src/Chainweb/Crypto/MerkleLog.hs b/src/Chainweb/Crypto/MerkleLog.hs index ea160f0b80..f485c62d26 100644 --- a/src/Chainweb/Crypto/MerkleLog.hs +++ b/src/Chainweb/Crypto/MerkleLog.hs @@ -6,6 +6,7 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE GADTs #-} +{-# LANGUAGE ImportQualifiedPost #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE RankNTypes #-} @@ -15,6 +16,7 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE TypeFamilyDependencies #-} -- | -- Module: Chainweb.Crypto.MerkleLog @@ -114,9 +116,11 @@ module Chainweb.Crypto.MerkleLog , mapLogEntries , entriesHeaderSize , entriesBody +, fromMerkleNodeM -- * Merkle Log , MerkleLog(..) +, _merkleLogTree , HasMerkleLog(..) , MkLogType , merkleLog @@ -129,13 +133,16 @@ module Chainweb.Crypto.MerkleLog , computeMerkleLogRoot -- * Merkle Log Proofs -, headerProof +, headerProofV1 +, headerProofV2 , headerTree , headerTree_ -, bodyProof +, bodyProofV1 +, bodyProofV2 , bodyTree , bodyTree_ , proofSubject +, proofClaim -- * Utils for Defining Instances , decodeMerkleInputNode @@ -145,12 +152,7 @@ module Chainweb.Crypto.MerkleLog , encodeMerkleTreeNode -- ** IsMerkleLogEntry instance for use with @deriving via@ -, ByteArrayMerkleLogEntry(..) , MerkleRootLogEntry(..) -, Word8MerkleLogEntry(..) -, Word16BeMerkleLogEntry(..) -, Word32BeMerkleLogEntry(..) -, Word64BeMerkleLogEntry(..) -- * Exceptions , MerkleLogException(..) @@ -160,27 +162,24 @@ module Chainweb.Crypto.MerkleLog import Control.Monad.Catch -import Crypto.Hash.Algorithms - -import qualified Data.ByteArray as BA -import qualified Data.ByteString as B +import Data.ByteString qualified as B +import Data.ByteString.Builder qualified as BB import Data.Coerce import Data.Foldable import Data.Kind -import Data.Memory.Endian -import qualified Data.Memory.Endian as BA import Data.MerkleLog hiding (Expected, Actual) +import Data.MerkleLog.V1 qualified as V1 import Data.Proxy -import qualified Data.Text as T -import qualified Data.Vector as V +import Data.Text qualified as T +import Data.Vector qualified as V import Data.Word +import Data.Hash.SHA2 +import Data.Hash.Keccak import Foreign.Storable import GHC.TypeNats -import System.IO.Unsafe - -- internal modules import Data.Singletons @@ -211,23 +210,16 @@ expectedTreeNodeException = MerkleLogWrongNodeTypeException -- -------------------------------------------------------------------------- -- -- Internal Utils -fromWordBE :: forall w b . BA.ByteArray b => ByteSwap w => w -> b -fromWordBE w = BA.allocAndFreeze (sizeOf (undefined :: w)) $ \ptr -> poke ptr (BA.toBE w) - -unsafeToWordBE :: BA.ByteSwap w => BA.ByteArrayAccess b => b -> w -unsafeToWordBE bytes = BA.fromBE . unsafeDupablePerformIO $ BA.withByteArray bytes peek - toWordBE - :: forall w b m + :: forall w m . MonadThrow m - => BA.ByteSwap w - => BA.ByteArrayAccess b - => b + => ByteSwap w + => Storable w + => B.ByteString -> m w -toWordBE bytes - | BA.length bytes < sizeOf (undefined :: w) = throwM - $ MerkleLogDecodeException "failed to parse Word from bytes: not enough bytes" - | otherwise = return $! unsafeToWordBE bytes +toWordBE bs = case peekByteString bs of + Left e -> throwM $ MerkleLogDecodeException e + Right x -> return $ be x -- -------------------------------------------------------------------------- -- -- $inputs @@ -277,7 +269,7 @@ toWordBE bytes -- universe a type-level 'Nat' that represents a 'Word16' value. -- class MerkleUniverse k where - type MerkleTagVal k (a :: k) :: Nat + type MerkleTagVal k (a :: k) = (g :: Nat) | g -> a -- | Term level representation of the 'MerkleTagVal' of a type in a Merkle -- universe. @@ -288,16 +280,14 @@ tagVal = fromIntegral $ natVal (Proxy @(MerkleTagVal u t)) -- -------------------------------------------------------------------------- -- -- Hash Algorithms -type MerkleHashAlgorithm = HashAlgorithm - class MerkleHashAlgorithmName a where merkleHashAlgorithmName :: T.Text -instance MerkleHashAlgorithmName SHA512t_256 where +instance MerkleHashAlgorithmName Sha2_512_256 where merkleHashAlgorithmName = "SHA512t_256" {-# INLINE merkleHashAlgorithmName #-} -instance MerkleHashAlgorithmName Keccak_256 where +instance MerkleHashAlgorithmName Keccak256 where merkleHashAlgorithmName = "Keccak_256" {-# INLINE merkleHashAlgorithmName #-} @@ -318,21 +308,27 @@ type InUniverse u (t :: u) = (MerkleUniverse u, KnownNat (MerkleTagVal u t)) -- root of a nested Merkle tree or corresponds to an input node. -- class (MerkleHashAlgorithm a, InUniverse u (Tag b)) => IsMerkleLogEntry a u b | b -> u where + + -- | Morralay, this type family is injective. Please, see the comment on + -- the ChainwebHashTag type for details. + -- + -- We don't enforce this here to keep the type machinary simple. + -- type Tag b :: u toMerkleNode :: b - -> MerkleNodeType a B.ByteString + -> MerkleNodeType a fromMerkleNode - :: MerkleNodeType a B.ByteString + :: MerkleNodeType a -> Either SomeException b fromMerkleNodeM :: forall a u b m . MonadThrow m => IsMerkleLogEntry a u b - => MerkleNodeType a B.ByteString + => MerkleNodeType a -> m b fromMerkleNodeM = either throwM return . fromMerkleNode @a {-# INLINE fromMerkleNodeM #-} @@ -345,7 +341,7 @@ fromMerkleNodeM = either throwM return . fromMerkleNode @a -- * a fixed size polymorphic list of header values and -- * a monomorphic sequence of body values. -- --- Both the header and the body may possibly be empty. The type of the former is + -- Both the header and the body may possibly be empty. The type of the former is -- represented by an empty type-level list, while the latter is represented by -- 'Void'. -- @@ -420,15 +416,24 @@ data MerkleLog a u (h :: [Type]) (b :: Type) = MerkleLog -- Note: For creating proofs this isn't needed. Should we make this -- lazy, too? For large entries it may be somewhat costly to pull it -- from the store. - - , _merkleLogTree :: {- Lazy -} MerkleTree a - -- ^ The merkle tree for the entries of the log. It is required to - -- compute the root and for creating a merkle proofs. - -- - -- For some types, computing the merkle tree can be expensive. Therefore - -- it is instantiated lazily and only forced if actually required. } +_merkleLogTree + :: forall a u h b + . MerkleHashAlgorithm a + => MerkleLog a u h b + -> V1.MerkleTree a +_merkleLogTree = V1.merkleTree . _merkleLogLeafs + +_merkleLogLeafs + :: forall a u h b + . MerkleHashAlgorithm a + => MerkleLog a u h b + -> [MerkleNodeType a] +_merkleLogLeafs = toList + . mapLogEntries (toMerkleNodeTagged @a) + . _merkleLogEntries + -- | Class of types which can be represented as a Merkle tree log. -- -- An instance of 'HasMerkleLog' can be encoded as @@ -459,10 +464,9 @@ class (MerkleUniverse u, MerkleHashAlgorithm a) => HasMerkleLog a u b | b -> u w type MkLogType a u b = MerkleLog a u (MerkleLogHeader b) (MerkleLogBody b) -- | Create a 'MerkleLog' from a 'MerkleRoot' and a sequence of 'MerkleLogEntry's. --- The '_merkleLogTree' fields is instantiated lazily. -- merkleLog - :: forall a u h b + :: forall (a :: Type) u h b . MerkleHashAlgorithm a => MerkleRoot a -> MerkleLogEntries a u h b @@ -470,22 +474,19 @@ merkleLog merkleLog root entries = MerkleLog { _merkleLogRoot = root , _merkleLogEntries = entries - , _merkleLogTree = {- Lazy -} merkleTree - $ toList - $ mapLogEntries (toMerkleNodeTagged @a) entries } --- | /Internal:/ Create a representation Merkle nodes that are tagged with the --- respedtive type from the Merkle universe. +-- | /Internal:/ Create a representation of Merkle nodes that are tagged with the +-- respective type from the Merkle universe. -- toMerkleNodeTagged :: forall a u b . IsMerkleLogEntry a u b => b - -> MerkleNodeType a B.ByteString + -> MerkleNodeType a toMerkleNodeTagged b = case toMerkleNode @a @u @b b of - InputNode bytes -> InputNode @a @B.ByteString - $ fromWordBE @Word16 tag <> bytes + InputNode bs -> InputNode @a + $ buildByteString $ BB.word16BE tag <> BB.byteString bs TreeNode r -> TreeNode @a r where tag :: Word16 @@ -498,14 +499,14 @@ fromMerkleNodeTagged :: forall a u b m . MonadThrow m => IsMerkleLogEntry a u b - => MerkleNodeType a B.ByteString + => MerkleNodeType a -> m b -fromMerkleNodeTagged (InputNode bytes) = do - w16 <- toWordBE @Word16 bytes +fromMerkleNodeTagged (InputNode bs) = do + w16 <- toWordBE @Word16 bs if w16 /= tag then throwM $ MerkleLogWrongTagException (Expected (sshow tag)) (Actual (sshow w16)) - else fromMerkleNodeM @a $ InputNode (B.drop 2 bytes) + else fromMerkleNodeM @a $ InputNode (B.drop 2 bs) where tag = tagVal @u @(Tag b) fromMerkleNodeTagged r = fromMerkleNodeM @a r @@ -522,12 +523,12 @@ newMerkleLog => MerkleLogEntries a u h b -> MerkleLog a u h b newMerkleLog entries = MerkleLog - { _merkleLogRoot = merkleRoot tree + { _merkleLogRoot = merkleRoot + $ toList + $ mapLogEntries (toMerkleNodeTagged @a) + $ entries , _merkleLogEntries = entries - , _merkleLogTree = tree } - where - tree = merkleTree $ toList $ mapLogEntries (toMerkleNodeTagged @a) entries -- | /Internal:/ Get (first) header entry of given type from a Merkle log. -- @@ -543,9 +544,9 @@ class Index c (Hdr b) ~ i => HasHeader_ a u c b i | i b -> c where instance HasHeader_ a u c (MerkleLog a u (c ': t) s) 'Z where type Hdr (MerkleLog a u (c ': t) s) = (c ': t) - header (MerkleLog _ (c :+: _) _) = c + header (MerkleLog _ (c :+: _)) = c headerPos = 0 - headerDict (MerkleLog _ (c :+: _) _) = Dict c + headerDict (MerkleLog _ (c :+: _)) = Dict c -- TODO: -- @@ -558,9 +559,9 @@ instance => HasHeader_ a u c (MerkleLog a u (x ': t) s) ('S i) where type Hdr (MerkleLog a u (x ': t) s) = (x ': t) - header (MerkleLog x (_ :+: t) y) = header @a @u (MerkleLog @a x t y) + header (MerkleLog x (_ :+: t)) = header @a @u (MerkleLog @a x t) headerPos = succ $ headerPos @a @u @c @(MerkleLog a u t s) - headerDict (MerkleLog x (_ :+: t) y) = headerDict @a @u (MerkleLog @a x t y) + headerDict (MerkleLog x (_ :+: t)) = headerDict @a @u (MerkleLog @a x t) type HasHeader a u c b = HasHeader_ a u c b (Index c (Hdr b)) @@ -593,7 +594,8 @@ computeMerkleLogRoot . HasMerkleLog a u b => b -> MerkleRoot a -computeMerkleLogRoot = merkleRoot . _merkleLogTree . toLog @a +computeMerkleLogRoot = + merkleRoot . toList . mapLogEntries (toMerkleNodeTagged @a) . _merkleLogEntries . toLog @a {-# INLINE computeMerkleLogRoot #-} -- -------------------------------------------------------------------------- -- @@ -612,15 +614,27 @@ computeMerkleLogRoot = merkleRoot . _merkleLogTree . toLog @a -- should use that instead. Another option would be to use two separate trees, -- but, again, our current use case wouldn't justify the overhead. -- -headerProof +headerProofV1 + :: forall c a u b m + . MonadThrow m + => HasHeader a u c (MkLogType a u b) + => HasMerkleLog a u b + => b + -> m (V1.MerkleProof a) +headerProofV1 = uncurry3 (V1.merkleTreeProof @a) . headerTree @c @a +{-# INLINE headerProofV1 #-} + +headerProofV2 :: forall c a u b m . MonadThrow m => HasHeader a u c (MkLogType a u b) => HasMerkleLog a u b => b -> m (MerkleProof a) -headerProof = uncurry3 merkleProof . headerTree @c @a -{-# INLINE headerProof #-} +headerProofV2 b = merkleProof @a p (_merkleLogLeafs @a (toLog @a b)) + where + p = headerPos @a @u @c @(MkLogType a u b) +{-# INLINE headerProofV2 #-} -- | Create the parameters for creating nested inclusion proofs with the -- 'merkleProof_' of the merkle-log package. @@ -633,7 +647,7 @@ headerTree . HasHeader a u c (MkLogType a u b) => HasMerkleLog a u b => b - -> (MerkleNodeType a B.ByteString, Int, MerkleTree a) + -> (MerkleNodeType a, Int, V1.MerkleTree a) headerTree b = (node, p, _merkleLogTree @a mlog) where mlog = toLog @a b @@ -652,7 +666,7 @@ headerTree_ . HasHeader a u c (MkLogType a u b) => HasMerkleLog a u b => b - -> (Int, MerkleTree a) + -> (Int, V1.MerkleTree a) headerTree_ b = (p, _merkleLogTree @a mlog) where mlog = toLog @a b @@ -665,7 +679,18 @@ headerTree_ b = (p, _merkleLogTree @a mlog) -- should either make sure that it is memoized or provide a version that takes a -- 'MerkleLog' value. -- -bodyProof +bodyProofV1 + :: forall a u b m + . MonadThrow m + => HasMerkleLog a u b + => b + -> Int + -- ^ the index in the body of the log + -> m (V1.MerkleProof a) +bodyProofV1 b = uncurry3 V1.merkleTreeProof . bodyTree @a b +{-# INLINE bodyProofV1 #-} + +bodyProofV2 :: forall a u b m . MonadThrow m => HasMerkleLog a u b @@ -673,8 +698,11 @@ bodyProof -> Int -- ^ the index in the body of the log -> m (MerkleProof a) -bodyProof b = uncurry3 merkleProof . bodyTree @a b -{-# INLINE bodyProof #-} +bodyProofV2 b i = merkleProof @a p (_merkleLogLeafs @a mlog) + where + mlog = (toLog @a b) + p = i + headerSize mlog +{-# INLINE bodyProofV2 #-} -- | Create the parameters for creating nested inclusion proofs with the -- 'merkleProof_' of the merkle-log package. @@ -688,7 +716,7 @@ bodyTree => b -> Int -- ^ the index in the body of the log - -> (MerkleNodeType a B.ByteString, Int, MerkleTree a) + -> (MerkleNodeType a, Int, V1.MerkleTree a) bodyTree b i = (node, i_, _merkleLogTree @a mlog) where mlog = toLog @a b @@ -707,72 +735,67 @@ bodyTree_ => b -> Int -- ^ the index in the body of the log - -> (Int, MerkleTree a) + -> (Int, V1.MerkleTree a) bodyTree_ b i = (i_, _merkleLogTree @a mlog) where mlog = toLog @a b i_ = i + headerSize mlog --- | Extract the proof subject from a 'MerkleProof' value. +-- | Extract the proof subject from a 'V1.MerkleProof' value. -- proofSubject :: forall a u b m . MonadThrow m => IsMerkleLogEntry a u b - => MerkleProof a + => V1.MerkleProof a -> m b proofSubject p = fromMerkleNodeTagged @a subj where - MerkleProofSubject subj = _merkleProofSubject p + V1.MerkleProofSubject subj = V1._merkleProofSubject p {-# INLINE proofSubject #-} +-- | Extract the proof claim from a 'MerkleProof' value. +-- +proofClaim + :: forall a u b m + . MonadThrow m + => IsMerkleLogEntry a u b + => MerkleProof a + -> m b +proofClaim = fromMerkleNodeTagged @a . _merkleProofClaim +{-# INLINE proofClaim #-} + -- -------------------------------------------------------------------------- -- -- Tools Defining Instances encodeMerkleInputNode :: (b -> Put) -> b - -> MerkleNodeType a B.ByteString + -> MerkleNodeType a encodeMerkleInputNode encode = InputNode . runPutS . encode decodeMerkleInputNode :: MonadThrow m => Get b - -> MerkleNodeType a B.ByteString + -> MerkleNodeType a -> m b -decodeMerkleInputNode decode (InputNode bytes) = runGetS decode bytes +decodeMerkleInputNode decode (InputNode bs) = runGetS decode bs decodeMerkleInputNode _ (TreeNode _) = throwM expectedInputNodeException -encodeMerkleTreeNode :: Coercible a (MerkleRoot alg) => a -> MerkleNodeType alg x +encodeMerkleTreeNode :: Coercible a (MerkleRoot alg) => a -> MerkleNodeType alg encodeMerkleTreeNode = TreeNode . coerce decodeMerkleTreeNode :: MonadThrow m => Coercible (MerkleRoot alg) a - => MerkleNodeType alg x + => MerkleNodeType alg -> m a -decodeMerkleTreeNode (TreeNode bytes) = return $! coerce bytes +decodeMerkleTreeNode (TreeNode bs) = return $! coerce bs decodeMerkleTreeNode (InputNode _) = throwM expectedTreeNodeException -- -------------------------------------------------------------------------- -- -- Support for Deriving Via --- | Support for deriving IsMerkleLogEntry for types that are an instance of --- 'BA.ByteArray' via the @DerivingVia@ extension. --- -newtype ByteArrayMerkleLogEntry u (t :: u) b = ByteArrayMerkleLogEntry b - -instance - (MerkleHashAlgorithm a, InUniverse u t, BA.ByteArray b) - => IsMerkleLogEntry a u (ByteArrayMerkleLogEntry u (t :: u) b) - where - type Tag (ByteArrayMerkleLogEntry u t b) = t - toMerkleNode (ByteArrayMerkleLogEntry b) = InputNode $ BA.convert b - fromMerkleNode (InputNode x) = return $! ByteArrayMerkleLogEntry $! BA.convert x - fromMerkleNode (TreeNode _) = throwM expectedInputNodeException - {-# INLINE toMerkleNode #-} - {-# INLINE fromMerkleNode #-} - -- | Support for deriving IsMerkleLogEntry for types that are newtype wrappers of -- 'MerkleRoot' via the @DerivingVia@ extension. -- @@ -786,70 +809,3 @@ instance (MerkleHashAlgorithm a, InUniverse u t) => IsMerkleLogEntry a u (Merkle {-# INLINE toMerkleNode #-} {-# INLINE fromMerkleNode #-} --- | Support for deriving IsMerkleLogEntry for types that are newtype wrappers of --- 'Word8' via the @DerivingVia@ extension. --- -newtype Word8MerkleLogEntry (t :: u) = Word8MerkleLogEntry { _getWord8LogEntry :: Word8 } - -instance - (MerkleHashAlgorithm a, InUniverse u t) => IsMerkleLogEntry a u (Word8MerkleLogEntry (t :: u)) - where - type Tag (Word8MerkleLogEntry t) = t - toMerkleNode = InputNode . B.singleton . _getWord8LogEntry - fromMerkleNode (InputNode x) = case B.uncons x of - Nothing -> throwM - $ MerkleLogDecodeException "failed to deserialize Word8 from empty ByteString" - Just (!c,"") -> return $! Word8MerkleLogEntry c - Just _ -> throwM - $ MerkleLogDecodeException "failed to deserialize Word8. Pending bytes in input" - fromMerkleNode (TreeNode _) = throwM expectedInputNodeException - {-# INLINE toMerkleNode #-} - {-# INLINE fromMerkleNode #-} - --- | Support for deriving IsMerkleLogEntry for types that are newtype wrappers of --- 'Word16' via the @DerivingVia@ extension. --- -newtype Word16BeMerkleLogEntry (t :: u) = Word16BeMerkleLogEntry - { _getWord16BeLogEntry :: Word16 } - -instance - (MerkleHashAlgorithm a, InUniverse u t) => IsMerkleLogEntry a u (Word16BeMerkleLogEntry (t :: u)) - where - type Tag (Word16BeMerkleLogEntry t) = t - toMerkleNode = InputNode . fromWordBE . _getWord16BeLogEntry - fromMerkleNode (InputNode x) = Word16BeMerkleLogEntry <$> toWordBE x - fromMerkleNode (TreeNode _) = throwM expectedInputNodeException - {-# INLINE toMerkleNode #-} - {-# INLINE fromMerkleNode #-} - --- | Support for deriving IsMerkleLogEntry for types that are newtype wrappers of --- 'Word32' via the @DerivingVia@ extension. --- -newtype Word32BeMerkleLogEntry (t :: u) = Word32BeMerkleLogEntry - { _getWord32BeLogEntry :: Word32 } - -instance - (MerkleHashAlgorithm a, InUniverse u t) => IsMerkleLogEntry a u (Word32BeMerkleLogEntry (t :: u)) - where - type Tag (Word32BeMerkleLogEntry t) = t - toMerkleNode = InputNode . fromWordBE . _getWord32BeLogEntry - fromMerkleNode (InputNode x) = Word32BeMerkleLogEntry <$> toWordBE x - fromMerkleNode (TreeNode _) = throwM expectedInputNodeException - {-# INLINE toMerkleNode #-} - {-# INLINE fromMerkleNode #-} - --- | Support for deriving IsMerkleLogEntry for types that are newtype wrappers of --- 'Word64' via the @DerivingVia@ extension. --- -newtype Word64BeMerkleLogEntry (t :: u) = Word64BeMerkleLogEntry - { _getWord64BeLogEntry :: Word64 } - -instance - (MerkleHashAlgorithm a, InUniverse u t) => IsMerkleLogEntry a u (Word64BeMerkleLogEntry (t :: u)) - where - type Tag (Word64BeMerkleLogEntry t) = t - toMerkleNode = InputNode . fromWordBE . _getWord64BeLogEntry - fromMerkleNode (InputNode x) = Word64BeMerkleLogEntry <$> toWordBE x - fromMerkleNode (TreeNode _) = throwM expectedInputNodeException - {-# INLINE toMerkleNode #-} - {-# INLINE fromMerkleNode #-} diff --git a/src/Chainweb/Cut.hs b/src/Chainweb/Cut.hs index b75c22d4ed..0b8a5a2607 100644 --- a/src/Chainweb/Cut.hs +++ b/src/Chainweb/Cut.hs @@ -1,21 +1,13 @@ {-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE ImportQualifiedPost #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ParallelListComp #-} {-# LANGUAGE RankNTypes #-} -{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} @@ -59,10 +51,6 @@ module Chainweb.Cut , cutAdjPairs , cutAdjs , lookupCutM -, forkDepth -, limitCut -, tryLimitCut -, limitCutHeaders , unsafeMkCut , chainHeights @@ -78,70 +66,34 @@ module Chainweb.Cut , checkBraidingOfCutPair , isBraidingOfCutPair --- * Extending Cuts -, isMonotonicCutExtension -, monotonicCutExtension -, tryMonotonicCutExtension - --- * Join -, Join(..) -, join -, applyJoin -, prioritizeHeavier -, prioritizeHeavier_ -, joinIntoHeavier -, joinIntoHeavier_ - --- * Meet -, meet - ) where +import Chainweb.BlockHash +import Chainweb.BlockHeader +import Chainweb.BlockHeight +import Chainweb.BlockWeight +import Chainweb.ChainId +import Chainweb.Graph +import Chainweb.Parent +import Chainweb.Utils +import Chainweb.Version +import Chainweb.Version.Utils import Control.DeepSeq import Control.Exception hiding (catch) import Control.Lens hiding ((:>), (.=)) import Control.Monad hiding (join) import Control.Monad.Catch - -import Data.Bifoldable import Data.Foldable import Data.Function -import Data.Functor.Of -import qualified Data.HashMap.Strict as HM -import qualified Data.HashSet as HS -import qualified Data.Heap as H -import qualified Data.List as List -import Data.Maybe (fromMaybe) -import Data.Monoid +import Data.HashMap.Strict qualified as HM +import Data.HashSet qualified as HS +import Data.List qualified as List import Data.Ord import Data.Text (Text) -import qualified Data.Text as T -import Data.These - +import Data.Text qualified as T import GHC.Generics (Generic) -import GHC.Stack - -import Numeric.Natural - import Prelude hiding (lookup) -import qualified Streaming.Prelude as S - --- internal modules - -import Chainweb.BlockHash -import Chainweb.BlockHeader -import Chainweb.BlockHeight -import Chainweb.BlockWeight -import Chainweb.ChainId -import Chainweb.Graph -import Chainweb.TreeDB -import Chainweb.Utils -import Chainweb.Version -import Chainweb.Version.Utils -import Chainweb.WebBlockHeaderDB -import Control.Monad.State.Strict - -- -------------------------------------------------------------------------- -- -- Cut @@ -176,7 +128,6 @@ import Control.Monad.State.Strict -- data Cut = Cut' { _cutHeaders' :: !(HM.HashMap ChainId BlockHeader) - , _cutChainwebVersion' :: !ChainwebVersion -- Memoize properties that have linear compute cost , _cutHeight' :: {- lazy -} CutHeight @@ -188,7 +139,7 @@ data Cut = Cut' deriving (Show, Eq, Ord, Generic) deriving anyclass (NFData) -_cutHeaders :: Cut -> (HM.HashMap ChainId BlockHeader) +_cutHeaders :: Cut -> HM.HashMap ChainId BlockHeader _cutHeaders = _cutHeaders' {-# INLINE cutHeaders #-} @@ -204,14 +155,6 @@ cutMap :: Getter Cut (HM.HashMap ChainId BlockHeader) cutMap = cutHeaders {-# INLINE cutMap #-} -_cutChainwebVersion :: Cut -> ChainwebVersion -_cutChainwebVersion = _cutChainwebVersion' -{-# INLINE _cutChainwebVersion #-} - -cutChainwebVersion :: Getter Cut ChainwebVersion -cutChainwebVersion = to _cutChainwebVersion -{-# INLINE cutChainwebVersion #-} - _cutWeight :: Cut -> BlockWeight _cutWeight = _cutWeight' {-# INLINE _cutWeight #-} @@ -255,14 +198,10 @@ cutIsTransition = to _cutIsTransition -- | The chain graph is the graph at the /minimum/ height of the block headers -- in the cut. -- -instance HasChainGraph Cut where - _chainGraph c = chainGraphAt (_chainwebVersion c) (_cutMinHeight c) +instance HasVersion => HasChainGraph Cut where + _chainGraph c = chainGraphAt (_cutMinHeight c) {-# INLINE _chainGraph #-} -instance HasChainwebVersion Cut where - _chainwebVersion = view cutChainwebVersion - {-# INLINE _chainwebVersion #-} - type instance Index Cut = ChainId type instance IxValue Cut = BlockHeader @@ -271,25 +210,24 @@ instance IxedGet Cut where {-# INLINE ixg #-} lookupCutM - :: MonadThrow m + :: (MonadThrow m, HasVersion) => HasChainId cid => cid -> Cut -> m BlockHeader lookupCutM cid c = firstOf (ixg (_chainId cid)) c ??? ChainNotInChainGraphException - (Expected $ chainIds c) + (Expected chainIds) (Actual (_chainId cid)) -unsafeMkCut :: ChainwebVersion -> HM.HashMap ChainId BlockHeader -> Cut -unsafeMkCut v hdrs = Cut' +unsafeMkCut :: HasVersion => HM.HashMap ChainId BlockHeader -> Cut +unsafeMkCut hdrs = Cut' { _cutHeaders' = hdrs - , _cutChainwebVersion' = v , _cutHeight' = int $ sum $ view blockHeight <$> hdrs , _cutWeight' = sum $ view blockWeight <$> hdrs , _cutMinHeight' = minimum $ view blockHeight <$> hdrs , _cutMaxHeight' = maximum $ view blockHeight <$> hdrs - , _cutIsTransition' = minheight < lastGraphChange v (maxheight) + , _cutIsTransition' = minheight < lastGraphChange maxheight } where minheight = minimum $ view blockHeight <$> hdrs @@ -344,184 +282,6 @@ chainHeights :: Cut -> [BlockHeight] chainHeights = fmap (view blockHeight) . toList . _cutHeaders {-# INLINE chainHeights #-} --- -------------------------------------------------------------------------- -- --- Tools for Graph Transitions --- --- These functions are used to adjust the available chains during construction --- of new cuts: --- --- * 'monotonicCutExtension' and 'tryMonotonicCutExtension': extend the --- resulting cut with genesis headers of new chains. --- --- * 'limitCut': project out chains that don't exist in the result cut. --- --- * 'join' and 'applyJoin': add chains from both cuts to the input cuts, so --- that all chains are available in the join base and can be restored during --- 'applyJoin'; project out non-existing chains in the result. --- --- The graph is determined by the /minimum/ height of the blocks in the cut. --- --- The minimum is used to ensure that cuts in a new graph only exist when /all/ --- blocks are on the new cut. This means the new chains are included only if all --- old chains have transitioned to the minimum block height of the new graph. - -cutHeadersMinHeight :: HM.HashMap ChainId BlockHeader -> BlockHeight -cutHeadersMinHeight = minimum . fmap (view blockHeight) -{-# INLINE cutHeadersMinHeight #-} - -cutHeadersChainwebVersion :: HM.HashMap ChainId BlockHeader -> ChainwebVersion -cutHeadersChainwebVersion m = _chainwebVersion $ unsafeHead "Chainweb.Cut.cutHeadersChainwebVersion" $ toList m -{-# INLINE cutHeadersChainwebVersion #-} - --- | The function projects onto the chains available at the minimum block height --- in input headers. --- --- At a graph change chains are considered blocked until "all" chains performed --- the transition to the new graph. Thus, a block in the new graph has all of --- its dependencies available. --- --- This an internal function. The result is meaningful only if the input headers --- form a valid cut. In particular, the input must not be empty. --- -projectChains - :: HM.HashMap ChainId BlockHeader - -> HM.HashMap ChainId BlockHeader -projectChains m = HM.intersection m - $ HS.toMap - $ chainIdsAt (cutHeadersChainwebVersion m) (cutHeadersMinHeight m) -{-# INLINE projectChains #-} - -cutProjectChains :: Cut -> Cut -cutProjectChains c = unsafeMkCut v $ projectChains $ _cutHeaders c - where - v = _chainwebVersion c -{-# INLINE cutProjectChains #-} - --- | Extend the chains for the graph at the minimum block height of the input --- headers. If a header for a chain is missing the genesis block header for that --- chain is added. --- --- This an internal function. The result is meaningful only if the input headers --- form a valid cut. In particular, the input must not be empty. --- -extendChains - :: HM.HashMap ChainId BlockHeader - -> HM.HashMap ChainId BlockHeader -extendChains m = HM.union m - $ genesisBlockHeadersAtHeight - (cutHeadersChainwebVersion m) - (cutHeadersMinHeight m) -{-# INLINE extendChains #-} - --- | This function adds all chains that are available in either of the input --- headers. It is assumed that both input header maps are contain headers for --- all chains for the graph at the respective minimum height of the headers. --- --- This function is used when dealing with joins that internally compute an --- intersection on the blocks on all chains, but the goal is to preserve blocks --- from all chains. --- --- This an internal function. The result is meaningful only if the input headers --- form a valid cut. In particular, the input must not be empty. --- -joinChains - :: HM.HashMap ChainId BlockHeader - -> HM.HashMap ChainId BlockHeader - -> (HM.HashMap ChainId BlockHeader, HM.HashMap ChainId BlockHeader) -joinChains a b = (HM.union a c, HM.union b c) - where - v = cutHeadersChainwebVersion a - c = genesisBlockHeader v <$> a <> b -{-# INLINE joinChains #-} - --- -------------------------------------------------------------------------- -- --- Limit Cut Hashes By Height - --- | Find a `Cut` that is a predecessor of the given one, and that has a block --- height that is smaller or equal the given height. --- --- If the requested limit is larger or equal to the current height, the given --- cut is returned. --- --- Otherwise, the predecessor of the given cut at the given height on each chain --- is returned. --- -limitCut - :: HasCallStack - => WebBlockHeaderDb - -> BlockHeight - -- ^ upper bound for the block height of each chain. This is not a tight - -- bound. - -> Cut - -> IO Cut -limitCut wdb h c - | all (\bh -> h >= view blockHeight bh) (view cutHeaders c) = - return c - | otherwise = do - hdrs <- itraverse go $ view cutHeaders c - return $! unsafeMkCut v $ projectChains $ HM.mapMaybe id hdrs - where - v = _chainwebVersion c - - go :: ChainId -> BlockHeader -> IO (Maybe BlockHeader) - go cid bh = do - if h >= view blockHeight bh - then return (Just bh) - else do - !db <- getWebBlockHeaderDb wdb cid - seekAncestor db bh (min (int $ view blockHeight bh) (int h)) - -- this is safe because it's guaranteed that the requested rank is - -- smaller then the block height of the argument - --- | Find a `Cut` that is a predecessor of the given one, and that has a block --- height that is as low as possible while not exceeding the given height and --- including all of the chains in the given cut. --- --- If the requested limit is larger or equal to the current height, the given --- cut is returned. --- -tryLimitCut - :: HasCallStack - => WebBlockHeaderDb - -> BlockHeight - -- upper bound for the block height of each chain. This is not a tight bound. - -> Cut - -> IO Cut -tryLimitCut wdb h c - | all (\bh -> h >= view blockHeight bh) (view cutHeaders c) = - return c - | otherwise = do - hdrs <- itraverse go $ view cutHeaders c - return $! unsafeMkCut v hdrs - where - v = _chainwebVersion wdb - go :: ChainId -> BlockHeader -> IO BlockHeader - go cid bh = do - if h >= view blockHeight bh - then return bh - else do - !db <- getWebBlockHeaderDb wdb cid - -- this is safe because it's guaranteed that the requested rank is - -- smaller then the block height of the argument - let ancestorHeight = min (int $ view blockHeight bh) (int h) - if ancestorHeight <= fromIntegral (genesisHeight v cid) - then return $ genesisBlockHeader v cid - else fromJuste <$> seekAncestor db bh ancestorHeight - --- | The resulting headers are valid cut headers only if the input headers are --- valid cut headers, too. The inverse is not true. --- -limitCutHeaders - :: HasCallStack - => WebBlockHeaderDb - -> BlockHeight - -- ^ upper bound for the block height of each chain. This is not a tight bound. - -> HM.HashMap ChainId BlockHeader - -> IO (HM.HashMap ChainId BlockHeader) -limitCutHeaders whdb h ch = _cutHeaders <$> limitCut whdb h (unsafeMkCut v ch) - where - v = _chainwebVersion whdb - -- -------------------------------------------------------------------------- -- -- Genesis Cut @@ -539,9 +299,9 @@ limitCutHeaders whdb h ch = _cutHeaders <$> limitCut whdb h (unsafeMkCut v ch) -- These properties are maintained as inductive invariants for all Cuts. -- genesisCut - :: ChainwebVersion - -> Cut -genesisCut v = unsafeMkCut v (genesisBlockHeadersAtHeight v 0) + :: HasVersion + => Cut +genesisCut = unsafeMkCut (genesisBlockHeadersAtHeight 0) -- -------------------------------------------------------------------------- -- -- Exceptions @@ -639,294 +399,9 @@ isBraidingOfCutPair a b = do ba <- getAdjacentHash a b -- adjacent of b on chain of a return $! (view blockParent a == ba && view blockParent b == ab) -- same graph - || (view blockHeight a > view blockHeight b) && ab == view blockHash b + || (view blockHeight a > view blockHeight b) && ab == Parent (view blockHash b) || (view blockHeight a < view blockHeight b) && True {- if same graph: ba == view blockHash a -} --- -------------------------------------------------------------------------- -- --- Extending Cuts - --- | Extends a Cut monotonically, i.e. the replaced block header is the parent --- of the added block header. --- --- Checks --- --- * block header is from the ChainGraph of the Cut --- * result has valid braiding --- * result is a cut --- * update is monotonic --- --- This includes a check that inductively maintains 'checkBraidingOfCut'. --- --- FIXME: this must conform with 'isBraidingOfCutPair'. Double check that we --- have test for this or check if the implementation can be shared. --- --- TODO: do we have to check that the correct graph is used? --- -isMonotonicCutExtension - :: HasCallStack - => MonadThrow m - => Cut - -> BlockHeader - -> m Bool -isMonotonicCutExtension c h = do - checkBlockHeaderGraph h - return $! monotonic && validBraiding - where - monotonic = view blockParent h == case c ^? ixg (_chainId h) . blockHash of - Nothing -> error $ T.unpack $ "isMonotonicCutExtension.monotonic: missing parent in cut. " <> encodeToText h - Just x -> x - validBraiding = getAll $ ifoldMap - (\cid -> All . validBraidingCid cid) - (_getBlockHashRecord $ view blockAdjacentHashes h) - - validBraidingCid cid a - | Just b <- c ^? ixg cid = view blockHash b == a || view blockParent b == a - | view blockHeight h == genesisHeight v cid = a == genesisParentBlockHash v cid - | otherwise = error $ T.unpack $ "isMonotonicCutExtension.validBraiding: missing adjacent parent on chain " <> toText cid <> " in cut. " <> encodeToText h - - v = _chainwebVersion c - --- | Extend a cut with a block header. Throws 'InvalidCutExtension' if the block --- header isn't a monotonic cut extension. --- -monotonicCutExtension - :: MonadThrow m - => Cut - -> BlockHeader - -> m Cut -monotonicCutExtension c h = tryMonotonicCutExtension c h >>= \case - Nothing -> throwM $ InvalidCutExtension h - Just x -> return x - --- | Extend a cut with a block header. Returns 'Nothing' the block header isn't --- a monotonic cut extension. --- -tryMonotonicCutExtension - :: MonadThrow m - => Cut - -> BlockHeader - -> m (Maybe Cut) -tryMonotonicCutExtension c h = isMonotonicCutExtension c h >>= \case - False -> return Nothing - True -> return $! Just - $! unsafeMkCut v - $ extendChains - $ set (ix' (_chainId h)) h - $ _cutHeaders c - where - v = _chainwebVersion c - --- -------------------------------------------------------------------------- -- --- Join - -type DiffItem a = These a a - -type JoinQueue a = H.Heap (H.Entry (BlockHeight, a) BlockHeader) - --- | This represents the Join of two cuts in an algorithmically convenient way. --- -data Join a = Join - { _joinBase :: !Cut - -- ^ the base of the join, the largest cut that is contained in both - -- cuts, or when viewed as sets, the intersection. - , _joinQueue :: !(JoinQueue a) - -- ^ a queue of block headers from both cuts that allows construct - -- the join cut from the join base. - } - --- | This computes the join for cuts across all chains. --- --- If you want to compute a join for cuts that include only a subset of all --- chains. --- -join - :: Ord a - => WebBlockHeaderDb - -> (DiffItem BlockHeader -> DiffItem (Maybe a)) - -> Cut - -> Cut - -> IO (Join a) -join wdb f = join_ wdb f `on` _cutHeaders - --- | This merges two maps from ChainIds to BlockHeaders such that the result is --- a Cut. Note, however, that the resulting cut contains only the chain ids from --- the intersection of the input maps. --- --- NOTE: For this to work as expected make sure that both inputs contain all --- chains that should be present in the output. --- --- Adds genesis blocks for chains that are not yet active. This purpose of this --- is to make sure that all chains of both inputs are preserved in the join, so --- that the result of the join contains all chains of the original cuts. --- Otherwise the join would contain only the intersection of all chains and any --- information/blocks in the other chains would be lost when applying the join. --- -join_ - :: forall a - . Ord a - => WebBlockHeaderDb - -> (DiffItem BlockHeader -> DiffItem (Maybe a)) - -> HM.HashMap ChainId BlockHeader - -> HM.HashMap ChainId BlockHeader - -> IO (Join a) -join_ wdb prioFun a b = do - (m, h) <- runStateT (HM.traverseWithKey f (HM.intersectionWith (,) a' b')) mempty - return $! Join (unsafeMkCut (_chainwebVersion wdb) m) h - where - (a', b') = joinChains a b - - f - :: ChainId - -> (BlockHeader, BlockHeader) - -> StateT (JoinQueue a) IO BlockHeader - f cid (x, y) = do - !q <- get - db <- getWebBlockHeaderDb wdb cid - (q' :> !h) <- liftIO $ S.fold g q id $ branchDiff_ db x y - put q' - return h - - g :: JoinQueue a -> DiffItem BlockHeader -> JoinQueue a - g q x = foldl' maybeInsert q $ zip (biList x) (biList (prioFun x)) - - maybeInsert - :: H.Heap (H.Entry (BlockHeight, a) BlockHeader) - -> (BlockHeader, Maybe a) - -> H.Heap (H.Entry (BlockHeight, a) BlockHeader) - maybeInsert !q (_, Nothing) = q - maybeInsert !q (!h, (Just !p)) = H.insert (H.Entry (view blockHeight h, p) h) q - --- This can't fail because of missing dependencies. It can't fail because --- of conflict. --- --- Non-existing chains are stripped from the result. --- -applyJoin :: MonadThrow m => Join a -> m Cut -applyJoin m = cutProjectChains - <$> foldM - (\c b -> fromMaybe c <$> tryMonotonicCutExtension c (H.payload b)) - (_joinBase m) - (_joinQueue m) - --- | Merge two Cuts. If at least one of the input cuts had a valid braiding the --- result is guaranteed to have a valid braiding for all blocks included in cut --- and their ancestors. --- --- This is because the merge starts with the intersection of both cuts, using --- 'branchDiff_' on each chain, and constructs the merge cut using --- 'tryMonotonicCutExtension'. If one of the inputs is correctly braided, so is --- the intersection. 'tryMonotonicCutExtension' is guaranteed to maintain that --- property. --- --- Chains that aren't yet initialized are included in the join and later --- stripped from the result. --- --- If you want to compute a join for cuts that include only a subset of all --- chains, make sure that @genesisBlockHeaders v@ only returns genesis headers --- for those chains that you care about. --- -joinIntoHeavier - :: WebBlockHeaderDb - -> Cut - -> Cut - -> IO Cut -joinIntoHeavier wdb = joinIntoHeavier_ wdb `on` _cutHeaders - --- | Chains that aren't yet initialized are included in the join and later --- stripped from the result. --- --- If you want to compute a join for cuts that include only a subset of all --- chains, make sure that @genesisBlockHeaders v@ only returns genesis headers --- for those chains that you care about. --- -joinIntoHeavier_ - :: WebBlockHeaderDb - -> HM.HashMap ChainId BlockHeader - -> HM.HashMap ChainId BlockHeader - -> IO Cut -joinIntoHeavier_ wdb a b = do - m <- join_ wdb (prioritizeHeavier_ a b) a b - applyJoin m - -prioritizeHeavier :: Cut -> Cut -> DiffItem BlockHeader -> DiffItem (Maybe Int) -prioritizeHeavier = prioritizeHeavier_ `on` _cutHeaders - --- | Note: consider the weight of the recursive dependencies for the --- priority of a block header. For that we would have to annotate the --- block headers before putting them in the queue. To traverse only once, --- we'd have to traverse the zipped cuts by height and not by chainid, which --- could easily be done by merging/zipping the branch-diff streams. --- -prioritizeHeavier_ - :: Foldable f - => Eq (f BlockHeader) - => f BlockHeader - -> f BlockHeader - -> DiffItem BlockHeader - -> DiffItem (Maybe Int) -prioritizeHeavier_ a b = f - where - heaviest = maxBy (compare `on` weight) a b - w c = if c == heaviest then 0 else 1 - - f (This _) = This (Just $ w a) - f (That _) = That (Just $ w b) - f (These _ _) - | heaviest == a = These (Just 0) Nothing - | otherwise = These Nothing (Just 0) - - weight c = - ( sumOf (folded . blockWeight) c - -- first sort by weight - , sumOf (folded . blockHeight) c - -- for scenarios with trivial difficulty height is added as - -- secondary metrics - - -- NOTE: - -- We could consider prioritizing the latest block in the cut here as - -- first-level tie breaker. That would further incentivize miners to use - -- a block creation time that is close to the real world time (note that - -- blocks from the future are rejected, so post-dating blocks is risky - -- for miners.) - - , List.sort (toList c) - -- the block hashes of the cut are added as tie breaker in order - -- to guarantee commutativity. - -- - ) - --- -------------------------------------------------------------------------- -- --- Cut Meet - --- | Intersection of cuts --- -meet - :: WebBlockHeaderDb - -> Cut - -> Cut - -> IO Cut -meet wdb a b = do - !r <- imapM f $ HM.intersectionWith (,) (_cutHeaders a) (_cutHeaders b) - return $! unsafeMkCut (_chainwebVersion wdb) r - where - f !cid (!x, !y) = do - db <- getWebBlockHeaderDb wdb cid - forkEntry db x y - -forkDepth - :: WebBlockHeaderDb - -> Cut - -> Cut - -> IO Natural -forkDepth wdb a b = do - m <- meet wdb a b - return $! int $ max (maxDepth m a) (maxDepth m b) - where - maxDepth l u = maximum $ HM.intersectionWith - (\x y -> view blockHeight y - view blockHeight x) - (_cutHeaders l) - (_cutHeaders u) - cutToTextShort :: Cut -> [Text] cutToTextShort c = [ blockHeaderShortDescription bh diff --git a/src/Chainweb/Cut/Create.hs b/src/Chainweb/Cut/Create.hs index 4fbc31a6b3..2670a91ddb 100644 --- a/src/Chainweb/Cut/Create.hs +++ b/src/Chainweb/Cut/Create.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DerivingStrategies #-} @@ -5,12 +7,14 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE ImportQualifiedPost #-} {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MagicHash #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} -- | -- Module: Chainweb.Cut.Create @@ -46,17 +50,49 @@ module Chainweb.Cut.Create , _cutExtensionAdjacentHashes , cutExtensionAdjacentHashes , getCutExtension +, cutMixedTransition + +-- * Limit cuts +, limitCut +, tryLimitCut +, limitCutHeaders + +-- * Predicates +, isMonotonicCutExtension +, monotonicCutExtension +, tryMonotonicCutExtension + +-- * Join +, Join(..) +, join +, applyJoin +, prioritizeHeavier +, prioritizeHeavier_ +, joinIntoHeavier +, joinIntoHeavier_ + +-- * Meet +, meet +, forkDepth + +-- * WorkParents +, WorkParents(..) +, workParents +, _workParent +, workParent +, _workParentsAdjacentHashes +, workParentsAdjacentHashes +, newWork +, getAdjacentParentHeaders -- * Work -, WorkHeader(..) -, encodeWorkHeader +, MiningWork(..) +, encodeMiningWork , decodeWorkHeader -, newWorkHeader -, newWorkHeaderPure +, newMiningWorkPure -- * Solved Work , SolvedWork(..) -, encodeSolvedWork , decodeSolvedWork , extend , InvalidSolvedHeader(..) @@ -65,51 +101,74 @@ module Chainweb.Cut.Create import Control.DeepSeq import Control.Lens -import Control.Monad +import Control.Monad hiding (join) import Control.Monad.Catch - +import Control.Monad.State.Strict import Data.ByteString.Short qualified as SB import Data.HashMap.Strict qualified as HM import Data.HashSet qualified as HS +import Data.Heap qualified as H import Data.Text qualified as T - -import GHC.Generics +import Data.These +import GHC.Generics (Generic) import GHC.Stack - --- internal modules - +import Numeric.Natural import Chainweb.BlockCreationTime import Chainweb.BlockHash import Chainweb.BlockHeader import Chainweb.BlockHeader.Validation import Chainweb.BlockHeight import Chainweb.ChainValue +import Chainweb.Core.Brief import Chainweb.Cut import Chainweb.Cut.CutHashes import Chainweb.Difficulty +import Chainweb.Parent +import Chainweb.PayloadProvider (EncodedPayloadData (..), EncodedPayloadOutputs) import Chainweb.ForkState(ForkNumber(..)) -import Chainweb.Payload -import Chainweb.Time import Chainweb.Utils import Chainweb.Utils.Serialization import Chainweb.Version import Chainweb.Version.Utils +import Chainweb.WebBlockHeaderDB +import Chainweb.Ranked (Ranked(_rankedHeight)) +import Chainweb.TreeDB hiding (parent) +import Data.Foldable +import Data.Function +import Data.List qualified as List +import Data.List.NonEmpty (NonEmpty) +import Data.List.NonEmpty qualified as NE +import Data.Maybe +import Data.Monoid +import Streaming qualified as S +import Streaming.Prelude qualified as S -- -------------------------------------------------------------------------- -- -- Adjacent Parent Hashes -- | Witnesses that a cut can be extended for the respective header. -- +-- Essentially, this guarantees the following: +-- +-- 1. The parent header is in the cut. +-- 2. Adjacent hashes match the adjacent chains in the chain graph. +-- 3. Adjacent hashes are in the cut or parents of headers in the cut. +-- +-- There are a few additional corner cases related to genesis blocks and graph +-- transitions. +-- data CutExtension = CutExtension { _cutExtensionCut' :: !Cut -- ^ the cut which is to be extended -- -- This is overly restrictive, since the same cut extension can be -- valid for more than one cut. It's fine for now. - , _cutExtensionParent' :: !ParentHeader - -- ^ the header onto which the new block is created. It is expected + , _cutExtensionParent' :: !(Parent BlockHeader) + -- ^ The header onto which the new block is created. It is expected -- that this header is contained in the cut. , _cutExtensionAdjacentHashes' :: !BlockHashRecord + -- ^ The adjacent hashes for the new block. These are either part of the + -- cut or are parents of headers in the cut. } deriving (Show, Eq, Generic) @@ -123,12 +182,12 @@ cutExtensionCut = cutExtensionCut' -- | The header onto which the new block is created. -- -_cutExtensionParent :: CutExtension -> ParentHeader +_cutExtensionParent :: CutExtension -> Parent BlockHeader _cutExtensionParent = _cutExtensionParent' -- | The header onto which the new block is created. -- -cutExtensionParent :: Lens' CutExtension ParentHeader +cutExtensionParent :: Lens' CutExtension (Parent BlockHeader) cutExtensionParent = cutExtensionParent' _cutExtensionAdjacentHashes :: CutExtension -> BlockHashRecord @@ -141,10 +200,6 @@ instance HasChainId CutExtension where _chainId = _chainId . _cutExtensionParent {-# INLINE _chainId #-} -instance HasChainwebVersion CutExtension where - _chainwebVersion = _chainwebVersion . _cutExtensionCut - {-# INLINE _chainwebVersion #-} - -- | Witness that a cut can be extended for the given chain by trying to -- assemble the adjacent hashes for a new work header. -- @@ -164,13 +219,13 @@ instance HasChainwebVersion CutExtension where -- blocks for the new chains and move ahead. So steps in the new graph are not -- allowed. -- --- TODO: it is important that the semantics of this function corresponds to the +-- NB: it is important that the semantics of this function corresponds to the -- respective validation in the module "Chainweb.Cut", in particular -- 'isMonotonicCutExtension'. It must not happen, that a cut passes validation -- that can't be further extended. -- getCutExtension - :: HasCallStack + :: (HasCallStack, HasVersion) => HasChainId cid => Cut -- ^ the cut which is to be extended @@ -179,9 +234,9 @@ getCutExtension -> Maybe CutExtension getCutExtension c cid = do - -- In a graph transition we wait for all chains to do the transition to the - -- new graph before moving ahead. Blocks chains that reach the new graph - -- until all chains have reached the new graph. + -- If ANY chains in the graph have completed the graph transition (i.e. + -- reached the transition height) then we wait for ALL chains to complete + -- the transition before moving ahead on those chains. -- guard (not $ isGraphTransitionCut && isGraphTransitionPost) @@ -189,18 +244,17 @@ getCutExtension c cid = do return CutExtension { _cutExtensionCut' = c - , _cutExtensionParent' = ParentHeader p + , _cutExtensionParent' = Parent p , _cutExtensionAdjacentHashes' = as } where p = c ^?! ixg (_chainId cid) - v = _chainwebVersion c parentHeight = view blockHeight p targetHeight = parentHeight + 1 - parentGraph = chainGraphAt p parentHeight + parentGraph = chainGraphAt parentHeight -- true if the parent height is the first of a new graph. - isGraphTransitionPost = isGraphChange c parentHeight + isGraphTransitionPost = isGraphChange parentHeight -- true if a graph transition occurs in the cut. isGraphTransitionCut = _cutIsTransition c @@ -208,7 +262,7 @@ getCutExtension c cid = do -- | Try to get all adjacent hashes dependencies for the given graph. -- - newAdjHashes :: ChainGraph -> Maybe (HM.HashMap ChainId BlockHash) + newAdjHashes :: ChainGraph -> Maybe (HM.HashMap ChainId (Parent BlockHash)) newAdjHashes g = imapM (\xcid _ -> hashForChain xcid) $ HS.toMap -- converts to Map Foo () @@ -217,7 +271,7 @@ getCutExtension c cid = do hashForChain acid -- existing chain | Just b <- lookupCutM acid c = tryAdj b - | targetHeight == genesisHeight v acid = error $ T.unpack + | targetHeight == genesisHeight acid = error $ T.unpack $ "getAdjacentParents: invalid cut extension, requested parent of a genesis block for chain " <> sshow acid <> ".\n Parent: " <> encodeToText (ObjectEncoded p) @@ -226,7 +280,7 @@ getCutExtension c cid = do <> sshow acid <> ".\n Cut: " <> sshow c - tryAdj :: BlockHeader -> Maybe BlockHash + tryAdj :: BlockHeader -> Maybe (Parent BlockHash) tryAdj b -- When the block is behind, we can move ahead @@ -236,33 +290,42 @@ getCutExtension c cid = do | view blockHeight b + 1 == parentHeight = Nothing -- chain is blocked -- If this is not a graph transition cut we can move ahead - | view blockHeight b == parentHeight = Just $! view blockHash b + | view blockHeight b == parentHeight = Just $! Parent $ view blockHash b -- The cut is invalid | view blockHeight b > targetHeight = error $ T.unpack $ "getAdjacentParents: detected invalid cut (adjacent parent too far ahead)." <> "\n Parent: " <> encodeToText (ObjectEncoded p) <> "\n Conflict: " <> encodeToText (ObjectEncoded b) + <> "\n Cut: " <> brief c | view blockHeight b + 1 < parentHeight = error $ T.unpack $ "getAdjacentParents: detected invalid cut (adjacent parent too far behind)." <> "\n Parent: " <> encodeToText (ObjectEncoded p) <> "\n Conflict: " <> encodeToText (ObjectEncoded b) - | otherwise = error - $ "Chainweb.Miner.Coordinator.getAdjacentParents: internal code invariant violation" + <> "\n Cut: " <> brief c + | otherwise = error $ T.unpack + $ "Chainweb.Miner.Coordinator.getAdjacentParents: internal code invariant violation:" + <> "\n Cut: " <> brief c -- -------------------------------------------------------------------------- -- --- Mining Work Header +-- Mining Work --- | A work header has a preliminary creation time and an invalid nonce of 0. +-- | Mining work has a preliminary creation time and an invalid nonce of 0. +-- +-- The work is derived from a block header, however it is not obtain the +-- original block header from the work header. In order to obtain the original +-- header one has to extract the nonce and the creation from the mining work and +-- inject it into the original block header. +-- -- It is the job of the miner to update the creation time and find a valid nonce -- that satisfies the target of the header. -- --- The updated header has type 'SolvedHeader'. +-- The result of mining has type 'SolvedMiningWork'. -- -data WorkHeader = WorkHeader - { _workHeaderChainId :: !ChainId - , _workHeaderTarget :: !HashTarget - , _workHeaderBytes :: !SB.ShortByteString +data MiningWork = MiningWork + { _miningWorkChainId :: !ChainId + , _miningWorkTarget :: !HashTarget + , _miningWorkBytes :: !SB.ShortByteString -- ^ 286 work bytes. -- The last 8 bytes are the nonce -- The creation time is encoded in bytes 8-15 @@ -270,45 +333,34 @@ data WorkHeader = WorkHeader deriving (Show, Eq, Ord, Generic) deriving anyclass (NFData) -encodeWorkHeader :: WorkHeader -> Put -encodeWorkHeader wh = do - encodeChainId $ _workHeaderChainId wh - encodeHashTarget $ _workHeaderTarget wh - putByteString $ SB.fromShort $ _workHeaderBytes wh +encodeMiningWork :: MiningWork -> Put +encodeMiningWork wh = do + encodeChainId $ _miningWorkChainId wh + encodeHashTarget $ _miningWorkTarget wh + putByteString $ SB.fromShort $ _miningWorkBytes wh -- FIXME: We really want this indepenent of the block height. For production -- chainweb version this is actually the case. -- -decodeWorkHeader :: ChainwebVersion -> BlockHeight -> Get WorkHeader -decodeWorkHeader ver h = WorkHeader +decodeWorkHeader :: HasVersion => BlockHeight -> Get MiningWork +decodeWorkHeader h = MiningWork <$> decodeChainId <*> decodeHashTarget - <*> (SB.toShort <$> getByteString (int $ workSizeBytes ver h)) + <*> (SB.toShort <$> getByteString (int $ workSizeBytes h)) --- | Create work header for cut +-- | A pure version of 'newWorkHeader' that is useful in testing. It is not used +-- in production code. -- -newWorkHeader - :: ChainValueCasLookup hdb BlockHeader - => hdb - -> ForkNumber - -> CutExtension - -> BlockPayloadHash - -> IO WorkHeader -newWorkHeader hdb targetFork e h = do - creationTime <- BlockCreationTime <$> getCurrentTimeIntegral - newWorkHeaderPure (chainLookupM hdb) targetFork creationTime e h - --- | A pure version of 'newWorkHeader' that is useful in testing. --- -newWorkHeaderPure +newMiningWorkPure :: Applicative m + => HasVersion => (ChainValue BlockHash -> m BlockHeader) -> ForkNumber -> BlockCreationTime -> CutExtension -> BlockPayloadHash - -> m WorkHeader -newWorkHeaderPure hdb targetFork creationTime extension phash = do + -> m MiningWork +newMiningWorkPure hdb targetFork creationTime extension phash = do -- Collect block headers for adjacent parents, some of which may be -- available in the cut. createWithParents <$> getAdjacentParentHeaders hdb extension @@ -321,10 +373,10 @@ newWorkHeaderPure hdb targetFork creationTime extension phash = do let nh = newBlockHeader targetFork parents phash (Nonce 0) creationTime $! _cutExtensionParent extension -- FIXME: check that parents also include hashes on new chains! - in WorkHeader - { _workHeaderBytes = SB.toShort $ runPutS $ encodeBlockHeaderWithoutHash nh - , _workHeaderTarget = view blockTarget nh - , _workHeaderChainId = _chainId nh + in MiningWork + { _miningWorkBytes = SB.toShort $ runPutS $ encodeAsMiningWork nh + , _miningWorkTarget = view blockTarget nh + , _miningWorkChainId = _chainId nh } -- | Get all adjacent parent headers for a new block header for a given cut. @@ -345,10 +397,11 @@ newWorkHeaderPure hdb targetFork creationTime extension phash = do -- getAdjacentParentHeaders :: HasCallStack + => HasVersion => Applicative m => (ChainValue BlockHash -> m BlockHeader) -> CutExtension - -> m (HM.HashMap ChainId ParentHeader) + -> m (HM.HashMap ChainId (Parent BlockHeader)) getAdjacentParentHeaders hdb extension = itraverse select . _getBlockHashRecord @@ -356,10 +409,10 @@ getAdjacentParentHeaders hdb extension where c = _cutExtensionCut extension - select cid h = case c ^? ixg cid of - Just ch -> ParentHeader <$> if view blockHash ch == h - then pure ch - else hdb (ChainValue cid h) + select cid (Parent h) = case c ^? ixg cid of + Just ch -> if view blockHash ch == h + then pure (Parent ch) + else Parent <$> hdb (ChainValue cid h) Nothing -> error $ T.unpack $ "Chainweb.Cut.Create.getAdjacentParentHeaders: inconsistent cut extension detected" @@ -367,32 +420,173 @@ getAdjacentParentHeaders hdb extension <> ". CutHashes: " <> encodeToText (cutToCutHashes Nothing c) -- -------------------------------------------------------------------------- -- --- Solved Header +-- Work Parents + +-- | The direct parents and adjacent new parents onto which a new block is +-- created. -- +data WorkParents = WorkParents + { _workParent' :: !(Parent BlockHeader) + -- ^ The header onto which the new block is created. + , _workAdjacentParents' :: !(HM.HashMap ChainId (Parent BlockHeader)) + -- ^ The adjacent hashes for the new block. These must be at the same + -- height as the parent and must be have a pairwise valid braiding among + -- each other and with the parent. + -- + -- Actually, only the hash and the target of the adjacent parents is + -- used to construct the new work. + } + deriving (Show, Eq, Generic) + +instance Brief WorkParents where + brief ps = brief (view _Parent $ _workParent ps) + <> ":" + <> brief (HM.toList $ view _Parent <$> _workAdjacentParents' ps) + +_workParent :: WorkParents -> Parent BlockHeader +_workParent = _workParent' + +workParent :: Getter WorkParents (Parent BlockHeader) +workParent = to _workParent --- | A solved header is the result of mining. It has the final creation time and --- a valid nonce. The binary representation doesn't yet contain a Merkle Hash. --- Also, the block header is not yet validated. +_workParentsAdjacentHashes :: WorkParents -> BlockHashRecord +_workParentsAdjacentHashes = BlockHashRecord + . fmap (fmap (view blockHash)) + . _workAdjacentParents' + +workParentsAdjacentHashes :: Getter WorkParents BlockHashRecord +workParentsAdjacentHashes = to _workParentsAdjacentHashes + +-- | Returns the work parents for a given cut and a given chain. Returns +-- 'Nothing' if the chain in blocked for the cut. -- --- This is an internal data type. On the client/miner side only the serialized --- representation is used. +workParents + :: HasCallStack + => HasVersion + => Applicative m + => HasChainId cid + => (ChainValue BlockHash -> m BlockHeader) + -> Cut + -- ^ the cut which is to be extended + -> cid + -- ^ the chain which is to be extended + -> m (Maybe WorkParents) +workParents hdb c cid = case getCutExtension c cid of + Nothing -> pure Nothing + Just e -> Just . WorkParents (_cutExtensionParent e) + <$> getAdjacentParentHeaders hdb e + +newWork + :: HasVersion + => ForkNumber + -> BlockCreationTime + -> WorkParents + -> BlockPayloadHash + -> MiningWork +newWork targetFork creationTime parents pldHash = MiningWork + { _miningWorkBytes = SB.toShort $ runPutS $ encodeAsMiningWork nh + , _miningWorkTarget = view blockTarget nh + , _miningWorkChainId = _chainId nh + } + where + adjParents = _workAdjacentParents' parents + parent = _workParent' parents + nh = newBlockHeader targetFork adjParents pldHash (Nonce 0) creationTime parent + +-- | TODO: do we have to verify that the solved for matches the work parents? -- -newtype SolvedWork = SolvedWork BlockHeader +newHeader + :: HasVersion + => ForkNumber + -> WorkParents + -> SolvedWork + -> BlockHeader +newHeader targetFork parents solved = + newBlockHeader targetFork adjParents pldHash nonce creationTime parent + where + pldHash = _solvedPayloadHash solved + adjParents = _workAdjacentParents' parents + parent = _workParent' parents + nonce = _solvedWorkNonce solved + creationTime = _solvedWorkCreationTime solved + +-- -------------------------------------------------------------------------- -- +-- Solved Work + +-- | A solution for mining work. It provides final creation time and +-- a valid nonce for the respective new header that is identfied by the parent +-- hashes, and the payload hash. +-- +-- With the currently mining API, mining clients actually return a solved mining +-- work value from which the solution is extracted. Future version of the API +-- will most like return SolvedWork values directly. +-- +data SolvedWork = SolvedWork + { _solvedChainId :: !ChainId + , _solvedParentHash :: !(Parent BlockHash) + , _solvedAdjacentHash :: !AdjacentsHash + , _solvedPayloadHash :: !BlockPayloadHash + , _solvedWorkCreationTime :: !BlockCreationTime + , _solvedWorkNonce :: !Nonce + } deriving (Show, Eq, Ord, Generic) deriving anyclass (NFData) -encodeSolvedWork :: SolvedWork -> Put -encodeSolvedWork (SolvedWork hdr) = encodeBlockHeaderWithoutHash hdr +instance HasChainId SolvedWork where + _chainId = _solvedChainId + {-# INLINE _chainId #-} +-- | This is a special decoding function that decode solved work from the +-- mining work bytes that the miner returns as solution. +-- decodeSolvedWork :: Get SolvedWork -decodeSolvedWork = SolvedWork <$> decodeBlockHeaderWithoutHash +decodeSolvedWork = do + -- creation time: [8:15] + skip 8 + time <- decodeBlockCreationTime + + -- parenthash: [16:47] + parent <- decodeBlockHash + + -- third adjacent hash: [126:157] + skip 78 + adj <- decodeAdjacentsHash -data InvalidSolvedHeader = InvalidSolvedHeader BlockHeader T.Text + -- payload hash: [190:221] + skip 32 + pldHash <- decodeBlockPayloadHash + + -- chainId [222:225] + cid <- decodeChainId + + -- nonce: [278:285] + skip 52 + nonce <- decodeNonce + + return $ SolvedWork + { _solvedChainId = cid + , _solvedParentHash = Parent parent + , _solvedAdjacentHash = adj + , _solvedPayloadHash = pldHash + , _solvedWorkCreationTime = time + , _solvedWorkNonce = nonce + } + +data InvalidSolvedHeader = InvalidSolvedHeader T.Text deriving (Show, Eq, Ord, Generic) deriving anyclass (NFData) instance Exception InvalidSolvedHeader +instance Brief SolvedWork where + brief (SolvedWork cid p a pld t n) = "SolvedWork" + <> ": chain " <> brief cid + <> ", parent " <> brief p + <> ", adj " <> brief a + <> ", payload " <> brief pld + <> ", time " <> sshow t + <> ", nonce " <> sshow n + -- | Extend a Cut with a solved work value. -- -- The function verifies that the solved work actually is a valid extension of @@ -406,47 +600,573 @@ instance Exception InvalidSolvedHeader -- work. -- extend - :: MonadThrow m - => Cut - -> PayloadWithOutputs + :: (MonadThrow m, HasVersion) + => ForkNumber + -> Cut + -> Maybe EncodedPayloadData + -> Maybe EncodedPayloadOutputs + -> WorkParents -> SolvedWork -> m (BlockHeader, Maybe CutHashes) -extend c pwo s = do - (bh, mc) <- extendCut c (_payloadWithOutputsPayloadHash pwo) s +extend targetFork c pld pwo ps s = do + (bh, mc) <- extendCut targetFork c ps s return (bh, toCutHashes bh <$> mc) where toCutHashes bh c' = cutToCutHashes Nothing c' & set cutHashesHeaders (HM.singleton (view blockHash bh) bh) & set cutHashesPayloads - (HM.singleton (view blockPayloadHash bh) (payloadWithOutputsToPayloadData pwo)) + (maybe mempty (HM.singleton (view blockPayloadHash bh)) pld) & set cutHashesLocalPayload - (Just (view blockPayloadHash bh, pwo)) + ((view blockPayloadHash bh,) <$> pwo) -- | For internal use and testing -- extendCut - :: MonadThrow m - => Cut - -> BlockPayloadHash + :: (MonadThrow m, HasVersion) + => ForkNumber + -> Cut + -> WorkParents -> SolvedWork -> m (BlockHeader, Maybe Cut) -extendCut c ph (SolvedWork bh) = do +extendCut targetFork c ps s = do + -- Fail Early: If a `BlockHeader`'s injected Nonce (and thus its POW + -- Hash) is trivially incorrect, reject it. + -- + unless (prop_block_pow bh) + $ throwM $ InvalidSolvedHeader "Invalid POW hash" - -- Fail Early: If a `BlockHeader`'s injected Nonce (and thus its POW - -- Hash) is trivially incorrect, reject it. - -- - unless (prop_block_pow bh) - $ throwM $ InvalidSolvedHeader bh "Invalid POW hash" + -- If the `BlockHeader` is already stale and can't be appended to the + -- best `Cut`, Nothing is returned + -- + (bh,) <$> tryMonotonicCutExtension c bh + where + bh = newHeader targetFork ps s - -- Fail Early: check that the given payload matches the new block. - -- - unless (view blockPayloadHash bh == ph) $ throwM $ InvalidSolvedHeader bh - $ "Invalid payload hash" - <> ". Expected: " <> sshow (view blockPayloadHash bh) - <> ", Got: " <> sshow ph - -- If the `BlockHeader` is already stale and can't be appended to the - -- best `Cut`, Nothing is returned - -- - (bh,) <$> tryMonotonicCutExtension c bh +-- -------------------------------------------------------------------------- -- +-- Tools for Graph Transitions +-- +-- These functions are used to adjust the available chains during construction +-- of new cuts: +-- +-- * 'monotonicCutExtension' and 'tryMonotonicCutExtension': extend the +-- resulting cut with genesis headers of new chains. +-- +-- * 'limitCut': project out chains that don't exist in the result cut. +-- +-- * 'join' and 'applyJoin': add chains from both cuts to the input cuts, so +-- that all chains are available in the join base and can be restored during +-- 'applyJoin'; project out non-existing chains in the result. +-- +-- The graph is determined by the /minimum/ height of the blocks in the cut. +-- +-- The minimum is used to ensure that cuts in a new graph only exist when /all/ +-- blocks are on the new cut. This means the new chains are included only if all +-- old chains have transitioned to the minimum block height of the new graph. + +cutHeadersMinHeight :: HM.HashMap ChainId BlockHeader -> BlockHeight +cutHeadersMinHeight = minimum . fmap (view blockHeight) +{-# INLINE cutHeadersMinHeight #-} + + +-- | The function projects onto the chains available at the minimum block height +-- in input headers. +-- +-- At a graph change chains are considered blocked until "all" chains performed +-- the transition to the new graph. Thus, a block in the new graph has all of +-- its dependencies available. +-- +-- This an internal function. The result is meaningful only if the input headers +-- form a valid cut. In particular, the input must not be empty. +-- +projectChains + :: HasVersion + => HM.HashMap ChainId BlockHeader + -> HM.HashMap ChainId BlockHeader +projectChains m = HM.intersection m + $ HS.toMap + $ chainIdsAt (cutHeadersMinHeight m) +{-# INLINE projectChains #-} + +cutProjectChains :: HasVersion => Cut -> Cut +cutProjectChains c = unsafeMkCut $ projectChains $ _cutHeaders c +{-# INLINE cutProjectChains #-} + +-- | Extend the chains for the graph at the minimum block height of the input +-- headers. If a header for a chain is missing the genesis block header for that +-- chain is added. +-- +-- This an internal function. The result is meaningful only if the input headers +-- form a valid cut. In particular, the input must not be empty. +-- +extendChains + :: HasVersion + => HM.HashMap ChainId BlockHeader + -> HM.HashMap ChainId BlockHeader +extendChains m = HM.union m + $ genesisBlockHeadersAtHeight (cutHeadersMinHeight m) +{-# INLINE extendChains #-} + +-- | This function adds all chains that are available in either of the input +-- headers. It is assumed that both input header maps are contain headers for +-- all chains for the graph at the respective minimum height of the headers. +-- +-- This function is used when dealing with joins that internally compute an +-- intersection on the blocks on all chains, but the goal is to preserve blocks +-- from all chains. +-- +-- This an internal function. The result is meaningful only if the input headers +-- form a valid cut. In particular, the input must not be empty. +-- +joinChains + :: HasVersion + => HM.HashMap ChainId BlockHeader + -> HM.HashMap ChainId BlockHeader + -> (HM.HashMap ChainId BlockHeader, HM.HashMap ChainId BlockHeader) +joinChains a b = (HM.union a c, HM.union b c) + where + c = genesisBlockHeader <$> a <> b +{-# INLINE joinChains #-} + +-- -------------------------------------------------------------------------- -- +-- Extending Cuts + +-- | Extends a Cut monotonically, i.e. the replaced block header is the parent +-- of the added block header. +-- +-- Checks +-- +-- * block header is from the ChainGraph of the Cut +-- * result has valid braiding +-- * result is a cut +-- * update is monotonic +-- +-- This includes a check that inductively maintains 'checkBraidingOfCut'. +-- +-- FIXME: this must conform with 'isBraidingOfCutPair'. Double check that we +-- have test for this or check if the implementation can be shared. +-- +isMonotonicCutExtension + :: (HasCallStack, HasVersion) + => MonadThrow m + => Cut + -> BlockHeader + -> m Bool +isMonotonicCutExtension c h = do + case getCutExtension c (_chainId h) of + Just ext -> do + let cutParent = _cutExtensionParent' ext + let monotonic = view blockParent h == fmap (view blockHash) cutParent + checkBlockHeaderGraph h + return $! monotonic && validBraiding + Nothing -> return False + + where + validBraiding = getAll $ ifoldMap + (\cid -> All . validBraidingCid cid) + (_getBlockHashRecord $ view blockAdjacentHashes h) + + validBraidingCid cid a + | Just b <- c ^? ixg cid = Parent (view blockHash b) == a || view blockParent b == a + | view blockHeight h == genesisHeight cid = a == genesisParentBlockHash cid + | otherwise = error $ T.unpack $ "isMonotonicCutExtension.validBraiding: missing adjacent parent on chain " <> toText cid <> " in cut. " <> encodeToText h + + + +-- | Extend a cut with a block header. Throws 'InvalidCutExtension' if the block +-- header isn't a monotonic cut extension. +-- +monotonicCutExtension + :: (MonadThrow m, HasVersion) + => Cut + -> BlockHeader + -> m Cut +monotonicCutExtension c h = tryMonotonicCutExtension c h >>= \case + Nothing -> throwM $ InvalidCutExtension h + Just x -> return x + +-- | Extend a cut with a block header. Returns 'Nothing' the block header isn't +-- a monotonic cut extension. +-- +tryMonotonicCutExtension + :: (MonadThrow m, HasVersion) + => Cut + -> BlockHeader + -> m (Maybe Cut) +tryMonotonicCutExtension c h = isMonotonicCutExtension c h >>= \case + False -> return Nothing + True -> return $! Just + $! unsafeMkCut + $ extendChains + $ set (ix' (_chainId h)) h + $ _cutHeaders c + +-- -------------------------------------------------------------------------- -- +-- Join + +type DiffItem a = These a a + +type JoinQueue = H.Heap (H.Entry (BlockHeight, ChainId) (NonEmpty BlockHeader)) + +-- | This represents the Join of two cuts in an algorithmically convenient way. +-- +data Join = Join + { _joinBase :: !Cut + -- ^ the base of the join, the largest cut that is contained in both + -- cuts, or when viewed as sets, the intersection. + , _joinQueue :: !JoinQueue + -- ^ a queue of block headers from both cuts that allows construct + -- the join cut from the join base. + } + +-- | This computes the join for cuts across all chains. +-- +-- If you want to compute a join for cuts that include only a subset of all +-- chains. +-- +join + :: (HasVersion) + => WebBlockHeaderDb + -> (DiffItem BlockHeader -> NonEmpty BlockHeader) + -> Cut + -> Cut + -> IO Join +join wdb f = join_ wdb f `on` _cutHeaders + +-- | This merges two maps from ChainIds to BlockHeaders such that the result is +-- a Cut. Note, however, that the resulting cut contains only the chain ids from +-- the intersection of the input maps. +-- +-- NOTE: For this to work as expected make sure that both inputs contain all +-- chains that should be present in the output. +-- +-- Adds genesis blocks for chains that are not yet active. This purpose of this +-- is to make sure that all chains of both inputs are preserved in the join, so +-- that the result of the join contains all chains of the original cuts. +-- Otherwise the join would contain only the intersection of all chains and any +-- information/blocks in the other chains would be lost when applying the join. +-- +join_ + :: (HasVersion) + => WebBlockHeaderDb + -> (DiffItem BlockHeader -> NonEmpty BlockHeader) + -> HM.HashMap ChainId BlockHeader + -> HM.HashMap ChainId BlockHeader + -> IO Join +join_ wdb prioFun a b = do + (base, queue) <- flip runStateT mempty $ do + unsafeJoinBase <- unsafeMkCut <$> HM.traverseWithKey joinChain (HM.intersectionWith (,) a' b') + if cutMixedTransition (cutToCutHashes Nothing unsafeJoinBase) + then + -- mixed transition cuts cannot be extended safely. so, we push back the + -- join base in that case, until it's not post-transition on any chains. + limitCut_ wdb (lastGraphChangeInCut $ cutToCutHashes Nothing unsafeJoinBase) unsafeJoinBase + else + return unsafeJoinBase + + return $! Join base queue + where + (a', b') = joinChains a b + + joinChain + :: ChainId + -> (BlockHeader, BlockHeader) + -> StateT JoinQueue IO BlockHeader + joinChain cid (x, y) = do + db <- getWebBlockHeaderDb wdb cid + branchDiff_ db x y + & S.hoist liftIO + & S.mapM_ (enqueueHeaders . prioFun) + +enqueueHeaders :: NonEmpty BlockHeader -> StateT JoinQueue IO () +enqueueHeaders hs = + modify' (\q -> + H.insert (H.Entry (height, chain) hs) q + ) + where + height = view blockHeight (NE.head hs) + chain = view chainId (NE.head hs) + +-- This can't fail because of missing dependencies. It can't fail because +-- of conflict. +-- +-- Non-existing chains are stripped from the result. +-- +applyJoin :: (MonadThrow m, HasVersion) => Join -> m Cut +applyJoin m = cutProjectChains + <$> foldlMOf (folded . folded . folded) + (\c b -> + fromMaybe c <$> tryMonotonicCutExtension c b) + (_joinBase m) + (_joinQueue m) + +-- | Merge two Cuts. If at least one of the input cuts had a valid braiding the +-- result is guaranteed to have a valid braiding for all blocks included in cut +-- and their ancestors. +-- +-- This is because the merge starts with the intersection of both cuts, using +-- 'branchDiff_' on each chain, and constructs the merge cut using +-- 'tryMonotonicCutExtension'. If one of the inputs is correctly braided, so is +-- the intersection. 'tryMonotonicCutExtension' is guaranteed to maintain that +-- property. +-- +-- Chains that aren't yet initialized are included in the join and later +-- stripped from the result. +-- +-- If you want to compute a join for cuts that include only a subset of all +-- chains, make sure that @genesisBlockHeaders v@ only returns genesis headers +-- for those chains that you care about. +-- +-- This invariant is required during a chain graph transition to avoid producing +-- an invalid cut that straddles the transition line: A cut that is ahead or +-- equal in height on all chains and ahead in height on at least one chain must +-- have a higher total weight. +-- +joinIntoHeavier + :: HasVersion + => WebBlockHeaderDb + -> Cut + -> Cut + -> IO Cut +joinIntoHeavier wdb = joinIntoHeavier_ wdb `on` _cutHeaders + +-- | Chains that aren't yet initialized are included in the join and later +-- stripped from the result. +-- +-- If you want to compute a join for cuts that include only a subset of all +-- chains, make sure that @genesisBlockHeaders v@ only returns genesis headers +-- for those chains that you care about. +-- +joinIntoHeavier_ + :: HasVersion + => WebBlockHeaderDb + -> HM.HashMap ChainId BlockHeader + -> HM.HashMap ChainId BlockHeader + -> IO Cut +joinIntoHeavier_ wdb a b = do + m <- join_ wdb (prioritizeHeavier_ a b) a b + applyJoin m + +-- -------------------------------------------------------------------------- -- +-- Limit Cut Hashes By Height + +-- | Finds a `Cut` that is a predecessor of the given one, and that has a block +-- height that is smaller or equal to the given height. Also, returns a queue +-- ordered by height of all of the blocks that lie between the resulting cut and +-- the input cut. +-- +-- Always iterates over every block being removed from the input cut. For a +-- faster version, see `limitCut`. +limitCut_ + :: (HasCallStack, HasVersion) + => WebBlockHeaderDb + -> BlockHeight + -> Cut + -> StateT JoinQueue IO Cut +limitCut_ wdb h c + | all (\bh -> h >= view blockHeight bh) (view cutHeaders c) = + return c + | otherwise = do + hdrs <- itraverse go $ view cutHeaders c + return $! unsafeMkCut $ projectChains $ HM.mapMaybe id hdrs + where + go :: ChainId -> BlockHeader -> StateT JoinQueue IO (Maybe BlockHeader) + go cid bh = do + if h < genesisBlockHeight cid + then return Nothing + else if h >= view blockHeight bh + then return (Just bh) + else do + !db <- getWebBlockHeaderDb wdb cid + ancestor <- + S.mapM_ (enqueueHeaders . NE.singleton) $ + -- this is safe because it's guaranteed that the requested rank is + -- smaller then the block height of the argument + getAncestors db (min (int $ view blockHeight bh) (int h)) (ancestors db (key bh)) + return (Just ancestor) + getAncestors db b strm = liftIO (S.next strm) >>= \case + Left () -> error "reached end" + Right (anc, strm') + | rank anc == b -> + return anc + | otherwise -> do + S.yield anc + getAncestors db b strm' + +-- | Find a `Cut` that is a predecessor of the given one, and that has a block +-- height that is smaller or equal the given height. +-- +-- If the requested limit is larger or equal to the current height, the given +-- cut is returned. +-- +-- Otherwise, the predecessor of the given cut at the given height on each chain +-- is returned. +-- +-- See the performance notes for `seekAncestor`. +limitCut + :: (HasCallStack, HasVersion) + => WebBlockHeaderDb + -> BlockHeight + -- ^ upper bound for the block height of each chain. This is not a tight + -- bound. + -> Cut + -> IO Cut +limitCut wdb h c + | all (\bh -> h >= view blockHeight bh) (view cutHeaders c) = + return c + | otherwise = do + hdrs <- itraverse go $ view cutHeaders c + return $! unsafeMkCut $ projectChains $ HM.mapMaybe id hdrs + where + + go :: ChainId -> BlockHeader -> IO (Maybe BlockHeader) + go cid bh = do + if h >= view blockHeight bh + then return (Just bh) + else do + !db <- getWebBlockHeaderDb wdb cid + seekAncestor db bh (min (int $ view blockHeight bh) (int h)) + -- this is safe because it's guaranteed that the requested rank is + -- smaller then the block height of the argument + +-- | Find a `Cut` that is a predecessor of the given one, and that has a block +-- height that is as low as possible while not exceeding the given height and +-- including all of the chains in the given cut. +-- +-- If the requested limit is larger or equal to the current height, the given +-- cut is returned. +-- +tryLimitCut + :: (HasCallStack, HasVersion) + => WebBlockHeaderDb + -> BlockHeight + -- upper bound for the block height of each chain. This is not a tight bound. + -> Cut + -> IO Cut +tryLimitCut wdb h c + | all (\bh -> h >= view blockHeight bh) (view cutHeaders c) = + return c + | otherwise = do + hdrs <- itraverse go $ view cutHeaders c + return $! unsafeMkCut hdrs + where + go :: ChainId -> BlockHeader -> IO BlockHeader + go cid bh = do + if h >= view blockHeight bh + then return bh + else do + !db <- getWebBlockHeaderDb wdb cid + -- this is safe because it's guaranteed that the requested rank is + -- smaller then the block height of the argument + let ancestorHeight = min (int $ view blockHeight bh) (int h) + if ancestorHeight <= fromIntegral (genesisHeight cid) + then return $ genesisBlockHeader cid + else fromJuste <$> seekAncestor db bh ancestorHeight + +-- | The resulting headers are valid cut headers only if the input headers are +-- valid cut headers, too. The inverse is not true. +-- +limitCutHeaders + :: (HasCallStack, HasVersion) + => WebBlockHeaderDb + -> BlockHeight + -- ^ upper bound for the block height of each chain. This is not a tight bound. + -> HM.HashMap ChainId BlockHeader + -> IO (HM.HashMap ChainId BlockHeader) +limitCutHeaders whdb h ch = _cutHeaders <$> limitCut whdb h (unsafeMkCut ch) + +lastGraphChangeInCut :: HasVersion => CutHashes -> BlockHeight +lastGraphChangeInCut c = + maximum $ + lastGraphChange . _rankedHeight <$> (_cutHashes c) + +-- | This is a mixed transition cut, and thus has no unique chain graph. Such a +-- cut may have invalid braiding according to *either* the pre- or post- +-- transition graph. +cutMixedTransition :: HasVersion => CutHashes -> Bool +cutMixedTransition c = + let + lgc = lastGraphChangeInCut c + in + any ((< lgc) ._rankedHeight) (_cutHashes c) + +prioritizeHeavier :: Cut -> Cut -> DiffItem BlockHeader -> NonEmpty BlockHeader +prioritizeHeavier = prioritizeHeavier_ `on` _cutHeaders + +-- | Note: consider the weight of the recursive dependencies for the +-- priority of a block header. For that we would have to annotate the +-- block headers before putting them in the queue. To traverse only once, +-- we'd have to traverse the zipped cuts by height and not by chainid, which +-- could easily be done by merging/zipping the branch-diff streams. +-- +prioritizeHeavier_ + :: Foldable f + => Eq (f BlockHeader) + => f BlockHeader + -> f BlockHeader + -> DiffItem BlockHeader + -> NonEmpty BlockHeader +prioritizeHeavier_ a b = f + where + heaviest = maxBy (compare `on` weight) a b + + f (This bh) = NE.singleton bh + f (That bh) = NE.singleton bh + f (These bha bhb ) + | heaviest == a = bha NE.:| [bhb] + | otherwise = bhb NE.:| [bha] + + weight c = + ( sumOf (folded . blockWeight) c + -- first sort by weight + , sumOf (folded . blockHeight) c + -- for scenarios with trivial difficulty height is added as + -- secondary metrics + + -- NOTE: + -- We could consider prioritizing the latest block in the cut here as + -- first-level tie breaker. That would further incentivize miners to use + -- a block creation time that is close to the real world time (note that + -- blocks from the future are rejected, so post-dating blocks is risky + -- for miners.) + + , List.sort (toList c) + -- the block hashes of the cut are added as tie breaker in order + -- to guarantee commutativity. + -- + ) + +-- -------------------------------------------------------------------------- -- +-- Cut Meet + +-- | Intersection of cuts +-- +meet + :: HasVersion + => WebBlockHeaderDb + -> Cut + -> Cut + -> IO Cut +meet wdb a b = do + !r <- imapM f $ HM.intersectionWith (,) (_cutHeaders a) (_cutHeaders b) + return $! unsafeMkCut r + where + f !cid (!x, !y) = do + db <- getWebBlockHeaderDb wdb cid + forkEntry db x y + +forkDepth + :: HasVersion + => WebBlockHeaderDb + -> Cut + -> Cut + -> IO Natural +forkDepth wdb a b = do + m <- meet wdb a b + return $! int $ max (maxDepth m a) (maxDepth m b) + where + maxDepth l u = maximum $ HM.intersectionWith + (\x y -> view blockHeight y - view blockHeight x) + (_cutHeaders l) + (_cutHeaders u) diff --git a/src/Chainweb/Cut/CutHashes.hs b/src/Chainweb/Cut/CutHashes.hs index f1b3246480..df24059f3f 100644 --- a/src/Chainweb/Cut/CutHashes.hs +++ b/src/Chainweb/Cut/CutHashes.hs @@ -41,10 +41,8 @@ module Chainweb.Cut.CutHashes , HasCutId(..) -- * CutHashes -, BlockHashWithHeight(..) , CutHashes(..) , cutHashes -, cutHashesChainwebVersion , cutHashesId , cutOrigin , cutHashesWeight @@ -63,7 +61,7 @@ module Chainweb.Cut.CutHashes import Control.Arrow import Control.DeepSeq import Control.Lens (Getter, Lens', makeLenses, to, view) -import Control.Monad ((<$!>)) +import Control.Monad ((<$!>), unless) import Control.Monad.Catch import qualified Crypto.Hash as C @@ -96,16 +94,14 @@ import Chainweb.BlockHeight import Chainweb.BlockWeight import Chainweb.ChainId import Chainweb.Cut +import Chainweb.PayloadProvider(EncodedPayloadData(..), EncodedPayloadOutputs(..)) +import Chainweb.Ranked +import Chainweb.Storage.Table import Chainweb.Utils import Chainweb.Utils.Serialization import Chainweb.Version -import Chainweb.Payload - -import Chainweb.Storage.Table - import P2P.Peer -import Chainweb.Version.Registry (fabricateVersionWithName) -- -------------------------------------------------------------------------- -- -- CutId @@ -225,32 +221,6 @@ instance HasCutId CutId where -- -------------------------------------------------------------------------- -- -- Cut Hashes -data BlockHashWithHeight = BlockHashWithHeight - { _bhwhHeight :: !BlockHeight - , _bhwhHash :: !BlockHash - } - deriving (Show, Eq, Ord, Generic) - deriving anyclass (NFData) - -blockHashWithHeightProperties :: KeyValue e kv => BlockHashWithHeight -> [kv] -blockHashWithHeightProperties o = - [ "height" .= _bhwhHeight o - , "hash" .= _bhwhHash o - ] -{-# INLINE blockHashWithHeightProperties #-} - -instance ToJSON BlockHashWithHeight where - toJSON = object . blockHashWithHeightProperties - toEncoding = pairs . mconcat . blockHashWithHeightProperties - {-# INLINE toJSON #-} - {-# INLINE toEncoding #-} - -instance FromJSON BlockHashWithHeight where - parseJSON = withObject "HashWithHeight" $ \o -> BlockHashWithHeight - <$> o .: "height" - <*> o .: "hash" - {-# INLINE parseJSON #-} - -- | This data structure is used to inform other components and chainweb nodes -- about new cuts along with some properties of the cut. -- @@ -260,19 +230,38 @@ instance FromJSON BlockHashWithHeight where -- Optionally, a node may attach the 'PayloadData' and/or the 'BlockHeader' for -- some of the block of the 'Cut'. -- +-- FIXME: +-- We should not misuse the cut hashes structure for passing around payloads. +-- Instead the payload provider should cache payloads for locally mined blocks +-- for a while (e.g. until the block height advanced beyond the height of the +-- payload). +-- +-- The main benefit of this data is that it allows to push the payload of new +-- blocks along with the respective cut, saving up to 50% connection overhead +-- and also reducing latencies significantly. Currently, we do not do this, +-- though. +-- data CutHashes = CutHashes - { _cutHashes :: !(HM.HashMap ChainId BlockHashWithHeight) + { _cutHashes :: !(HM.HashMap ChainId RankedBlockHash) , _cutOrigin :: !(Maybe PeerInfo) -- ^ 'Nothing' is used for locally mined Cuts , _cutHashesWeight :: !BlockWeight , _cutHashesHeight :: !CutHeight - , _cutHashesChainwebVersion :: ChainwebVersion , _cutHashesId :: !CutId , _cutHashesHeaders :: !(HM.HashMap BlockHash BlockHeader) -- ^ optional block headers - , _cutHashesPayloads :: !(HM.HashMap BlockPayloadHash PayloadData) + , _cutHashesPayloads :: !(HM.HashMap BlockPayloadHash EncodedPayloadData) -- ^ optional block payloads - , _cutHashesLocalPayload :: !(Maybe (BlockPayloadHash, PayloadWithOutputs)) + -- + -- This is used for locally mined cuts for which the payload is not + -- available otherwise. + -- + -- TODO: This data should actually be ranked. For now we obtain the rank + -- from entries in the _cutHashesHeader field and reject the payload if + -- we do not have the corresponding header. Alternatively we could + -- also use an unranked candidate store, but that would make pruning + -- more difficult. + , _cutHashesLocalPayload :: !(Maybe (BlockPayloadHash, EncodedPayloadOutputs)) -- ^ optional, and unused except for error reporting, outputs -- Note: we cannot trust outputs from other nodes! } @@ -284,7 +273,7 @@ makeLenses ''CutHashes -- | Complexity is linear in the number of chains -- _cutHashesMaxHeight :: CutHashes -> BlockHeight -_cutHashesMaxHeight = maximum . fmap _bhwhHeight . _cutHashes +_cutHashesMaxHeight = maximum . fmap _rankedHeight . _cutHashes {-# INLINE _cutHashesMaxHeight #-} cutHashesMaxHeight :: Getter CutHashes BlockHeight @@ -294,7 +283,7 @@ cutHashesMaxHeight = to _cutHashesMaxHeight -- | Complexity is linear in the number of chains -- _cutHashesMinHeight :: CutHashes -> BlockHeight -_cutHashesMinHeight = minimum . fmap _bhwhHeight . _cutHashes +_cutHashesMinHeight = minimum . fmap _rankedHeight . _cutHashes {-# INLINE _cutHashesMinHeight #-} cutHashesMinHeight :: Getter CutHashes BlockHeight @@ -315,13 +304,14 @@ instance Ord CutHashes where compare = compare `on` (_cutHashesWeight &&& _cutHashesId) {-# INLINE compare #-} -cutHashesProperties :: forall e kv . KeyValue e kv => CutHashes -> [kv] +cutHashesProperties + :: forall e kv . KeyValue e kv => HasVersion => CutHashes -> [kv] cutHashesProperties c = [ "hashes" .= _cutHashes c , "origin" .= _cutOrigin c , "weight" .= _cutHashesWeight c , "height" .= _cutHashesHeight c - , "instance" .= _versionName (_cutHashesChainwebVersion c) + , "instance" .= _versionName implicitVersion , "id" .= _cutHashesId c ] <> ifNotEmpty "headers" cutHashesHeaders @@ -337,34 +327,37 @@ cutHashesProperties c = | x <- view l c, not (HM.null x) = [ s .= x ] | otherwise = mempty -instance ToJSON CutHashes where +instance HasVersion => ToJSON CutHashes where toJSON = object . cutHashesProperties toEncoding = pairs . mconcat . cutHashesProperties {-# INLINE toJSON #-} {-# INLINE toEncoding #-} -instance FromJSON CutHashes where - parseJSON = withObject "CutHashes" $ \o -> CutHashes - <$> o .: "hashes" - <*> o .: "origin" - <*> o .: "weight" - <*> o .: "height" - <*> (fabricateVersionWithName <$> o .: "instance") - <*> o .: "id" - <*> o .:? "headers" .!= mempty - <*> o .:? "payloads" .!= mempty - <*> pure Nothing +instance HasVersion => FromJSON CutHashes where + parseJSON = withObject "CutHashes" $ \o -> do + v <- o .: "instance" + unless (v == _versionName implicitVersion) $ fail $ T.unpack $ + "incorrect version: expected " <> getChainwebVersionName (_versionName implicitVersion) <> + ", but got " <> getChainwebVersionName v + CutHashes + <$> o .: "hashes" + <*> o .: "origin" + <*> o .: "weight" + <*> o .: "height" + <*> o .: "id" + <*> o .:? "headers" .!= mempty + <*> o .:? "payloads" .!= mempty + <*> pure Nothing -- | Compute a 'CutHashes' structure from a 'Cut'. The result doesn't include -- any block headers or payloads. -- cutToCutHashes :: Maybe PeerInfo -> Cut -> CutHashes cutToCutHashes p c = CutHashes - { _cutHashes = (\x -> BlockHashWithHeight (view blockHeight x) (view blockHash x)) <$> _cutMap c + { _cutHashes = view rankedBlockHash <$> _cutMap c , _cutOrigin = p , _cutHashesWeight = _cutWeight c , _cutHashesHeight = _cutHeight c - , _cutHashesChainwebVersion = _chainwebVersion c , _cutHashesId = _cutId c , _cutHashesHeaders = mempty , _cutHashesPayloads = mempty diff --git a/src/Chainweb/CutDB.hs b/src/Chainweb/CutDB.hs index 9960da5921..57e7902eff 100644 --- a/src/Chainweb/CutDB.hs +++ b/src/Chainweb/CutDB.hs @@ -8,16 +8,17 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE ImportQualifiedPost #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE TupleSections #-} -- | -- Module: Chainweb.CutDB @@ -38,7 +39,6 @@ module Chainweb.CutDB , cutDbParamsInitialHeightLimit , cutDbParamsFetchTimeout , cutDbParamsAvgBlockHeightPruningDepth -, cutDbParamsPruningFrequency , cutDbParamsReadOnly , defaultCutDbParams , farAheadThreshold @@ -53,13 +53,13 @@ module Chainweb.CutDB , pruneCuts , cutDbWebBlockHeaderDb , cutDbBlockHeaderDb -, cutDbPayloadDb -, cutDbPactService +, cutDbPayloadProviders , cut , _cut , _cutStm , cutStm , awaitNewCut +, awaitNewCutStm , awaitNewCutByChainId , awaitNewBlock , awaitNewBlockStm @@ -79,7 +79,6 @@ module Chainweb.CutDB -- * Membership Queries , member , memberOfHeader -, memberOfM -- * Some CutDb , CutDbT(..) @@ -91,74 +90,69 @@ module Chainweb.CutDB , getQueueStats ) where +import Chainweb.BlockHash +import Chainweb.BlockHeader +import Chainweb.BlockHeaderDB.Internal +import Chainweb.BlockHeight +import Chainweb.BlockWeight +import Chainweb.ChainId +import Chainweb.Cut +import Chainweb.Cut.Create +import Chainweb.Cut.CutHashes +import Chainweb.Graph +import Chainweb.Logger +import Chainweb.PayloadProvider +import Chainweb.Ranked +import Chainweb.Storage.Table +import Chainweb.Storage.Table.HashMap +import Chainweb.Storage.Table.RocksDB +import Chainweb.Sync.ForkInfo +import Chainweb.Sync.WebBlockHeaderStore +import Chainweb.TreeDB +import Chainweb.Utils hiding (Codec, check) +import Chainweb.Utils.Serialization +import Chainweb.Version +import Chainweb.Version.Utils +import Chainweb.WebBlockHeaderDB import Control.Applicative import Control.Concurrent.Async import Control.Concurrent.STM.TVar import Control.DeepSeq -import Control.Exception -import Control.Lens hiding ((:>)) +import Control.Exception (asyncExceptionFromException, asyncExceptionToException) +import Control.Exception.Safe +import Control.Lens hiding ((:>), (.=)) import Control.Monad -import Control.Monad.Catch (throwM) import Control.Monad.IO.Class import Control.Monad.Morph import Control.Monad.STM - -import Data.Aeson (ToJSON) +import Control.Monad.Trans.Maybe +import Control.Monad.Trans.Resource hiding (throwM) +import Data.Aeson (ToJSON, Value, object, (.=)) +import Data.Either (partitionEithers) import Data.Foldable import Data.Function import Data.Functor.Of -import qualified Data.HashMap.Strict as HM -import qualified Data.HashSet as HS +import Data.HashMap.Strict qualified as HM +import Data.HashSet qualified as HS import Data.LogMessage import Data.Maybe import Data.Monoid import Data.Ord +import Data.PQueue +import Data.TaskMap qualified as TM import Data.Text (Text) -import qualified Data.Text as T +import Data.Text qualified as T import Data.These - import GHC.Generics hiding (to) - import Numeric.Natural - +import P2P.TaskQueue import Prelude hiding (lookup) - -import qualified Streaming.Prelude as S - +import Streaming.Prelude qualified as S import System.LogLevel -import qualified System.Random.MWC as Prob import System.Timeout - --- internal modules - -import Chainweb.BlockHash -import Chainweb.BlockHeader -import Chainweb.BlockHeight -import Chainweb.BlockWeight -import Chainweb.BlockHeaderDB.Internal -import Chainweb.ChainId -import Chainweb.Cut -import Chainweb.Cut.CutHashes -import Chainweb.Graph -import Chainweb.Payload.PayloadStore -import Chainweb.Sync.WebBlockHeaderStore -import Chainweb.TreeDB -import Chainweb.Utils hiding (Codec, check) -import Chainweb.Utils.Serialization -import Chainweb.Version -import Chainweb.Version.Utils -import Chainweb.WebBlockHeaderDB -import Chainweb.WebPactExecutionService - -import Chainweb.Storage.Table -import Chainweb.Storage.Table.HashMap -import Chainweb.Storage.Table.RocksDB -import Data.PQueue - -import qualified Data.TaskMap as TM -import P2P.TaskQueue - import Utils.Logging.Trace +import Chainweb.ChainValue +import P2P.Utils -- -------------------------------------------------------------------------- -- -- Cut DB Configuration @@ -174,8 +168,6 @@ data CutDbParams = CutDbParams , _cutDbParamsAvgBlockHeightPruningDepth :: !BlockHeight -- ^ How many block heights' worth of cuts should we keep around? -- (how far back do we expect that a fork can happen) - , _cutDbParamsPruningFrequency :: !BlockHeight - -- ^ After how many blocks do we prune cuts (on average)? , _cutDbParamsReadOnly :: !Bool -- ^ Should the cut store be read-only? -- Enabled during replay-only mode. @@ -185,8 +177,8 @@ data CutDbParams = CutDbParams makeLenses ''CutDbParams -defaultCutDbParams :: ChainwebVersion -> Int -> CutDbParams -defaultCutDbParams v ft = CutDbParams +defaultCutDbParams :: HasVersion => Int -> CutDbParams +defaultCutDbParams ft = CutDbParams { _cutDbParamsInitialCutFile = Nothing , _cutDbParamsBufferSize = max 10 $ (order g ^ (2 :: Int)) * diameter g , _cutDbParamsLogLevel = Warn @@ -194,12 +186,22 @@ defaultCutDbParams v ft = CutDbParams , _cutDbParamsFetchTimeout = ft , _cutDbParamsInitialHeightLimit = Nothing , _cutDbParamsFastForwardHeightLimit = Nothing + -- really this is 2500 minutes, or ~1.7 days, which gives us some time to + -- recover from long-lived forks. , _cutDbParamsAvgBlockHeightPruningDepth = 5000 - , _cutDbParamsPruningFrequency = 10000 , _cutDbParamsReadOnly = False } where - g = _chainGraph (v, maxBound @BlockHeight) + g = chainGraphAt (maxBound @BlockHeight) + +newtype CutPruningState = CutPruningState + { cutPruningStateLatestWrittenHeight :: BlockHeight + } + +initialCutPruningState :: Cut -> CutPruningState +initialCutPruningState initialCut = CutPruningState + { cutPruningStateLatestWrittenHeight = view cutMaxHeight initialCut + } -- | We ignore cuts that are two far ahead of the current best cut that we have. -- There are two reasons for this: @@ -233,7 +235,7 @@ farAheadThreshold = 20 -- -------------------------------------------------------------------------- -- -- CutHashes Table -cutHashesTable :: RocksDb -> Casify RocksDbTable CutHashes +cutHashesTable :: HasVersion => RocksDb -> Casify RocksDbTable CutHashes cutHashesTable rdb = Casify $ newTable rdb valueCodec keyCodec ["CutHashes"] where keyCodec = Codec @@ -256,55 +258,43 @@ instance Exception CutDbStopped where -- | This is a singleton DB that contains the latest chainweb cut as only entry. -- -data CutDb tbl = CutDb +data CutDb l = CutDb { _cutDbCut :: !(TVar Cut) , _cutDbQueue :: !(PQueue CutHashes) , _cutDbAsync :: !(Async ()) , _cutDbLogFunction :: !LogFunction - , _cutDbHeaderStore :: !WebBlockHeaderStore - , _cutDbPayloadStore :: !(WebBlockPayloadStore tbl) + , _cutDbHeaderStore :: !(WebBlockHeaderStore l) + , _cutDbPayloadProviders :: !(ChainMap ConfiguredPayloadProvider) , _cutDbCutStore :: !(Casify RocksDbTable CutHashes) , _cutDbQueueSize :: !Natural , _cutDbReadOnly :: !Bool , _cutDbFastForwardHeightLimit :: !(Maybe BlockHeight) } -instance HasChainwebVersion (CutDb tbl) where - _chainwebVersion = _chainwebVersion . _cutDbHeaderStore - {-# INLINE _chainwebVersion #-} - -cutDbPayloadDb :: Getter (CutDb tbl) (PayloadDb tbl) -cutDbPayloadDb = to $ _webBlockPayloadStoreCas . _cutDbPayloadStore -{-# INLINE cutDbPayloadDb #-} - -cutDbPactService :: Getter (CutDb tbl) WebPactExecutionService -cutDbPactService = to $ _webBlockPayloadStorePact . _cutDbPayloadStore -{-# INLINE cutDbPactService #-} - -cutDbPayloadStore :: Getter (CutDb tbl) (WebBlockPayloadStore tbl) -cutDbPayloadStore = to _cutDbPayloadStore -{-# INLINE cutDbPayloadStore #-} +cutDbPayloadProviders :: Getter (CutDb l) (ChainMap ConfiguredPayloadProvider) +cutDbPayloadProviders = to _cutDbPayloadProviders +{-# INLINE cutDbPayloadProviders #-} -- We export the 'WebBlockHeaderDb' read-only -- -cutDbWebBlockHeaderDb :: Getter (CutDb tbl) WebBlockHeaderDb +cutDbWebBlockHeaderDb :: Getter (CutDb l) WebBlockHeaderDb cutDbWebBlockHeaderDb = to $ _webBlockHeaderStoreCas . _cutDbHeaderStore {-# INLINE cutDbWebBlockHeaderDb #-} -cutDbWebBlockHeaderStore :: Getter (CutDb tbl) WebBlockHeaderStore +cutDbWebBlockHeaderStore :: Getter (CutDb l) (WebBlockHeaderStore l) cutDbWebBlockHeaderStore = to _cutDbHeaderStore {-# INLINE cutDbWebBlockHeaderStore #-} -- | Access the blockerheaderdb via the cutdb for a given chain id -- -cutDbBlockHeaderDb :: HasChainId cid => cid -> Fold (CutDb tbl) BlockHeaderDb +cutDbBlockHeaderDb :: HasChainId cid => cid -> Fold (CutDb l) BlockHeaderDb cutDbBlockHeaderDb cid = cutDbWebBlockHeaderDb . ixg (_chainId cid) -- | Get the current 'Cut', which represent the latest chainweb state. -- -- This the main API method of chainweb-consensus. -- -_cut :: CutDb tbl -> IO Cut +_cut :: CutDb l -> IO Cut _cut = readTVarIO . _cutDbCut {-# INLINE _cut #-} @@ -312,50 +302,56 @@ _cut = readTVarIO . _cutDbCut -- -- This the main API method of chainweb-consensus. -- -cut :: Getter (CutDb tbl) (IO Cut) +cut :: Getter (CutDb l) (IO Cut) cut = to _cut -addCutHashes :: CutDb tbl -> CutHashes -> IO () +addCutHashes :: CutDb l -> CutHashes -> IO () addCutHashes db = pQueueInsert (_cutDbQueue db) -- | An 'STM' version of '_cut'. -- -- @_cut db@ is generally more efficient than as @atomically (_cut db)@. -- -_cutStm :: CutDb tbl -> STM Cut +_cutStm :: CutDb l -> STM Cut _cutStm = readTVar . _cutDbCut -- | An 'STM' version of 'cut'. -- -- @_cut db@ is generally more efficient than as @atomically (_cut db)@. -- -cutStm :: Getter (CutDb tbl) (STM Cut) +cutStm :: Getter (CutDb l) (STM Cut) cutStm = to _cutStm -- | A common idiom to spin while waiting for a guaranteed new `Cut`, different -- from the given one. -- -awaitNewCut :: CutDb tbl -> Cut -> IO Cut -awaitNewCut cdb c = atomically $ do +awaitNewCutStm :: CutDb l -> Cut -> STM Cut +awaitNewCutStm cdb c = do c' <- _cutStm cdb when (c' == c) retry return c' +-- | A common idiom to spin while waiting for a guaranteed new `Cut`, different +-- from the given one. +-- +awaitNewCut :: CutDb l -> Cut -> IO Cut +awaitNewCut cdb c = atomically $ awaitNewCutStm cdb c + -- | As in `awaitNewCut`, but only updates when the specified `ChainId` has -- grown. -- -awaitNewCutByChainId :: CutDb tbl -> ChainId -> Cut -> IO Cut +awaitNewCutByChainId :: CutDb l -> ChainId -> Cut -> IO Cut awaitNewCutByChainId cdb cid c = atomically $ awaitNewCutByChainIdStm cdb cid c {-# INLINE awaitNewCutByChainId #-} -- | As in `awaitNewCut`, but only updates when the header at the specified -- `ChainId` has changed, and only returns that new header. -awaitNewBlock :: CutDb tbl -> ChainId -> BlockHash -> IO BlockHeader +awaitNewBlock :: CutDb l -> ChainId -> BlockHash -> IO BlockHeader awaitNewBlock cdb cid bHash = atomically $ awaitNewBlockStm cdb cid bHash -- | As in `awaitNewCut`, but only updates when the header at the specified -- `ChainId` has changed, and only returns that new header. -awaitNewBlockStm :: CutDb tbl -> ChainId -> BlockHash -> STM BlockHeader +awaitNewBlockStm :: CutDb l -> ChainId -> BlockHash -> STM BlockHeader awaitNewBlockStm cdb cid bHash = do c <- _cutStm cdb case HM.lookup cid (_cutMap c) of @@ -365,7 +361,7 @@ awaitNewBlockStm cdb cid bHash = do -- | As in `awaitNewCut`, but only updates when the specified `ChainId` has -- grown. -- -awaitNewCutByChainIdStm :: CutDb tbl -> ChainId -> Cut -> STM Cut +awaitNewCutByChainIdStm :: CutDb l -> ChainId -> Cut -> STM Cut awaitNewCutByChainIdStm cdb cid c = do c' <- _cutStm cdb let !b0 = HM.lookup cid $ _cutMap c @@ -374,40 +370,38 @@ awaitNewCutByChainIdStm cdb cid c = do return c' pruneCuts - :: LogFunction - -> ChainwebVersion + :: HasVersion + => LogFunction -> CutDbParams -> BlockHeight -> Casify RocksDbTable CutHashes -> IO () -pruneCuts logfun v conf curAvgBlockHeight cutHashesStore = do +pruneCuts logfun conf curAvgBlockHeight cutHashesStore = do let avgBlockHeightPruningDepth = _cutDbParamsAvgBlockHeightPruningDepth conf let pruneCutHeight = - avgCutHeightAt v (curAvgBlockHeight - min curAvgBlockHeight avgBlockHeightPruningDepth) + avgCutHeightAt (curAvgBlockHeight - min curAvgBlockHeight avgBlockHeightPruningDepth) logfun @T.Text Info $ "pruning CutDB before cut height " <> T.pack (show pruneCutHeight) + -- deleteRange is constant time in rocksdb, it just inserts a tombstone. + -- either way, we will use constant space for cuts. deleteRangeRocksDb (unCasify cutHashesStore) (Nothing, Just (pruneCutHeight, 0, maxBound :: CutId)) - -- compactRangeRocksDb waits for compaction to complete which takes a while - void $ async $ - compactRangeRocksDb (unCasify cutHashesStore) - (Nothing, Just (pruneCutHeight, 0, maxBound :: CutId)) -cutDbQueueSize :: CutDb tbl -> IO Natural +cutDbQueueSize :: CutDb l -> IO Natural cutDbQueueSize = pQueueSize . _cutDbQueue withCutDb - :: CanPayloadCas tbl + :: HasVersion + => Logger logger => CutDbParams - -> LogFunction - -> WebBlockHeaderStore - -> WebBlockPayloadStore tbl + -> logger + -> WebBlockHeaderStore logger + -> ChainMap ConfiguredPayloadProvider -> Casify RocksDbTable CutHashes - -> (forall t' . CanReadablePayloadCas t' => CutDb t' -> IO a) - -> IO a -withCutDb config logfun headerStore payloadStore cutHashesStore a - = bracket - (startCutDb config logfun headerStore payloadStore cutHashesStore) - stopCutDb a + -> ResourceT IO (Either Cut (CutDb logger)) +withCutDb config logger headerStore providers cutHashesStore + = snd <$> allocate + (startCutDb config logger headerStore providers cutHashesStore) + (traverse_ stopCutDb) -- | Start a CutDB. This loads the initial cut from the database (falling back -- to the configured initial cut loading fails) and starts the cut validation @@ -419,63 +413,134 @@ withCutDb config logfun headerStore payloadStore cutHashesStore a -- read-only version of the payload store. -- startCutDb - :: CanPayloadCas tbl + :: Logger logger + => HasVersion => CutDbParams - -> LogFunction - -> WebBlockHeaderStore - -> WebBlockPayloadStore tbl + -> logger + -> WebBlockHeaderStore logger + -> ChainMap ConfiguredPayloadProvider -> Casify RocksDbTable CutHashes - -> IO (CutDb tbl) -startCutDb config logfun headerStore payloadStore cutHashesStore = mask_ $ do + -> IO (Either Cut (CutDb logger)) +startCutDb config logger headerStore providers cutHashesStore = mask_ $ do logg Debug "obtain initial cut" initialCut <- readInitialCut + recoveryCut <- synchronizeProviders logger wbhdb providers initialCut unless (_cutDbParamsReadOnly config) $ deleteRangeRocksDb (unCasify cutHashesStore) + -- intentionally don't delete up to recovery cut, the initial cut could be useful later (Just $ over _1 succ $ casKey $ cutToCutHashes Nothing initialCut, Nothing) - cutVar <- newTVarIO initialCut - c <- readTVarIO cutVar - logg Info $ T.unlines $ - "got initial cut:" : [" " <> block | block <- cutToTextShort c] - queue <- newEmptyPQueue _cutHashesWeight _cutHashesId (Just $ _cutDbParamsBufferSize config) - cutAsync <- asyncWithUnmask $ \u -> u $ processor queue cutVar - logg Debug "CutDB started" - return CutDb - { _cutDbCut = cutVar - , _cutDbQueue = queue - , _cutDbAsync = cutAsync - , _cutDbLogFunction = logfun - , _cutDbHeaderStore = headerStore - , _cutDbPayloadStore = payloadStore - , _cutDbQueueSize = _cutDbParamsBufferSize config - , _cutDbCutStore = cutHashesStore - , _cutDbReadOnly = _cutDbParamsReadOnly config - , _cutDbFastForwardHeightLimit = _cutDbParamsFastForwardHeightLimit config - } + if isNothing (_cutDbParamsInitialHeightLimit config) + && isNothing (_cutDbParamsInitialCutFile config) + then do + cutVar <- newTVarIO recoveryCut + -- use the recovery cut for the pruning state, so that we write cuts more quickly after recovering + cutPruningStateVar <- newTVarIO $ initialCutPruningState recoveryCut + c <- readTVarIO cutVar + logg Info $ T.unlines $ + "got initial cut:" : [" " <> block | block <- cutToTextShort c] + queue <- newEmptyPQueue _cutHashesWeight _cutHashesId + (Just $ _cutDbParamsBufferSize config) + cutAsync <- asyncWithUnmask $ \u -> u $ processor queue cutVar cutPruningStateVar + logg Debug "CutDB started" + return $ Right CutDb + { _cutDbCut = cutVar + , _cutDbQueue = queue + , _cutDbAsync = cutAsync + , _cutDbLogFunction = logFunction logger + , _cutDbHeaderStore = headerStore + , _cutDbPayloadProviders = providers + , _cutDbQueueSize = _cutDbParamsBufferSize config + , _cutDbCutStore = cutHashesStore + , _cutDbReadOnly = _cutDbParamsReadOnly config + , _cutDbFastForwardHeightLimit = _cutDbParamsFastForwardHeightLimit config + } + else + return (Left recoveryCut) where - logg = logfun @T.Text + logg = logFunctionText logger wbhdb = _webBlockHeaderStoreCas headerStore - v = _chainwebVersion headerStore - processor :: PQueue CutHashes -> TVar Cut -> IO () - processor queue cutVar = runForever logfun "CutDB" $ - processCuts config logfun headerStore payloadStore cutHashesStore queue cutVar + processor :: PQueue CutHashes -> TVar Cut -> TVar CutPruningState -> IO () + processor queue cutVar cutPruningStateVar = runForever (logFunction logger) "CutDB" $ + processCuts config logger headerStore providers cutHashesStore queue cutVar cutPruningStateVar - readInitialCut :: IO Cut + readInitialCut :: HasVersion => IO Cut readInitialCut = do - unsafeMkCut v <$> do - hm <- readHighestCutHeaders' v logg wbhdb cutHashesStore + unsafeMkCut <$> do + hm <- readHighestCutHeaders logg wbhdb cutHashesStore case _cutDbParamsInitialHeightLimit config of Just h -> do limitedCutHeaders <- limitCutHeaders wbhdb h hm - let limitedCut = unsafeMkCut v limitedCutHeaders + let limitedCut = unsafeMkCut limitedCutHeaders unless (_cutDbParamsReadOnly config) $ casInsert cutHashesStore (cutToCutHashes Nothing limitedCut) return limitedCutHeaders Nothing -> return hm -readHighestCutHeaders' :: ChainwebVersion -> LogFunctionText -> WebBlockHeaderDb -> Casify RocksDbTable CutHashes -> IO (HM.HashMap ChainId BlockHeader) -readHighestCutHeaders' v logg wbhdb cutHashesStore = withTableIterator (unCasify cutHashesStore) $ \it -> do +-- | Sync all configured payload providers with consensus. +-- +synchronizeProviders + :: (Logger logger, HasVersion) + => logger + -> WebBlockHeaderDb + -> ChainMap ConfiguredPayloadProvider + -> Cut + -> IO Cut +synchronizeProviders logger wbh providers c = do + let startHeaders = HM.union + (_cutHeaders c) + (imap (\cid () -> genesisBlockHeader cid) (HS.toMap chainIds)) + syncsSuccessful <- mapConcurrently (runMaybeT . syncOne) startHeaders + + logFunctionText logger Info $ "finished synchronizing all payload providers" + <> "; failed: " <> sshow (length (HM.filter isNothing syncsSuccessful)) + + if all isJust syncsSuccessful + then do + return c + else do + -- try to recover from the fork automatically by removing ~`diameter` + -- blocks from the cut + let recoveryHeight = + max (int (diameter (chainGraphAt maxBound))) (_cutMinHeight c) - int (diameter (chainGraphAt maxBound)) + recoveryCut <- limitCut wbh recoveryHeight c + let recoveryHeaders = HM.union + (_cutHeaders recoveryCut) + (imap (\cid () -> genesisBlockHeader cid) (HS.toMap chainIds)) + mapConcurrently_ (runMaybeT . syncOne) recoveryHeaders + return recoveryCut + where + syncOne :: BlockHeader -> MaybeT IO () + syncOne hdr = case providers ^?! atChain (_chainId hdr) of + ConfiguredPayloadProvider provider -> do + let pLogger = providerLogger provider . chainLogger hdr $ logger + let pLog :: MonadIO m => LogLevel -> Text -> m () + pLog l = liftIO . logFunctionText pLogger l + pLog Info $ "syncing payload provider to " + <> sshow (view blockHeight hdr) + <> "." <> toText (view blockHash hdr) + finfo <- liftIO $ forkInfoForHeader wbh hdr Nothing Nothing True + pLog Debug $ "syncToBlock with fork info " <> encodeToText finfo + + bhdb <- liftIO $ getWebBlockHeaderDb wbh cid + liftIO (resolveForkInfo pLog bhdb NullCas provider Nothing finfo) `catch` \(e :: SomeException) -> do + pLog Warn $ "resolveFork failed" + <> "; finfo: " <> encodeToText finfo + <> "; failure: " <> T.pack (displayException e) + empty + pLog Info $ "payload provider synced to " + <> sshow (view blockHeight hdr) + <> "." <> toText (view blockHash hdr) + + DisabledPayloadProvider -> do + liftIO $ logFunctionText logger Info $ + "payload provider disabled, not synced, on chain: " <> toText (_chainId hdr) + where + cid = _chainId hdr + +readHighestCutHeaders :: HasVersion => LogFunctionText -> WebBlockHeaderDb -> Casify RocksDbTable CutHashes -> IO (HM.HashMap ChainId BlockHeader) +readHighestCutHeaders logg wbhdb cutHashesStore = withTableIterator (unCasify cutHashesStore) $ \it -> do iterLast it go it where @@ -484,9 +549,9 @@ readHighestCutHeaders' v logg wbhdb cutHashesStore = withTableIterator (unCasify go it = iterValue it >>= \case Nothing -> do logg Warn "No initial cut found in database or configuration, falling back to genesis cut" - return $ view cutMap $ genesisCut v + return $ view cutMap genesisCut Just ch -> try (lookupCutHashes wbhdb ch) >>= \case - Left (e@(TreeDbKeyNotFound _) :: TreeDbException BlockHeaderDb) -> do + Left (e@(TreeDbKeyNotFound {}) :: TreeDbException BlockHeaderDb) -> do logg Warn $ "Unable to load cut at height " <> sshow (_cutHashesHeight ch) <> " from database." @@ -497,26 +562,29 @@ readHighestCutHeaders' v logg wbhdb cutHashesStore = withTableIterator (unCasify Left e -> throwM e Right hm -> return hm -readHighestCutHeaders :: CutDb cas -> IO (HM.HashMap ChainId BlockHeader) -readHighestCutHeaders cutDb = - readHighestCutHeaders' (_chainwebVersion cutDb) (_cutDbLogFunction cutDb) wbhdb (_cutDbCutStore cutDb) - where - wbhdb = _webBlockHeaderStoreCas $ _cutDbHeaderStore cutDb +readHighestCutHeaders' + :: ChainwebVersion + -> LogFunctionText + -> WebBlockHeaderDb + -> Casify RocksDbTable CutHashes + -> IO (HM.HashMap ChainId BlockHeader) +readHighestCutHeaders' v logg wbhdb cutHashesStore = + withVersion v $ readHighestCutHeaders logg wbhdb cutHashesStore -fastForwardCutDb :: CutDb cas -> IO () +fastForwardCutDb :: HasVersion => CutDb l -> IO () fastForwardCutDb cutDb = do highestCutHeaders <- - readHighestCutHeaders cutDb + readHighestCutHeaders (_cutDbLogFunction cutDb) wbhdb (_cutDbCutStore cutDb) limitedCutHeaders <- limitCutHeaders wbhdb (fromMaybe maxBound (_cutDbFastForwardHeightLimit cutDb)) highestCutHeaders - let limitedCut = unsafeMkCut (_chainwebVersion cutDb) limitedCutHeaders + let limitedCut = unsafeMkCut limitedCutHeaders atomically $ writeTVar (_cutDbCut cutDb) limitedCut where wbhdb = _webBlockHeaderStoreCas $ _cutDbHeaderStore cutDb -- | Stop the cut validation pipeline. -- -stopCutDb :: CutDb tbl -> IO () +stopCutDb :: CutDb l -> IO () stopCutDb db = do currentCut <- readTVarIO (_cutDbCut db) unless (_cutDbReadOnly db) $ @@ -527,15 +595,16 @@ stopCutDb db = do -- the lookup for some BlockHash in the input CutHashes. -- lookupCutHashes - :: WebBlockHeaderDb + :: HasVersion + => WebBlockHeaderDb -> CutHashes -> IO (HM.HashMap ChainId BlockHeader) lookupCutHashes wbhdb hs = - flip itraverse (_cutHashes hs) $ \cid (BlockHashWithHeight _ h) -> + flip itraverse (_cutHashes hs) $ \cid (Ranked _ h) -> lookupWebBlockHeaderDb wbhdb cid h -cutAvgBlockHeight :: ChainwebVersion -> Cut -> BlockHeight -cutAvgBlockHeight v = BlockHeight . round . avgBlockHeightAtCutHeight v . _cutHeight +cutAvgBlockHeight :: HasVersion => Cut -> BlockHeight +cutAvgBlockHeight = BlockHeight . round . avgBlockHeightAtCutHeight . _cutHeight -- | This is at the heart of 'Chainweb' POW: Deciding the current "longest" cut -- among the incoming candiates. @@ -548,69 +617,134 @@ cutAvgBlockHeight v = BlockHeight . round . avgBlockHeightAtCutHeight v . _cutHe -- stores the longest cut. -- processCuts - :: CanPayloadCas tbl + :: HasVersion + => Logger l => CutDbParams - -> LogFunction - -> WebBlockHeaderStore - -> WebBlockPayloadStore tbl + -> l + -> WebBlockHeaderStore l + -> ChainMap ConfiguredPayloadProvider -> Casify RocksDbTable CutHashes -> PQueue CutHashes -> TVar Cut + -> TVar CutPruningState -> IO () -processCuts conf logFun headerStore payloadStore cutHashesStore queue cutVar = do - rng <- Prob.createSystemRandom - queueToStream - & S.chain (\c -> loggCutId logFun Debug c "start processing") - & S.filterM (fmap not . isVeryOld) - & S.filterM (fmap not . farAhead) - & S.filterM (fmap not . isOld) - & S.filterM (fmap not . isCurrent) - - & S.chain (\c -> loggCutId logFun Info c "fetching all prerequisites") - & S.mapM (cutHashesToBlockHeaderMap conf logFun headerStore payloadStore) - & S.catMaybes - -- ignore unsuccessful values for now - - -- using S.scanM would be slightly more efficient (one pointer dereference) - -- by keeping the value of cutVar in memory. We use the S.mapM variant with - -- an redundant 'readTVarIO' because it is easier to read. - & S.mapM_ (\newCut -> do - curCut <- readTVarIO cutVar - !resultCut <- trace logFun "Chainweb.CutDB.processCuts._joinIntoHeavier" () 1 - $ joinIntoHeavier_ hdrStore (_cutMap curCut) newCut - unless (_cutDbParamsReadOnly conf) $ do - maybePrune rng (cutAvgBlockHeight v curCut) - loggCutId logFun Debug newCut "writing cut" - casInsert cutHashesStore (cutToCutHashes Nothing resultCut) - atomically $ writeTVar cutVar resultCut - let cutDiff = cutDiffToTextShort curCut resultCut - let currentCutIdMsg = T.unwords - [ "current cut is now" - , cutIdToTextShort (_cutId resultCut) <> "," - , "diff:" - ] - let catOverflowing x xs = - if length xs == 1 - then T.unwords (x : xs) - else T.intercalate "\n" (x : (map (" " <>) xs)) - logFun @T.Text Info $ catOverflowing currentCutIdMsg cutDiff - ) +processCuts conf logger headerStore providers cutHashesStore queue cutVar cutPruningStateVar = + flip onException writeLatestCutOnExit $ do + pQueueToStream queue + & S.chain (\c -> cutIdLogFunctionText c logger Debug "start processing") + & S.filterM (fmap not . isVeryOld) + & S.filterM (fmap not . farAhead) + & S.filterM (fmap not . isOld) + & S.filterM (fmap not . isCurrent) + + & S.chain (\c -> cutIdLogFunctionText c logger Info "fetching all prerequisites") + & S.mapM (cutHashesToBlockHeaderMap conf logger headerStore providers) + & S.catMaybes + -- ignore unsuccessful values for now + + -- using S.scanM would be slightly more efficient (one pointer dereference) + -- by keeping the value of cutVar in memory. We use the S.mapM variant with + -- an redundant 'readTVarIO' because it is easier to read. + & S.mapM_ (\newCut -> do + let clogger = cutLogger newCut logger + let loggCutId :: LogFunction + loggCutId = logFunction clogger + curCut <- readTVarIO cutVar + !resultCut <- trace loggCutId "Chainweb.CutDB.processCuts._joinIntoHeavier" () 1 + $ joinIntoHeavier_ hdrStore (_cutMap curCut) newCut + -- write the cut to storage for later use when the node restarts + -- or if the operator has to do manual fork resolution later. + -- + -- we don't write *all* cuts. in the worst case if the node + -- receives each block one at a time, we have one cut for each + -- block. each cut has one block hash per chain, so that would + -- be quadratic storage in the number of chains. + -- we also prune old cuts for this reason. + + -- however, we do want to write them at least *once in a while*, + -- to ensure that the node doesn't have to replay too much + -- history on restart, and to ensure that we can do manual fork + -- recovery without more complicated cut rediscovery mechanisms. + unless (_cutDbParamsReadOnly conf) $ do + let resultCutMaxHeight = view cutMaxHeight resultCut + shouldWriteAndPrune <- atomically $ do + latestPruningState <- readTVar cutPruningStateVar + -- we write one cut each time the max height advances by + -- a block ahead of the previously written cut. + -- note that we are not that smart here; this code isn't + -- aware of reorgs. reorgs, especially rewinds, would + -- probably make some sense to write; but we assume that + -- this is good enough, because reorgs are small, one + -- block is a fast thing to wait for, and we + -- regardless write our current cut on a healthy + -- shutdown. + let lastWriteHeight = cutPruningStateLatestWrittenHeight latestPruningState + let nextWriteHeight = succ lastWriteHeight + if all (\bh -> view blockHeight bh >= nextWriteHeight) (view cutMap resultCut) + then do + writeTVar cutPruningStateVar + latestPruningState { cutPruningStateLatestWrittenHeight = resultCutMaxHeight } + return True + else + return False + when shouldWriteAndPrune $ do + pruneCuts logFun conf (cutAvgBlockHeight curCut) cutHashesStore + loggCutId @Text Info $ "writing cut at bh " <> sshow resultCutMaxHeight + casInsert cutHashesStore (cutToCutHashes Nothing resultCut) + + -- ensure that payload providers are in sync with the *merged* + -- cut, so that they produce payloads on the correct parents. + forConcurrently_ (HM.toList (_cutMap resultCut)) $ \(cid, bh) -> do + -- avoid asking for syncToBlock when we know that we're already + -- in sync, otherwise some payload providers misbehave. + when (Just bh /= curCut ^? ixg cid) $ + case providers ^?! atChain cid of + ConfiguredPayloadProvider provider -> do + let cidLogger = chainLogger cid $ providerLogger provider clogger + let clog = logFunction cidLogger + + -- During this final sync we also enable payload production. + finfo <- forkInfoForHeader hdrStore bh Nothing Nothing True + + -- Note, that this sync really should be super quick and + -- should never fail. + -- TODO: It would be nicer to go to the merge cut directly. + clog Info "Syncing paylooad provider with merged cut" + resolveForkInfo clog (hdrStore ^?! ixg cid) NullCas provider Nothing finfo `catch` + \(e :: SomeException) -> do + clog Error + $ "Failed to sync payload provider to the merge cut." + <> " This should never happen. It may indicated a broken payload provider or a corrupted database." + <> " Fork info: " <> encodeToText finfo + <> " Failure: " <> T.pack (displayException e) + throwM $ InternalInvariantViolation + $ "Failed to sync payload provider to the merge cut." + <> " This should never happen. It may indicated a broken payload provider or a corrupted database." + <> " Failure: " <> T.pack (displayException e) + _ -> return () + let cutDiff = cutDiffToTextShort curCut resultCut + let currentCutIdMsg = T.unwords + [ "current cut is now" + , cutIdToTextShort (_cutId resultCut) <> "," + , "diff:" -- ??? + ] + let catOverflowing x xs = + if length xs == 1 + then T.unwords (x : xs) + else T.intercalate "\n" (x : map (" " <>) xs) + loggCutId Info $ catOverflowing currentCutIdMsg cutDiff + atomically $ writeTVar cutVar resultCut + ) where + logFun :: LogFunction + logFun = logFunction logger - v = _chainwebVersion headerStore - - maybePrune rng curCutAvgBlockHeight = do - r :: Double <- Prob.uniform rng - when (r < 1 / int (int (_cutDbParamsPruningFrequency conf) * chainCountAt v maxBound)) $ - pruneCuts logFun v conf curCutAvgBlockHeight cutHashesStore + writeLatestCutOnExit = do + latestCut <- readTVarIO cutVar + casInsert cutHashesStore (cutToCutHashes Nothing latestCut) hdrStore = _webBlockHeaderStoreCas headerStore - queueToStream = do - a <- liftIO (pQueueRemove queue) - S.yield a - queueToStream - -- FIXME: this is problematic. We should drop these much earlier before they -- are even added to the queue, to prevent the queue from becoming stale. -- Although its probably low risk, since the processing pipeline is probably @@ -626,7 +760,7 @@ processCuts conf logFun headerStore payloadStore cutHashesStore queue cutVar = d curMax <- _cutMaxHeight <$> readTVarIO cutVar let newMax = _cutHashesMaxHeight x let r = newMax >= curMax + farAheadThreshold - when r $ loggCutId logFun Debug x + when r $ cutIdLogFunctionText x logger Debug $ "skip far ahead cut. Current maximum block height: " <> sshow curMax <> ", got: " <> sshow newMax -- log at debug level because this is a common case during catchup @@ -643,10 +777,10 @@ processCuts conf logFun headerStore payloadStore cutHashesStore queue cutVar = d -- isVeryOld x = do curMin <- _cutMinHeight <$> readTVarIO cutVar - let diam = diameter $ chainGraphAt headerStore curMin + let diam = diameter $ chainGraphAt curMin newMin = _cutHashesMinHeight x let r = newMin + 2 * (1 + int diam) <= curMin - when r $ loggCutId logFun Debug x "skip very old cut" + when r $ cutIdLogFunctionText x logger Debug "skip very old cut" -- log at debug level because this is a common case during catchup return r @@ -654,14 +788,14 @@ processCuts conf logFun headerStore payloadStore cutHashesStore queue cutVar = d -- isOld x = do curHashes <- cutToCutHashes Nothing <$> readTVarIO cutVar - let r = all (>= (0 :: Int)) $ (HM.unionWith (-) `on` (fmap (int . _bhwhHeight) . _cutHashes)) curHashes x - when r $ loggCutId logFun Debug x "skip old cut" + let r = all (>= (0 :: Int)) $ (HM.unionWith (-) `on` (fmap (int . _rankedHeight) . _cutHashes)) curHashes x + when r $ cutIdLogFunctionText x logger Debug "skip old cut" return r isCurrent x = do curHashes <- cutToCutHashes Nothing <$> readTVarIO cutVar let r = _cutHashes curHashes == _cutHashes x - when r $ loggCutId logFun Debug x "skip current cut" + when r $ cutIdLogFunctionText x logger Debug "skip current cut" return r -- | Stream of most recent cuts. This stream does not generally include the full @@ -669,7 +803,7 @@ processCuts conf logFun headerStore payloadStore cutHashesStore queue cutVar = d -- produced faster than they are consumed from the stream, the stream skips over -- cuts and always returns the latest cut in the db. -- -cutStream :: MonadIO m => CutDb tbl -> S.Stream (Of Cut) m r +cutStream :: MonadIO m => CutDb l -> S.Stream (Of Cut) m r cutStream db = liftIO (_cut db) >>= \c -> S.yield c >> go c where go cur = do @@ -684,9 +818,10 @@ cutStream db = liftIO (_cut db) >>= \c -> S.yield c >> go c -- cuts. Blocks of the same chain are sorted by block height. -- cutStreamToHeaderStream - :: forall m tbl r + :: forall m r l . MonadIO m - => CutDb tbl + => HasVersion + => CutDb l -> S.Stream (Of Cut) m r -> S.Stream (Of BlockHeader) m r cutStreamToHeaderStream db s = S.for (go Nothing s) $ \(T2 p n) -> @@ -713,9 +848,10 @@ cutStreamToHeaderStream db s = S.for (go Nothing s) $ \(T2 p n) -> -- cuts. Blocks of the same chain are sorted by block height. -- cutStreamToHeaderDiffStream - :: forall m tbl r + :: forall m r l . MonadIO m - => CutDb tbl + => HasVersion + => CutDb l -> S.Stream (Of Cut) m r -> S.Stream (Of (Either BlockHeader BlockHeader)) m r cutStreamToHeaderDiffStream db s = S.for (cutUpdates Nothing s) $ \(T2 p n) -> @@ -752,88 +888,122 @@ cutStreamToHeaderDiffStream db s = S.for (cutUpdates Nothing s) $ \(T2 p n) -> -- -- @chainId + blockHeight * graphOrder@ -- -uniqueBlockNumber :: BlockHeader -> Natural +uniqueBlockNumber :: HasVersion => BlockHeader -> Natural uniqueBlockNumber bh = chainIdInt (_chainId bh) + int (view blockHeight bh) * order (_chainGraph bh) -blockStream :: MonadIO m => CutDb tbl -> S.Stream (Of BlockHeader) m r +blockStream :: (MonadIO m, HasVersion) => CutDb l -> S.Stream (Of BlockHeader) m r blockStream db = cutStreamToHeaderStream db $ cutStream db -blockDiffStream :: MonadIO m => CutDb tbl -> S.Stream (Of (Either BlockHeader BlockHeader)) m r +blockDiffStream :: (MonadIO m, HasVersion) => CutDb l -> S.Stream (Of (Either BlockHeader BlockHeader)) m r blockDiffStream db = cutStreamToHeaderDiffStream db $ cutStream db cutHashesToBlockHeaderMap - :: CanPayloadCas tbl + :: HasVersion + => Logger logger => CutDbParams - -> LogFunction - -> WebBlockHeaderStore - -> WebBlockPayloadStore tbl + -> logger + -> WebBlockHeaderStore logger + -> ChainMap ConfiguredPayloadProvider -> CutHashes -> IO (Maybe (HM.HashMap ChainId BlockHeader)) -- ^ The 'Left' value holds missing hashes, the 'Right' value holds -- a 'Cut'. -cutHashesToBlockHeaderMap conf logfun headerStore payloadStore hs = - trace logfun "Chainweb.CutDB.cutHashesToBlockHeaderMap" hsid 1 $ do +cutHashesToBlockHeaderMap conf logfun headerStore providers hs = + trace logg "Chainweb.CutDB.cutHashesToBlockHeaderMap" hsid 1 $ do timeout (_cutDbParamsFetchTimeout conf) go >>= \case Nothing -> do let cutOriginText = case _cutHashesLocalPayload hs of Nothing -> "from " <> maybe "unknown origin" (\p -> "origin " <> toText p) origin Just _ -> "which was locally mined - the mining loop will stall until unstuck by another miner" - logfun (maybe Warn (\_ -> Error) (_cutHashesLocalPayload hs)) + logg (maybe Warn (const Error) (_cutHashesLocalPayload hs)) $ "Timeout while processing cut " <> cutIdToTextShort hsid <> " at height " <> sshow (_cutHashesHeight hs) <> " from origin " <> cutOriginText return Nothing Just (Left missing) -> do - loggCutId logfun Warn hs $ "Failed to get prerequisites for some blocks. Missing: " <> encodeToText missing + logg Warn $ "Failed to get prerequisites for some blocks. Missing: " + <> renderMissing missing return Nothing Just (Right headers) -> do return (Just headers) where + logg :: LogFunction + logg = cutIdLogFunction hs logfun + + renderMissing :: HM.HashMap (ChainValue RankedBlockHash) [SomeException] -> T.Text + renderMissing m = encodeToText $ HM.mapWithKey renderMiss m + renderMiss :: ChainValue RankedBlockHash -> [SomeException] -> Value + renderMiss cv es = object + [ "blockHash" .= toText cv + , "error" .= (renderExceptionJson [Renderer clientErrorValue] <$> es) + ] + hsid = _cutId hs go = do + -- We collect candidate payloads locally in a table and provide them to + -- the payload provider by inserting them in the evluation contexts for + -- the respective blocks + -- plds <- emptyTable - casInsertBatch plds $ HM.elems $ _cutHashesPayloads hs + tableInsertBatch plds $ HM.toList $ _cutHashesPayloads hs hdrs <- emptyTable casInsertBatch hdrs $ HM.elems $ _cutHashesHeaders hs -- for better error messages on validation failure - -- must be a locally-produced payload let localPayload = _cutHashesLocalPayload hs - (headers :> missing) <- S.each (HM.toList $ _cutHashes hs) - & S.map (fmap _bhwhHash) - & S.mapM (tryGetBlockHeader hdrs plds localPayload) - & S.partitionEithers - & S.fold_ (\x (cid, h) -> HM.insert cid h x) mempty id - & S.fold (\x (cid, h) -> HM.insert cid h x) mempty id + (missing, headers) <- fmap partitionEithers + $ forConcurrently (uncurry ChainValue <$> HM.toList (_cutHashes hs)) + $ tryGetBlockHeader hdrs plds localPayload if null missing - then return $! Right headers - else do + then + return $ Right $! HM.fromList $ (\hdr -> (_chainId hdr, hdr)) <$> headers + else do when (isJust $ _cutHashesLocalPayload hs) $ - logfun @Text Error + logg @T.Text Error "error validating locally mined cut; the mining loop will stall until unstuck by another mining node" - return $! Left missing + return $ Left $! HM.fromList missing origin = _cutOrigin hs priority = Priority (int (_cutHashesHeight hs)) - tryGetBlockHeader hdrs plds localPayload cv@(cid, _) = - (Right <$> mapM (getBlockHeader headerStore payloadStore hdrs plds localPayload cid priority origin) cv) - `catch` \case - (TreeDbKeyNotFound{} :: TreeDbException BlockHeaderDb) -> - return (Left cv) - e -> throwM e + -- tryGetBlockHeader hdrs localPayload cv@(cid, _) = + -- (Right <$> mapM + -- (getBlockHeader minerInfo headerStore hdrs providers localPayload cid priority origin) cv) + -- `catch` \case + -- (TreeDbKeyNotFound{} :: TreeDbException BlockHeaderDb) -> + -- return (Left cv) + -- e -> throwM e + + tryGetBlockHeader + :: HashMapTable BlockHash BlockHeader + -> HashMapTable BlockPayloadHash EncodedPayloadData + -> Maybe (BlockPayloadHash, EncodedPayloadOutputs) + -> ChainValue RankedBlockHash + -> IO (Either (ChainValue RankedBlockHash, [SomeException]) BlockHeader) + tryGetBlockHeader hdrs plds localPayload cv = do + Right <$> getBlockHeader + headerStore + hdrs + plds + providers + localPayload + priority + origin + cv + `catch` \(TaskFailed es) -> return (Left (cv, es)) -- -------------------------------------------------------------------------- -- -- Membership Queries memberOfHeader - :: CutDb tbl + :: HasVersion + => CutDb l -> ChainId -> BlockHash -- ^ the block hash to look up (the member) @@ -843,27 +1013,18 @@ memberOfHeader memberOfHeader db cid h ctx = do lookup chainDb h >>= \case Nothing -> return False - Just lh -> seekAncestor chainDb ctx (int $ view blockHeight lh) >>= \case + Just !lh -> seekAncestor chainDb ctx (int $ view blockHeight lh) >>= \case Nothing -> return False Just x -> return $ view blockHash x == h where chainDb = db ^?! cutDbWebBlockHeaderDb . ixg cid -memberOfM - :: CutDb tbl +member + :: HasVersion + => CutDb l -> ChainId -> BlockHash - -- ^ the block hash to look up (the member) - -> BlockHash - -- ^ the context, i.e. the branch of the chain that contains the member -> IO Bool -memberOfM db cid h ctx = do - th <- lookupM chainDb ctx - memberOfHeader db cid h th - where - chainDb = db ^?! cutDbWebBlockHeaderDb . ixg cid - -member :: CutDb tbl -> ChainId -> BlockHash -> IO Bool member db cid h = do th <- maxEntry chainDb memberOfHeader db cid h th @@ -875,13 +1036,15 @@ member db cid h = do -- | 'CutDb' with type level 'ChainwebVersionName' -- -newtype CutDbT tbl (v :: ChainwebVersionT) = CutDbT (CutDb tbl) +newtype CutDbT l (v :: ChainwebVersionT) = CutDbT (CutDb l) deriving (Generic) -data SomeCutDb tbl = forall v . KnownChainwebVersionSymbol v => SomeCutDb (CutDbT tbl v) +data SomeCutDb = forall l v . KnownChainwebVersionSymbol v => SomeCutDb (CutDbT l v) -someCutDbVal :: ChainwebVersion -> CutDb tbl -> SomeCutDb tbl -someCutDbVal (FromSingChainwebVersion (SChainwebVersion :: Sing v)) db = SomeCutDb $ CutDbT @_ @v db +someCutDbVal :: HasVersion => CutDb l -> SomeCutDb +someCutDbVal db = case implicitVersion of + FromSingChainwebVersion (SChainwebVersion :: Sing v) -> + SomeCutDb $ CutDbT @_ @v db -- -------------------------------------------------------------------------- -- -- Queue Stats @@ -890,20 +1053,40 @@ data QueueStats = QueueStats { _queueStatsCutQueueSize :: !Natural , _queueStatsBlockHeaderQueueSize :: !Natural , _queueStatsBlockHeaderTaskMapSize :: !Natural - , _queueStatsPayloadQueueSize :: !Natural - , _queueStatsPayloadTaskMapSize :: !Natural } deriving (Show, Eq, Ord, Generic) deriving anyclass (NFData, ToJSON) -getQueueStats :: CutDb tbl -> IO QueueStats +getQueueStats :: CutDb l -> IO QueueStats getQueueStats db = QueueStats <$> cutDbQueueSize db <*> pQueueSize (_webBlockHeaderStoreQueue $ view cutDbWebBlockHeaderStore db) <*> (int <$> TM.size (_webBlockHeaderStoreMemo $ view cutDbWebBlockHeaderStore db)) - <*> pQueueSize (_webBlockPayloadStoreQueue $ view cutDbPayloadStore db) - <*> (int <$> TM.size (_webBlockPayloadStoreMemo $ view cutDbPayloadStore db)) --- Logging -loggCutId :: HasCutId c => LogFunction -> LogLevel -> c -> T.Text -> IO () -loggCutId logFun l c msg = logFun @T.Text l $ "cut " <> cutIdToTextShort (_cutId c) <> ": " <> msg +-- -------------------------------------------------------------------------- -- +-- Logging Utils + +chainLogger :: Logger logger => HasChainId c => c -> logger -> logger +chainLogger cid = addLabel ("chain", toText (_chainId cid)) + +providerLogger :: Logger logger => HasPayloadProviderType p => p -> logger -> logger +providerLogger p = addLabel ("provider", toText (_payloadProviderType p)) + +cutLogger :: Logger logger => HasCutId c => c -> logger -> logger +cutLogger c = addLabel ("cut", cutIdToTextShort (_cutId c)) + +cutIdLogFunction + :: HasCutId c + => Logger logger + => c + -> logger + -> LogFunction +cutIdLogFunction c = logFunction . cutLogger c + +cutIdLogFunctionText + :: HasCutId c + => Logger logger + => c + -> logger + -> LogFunctionText +cutIdLogFunctionText = cutIdLogFunction diff --git a/src/Chainweb/CutDB/RestAPI.hs b/src/Chainweb/CutDB/RestAPI.hs index adf03104aa..f178bdd3a8 100644 --- a/src/Chainweb/CutDB/RestAPI.hs +++ b/src/Chainweb/CutDB/RestAPI.hs @@ -84,5 +84,6 @@ cutApi = Proxy -- -------------------------------------------------------------------------- -- -- Some Cut Api -someCutApi :: ChainwebVersion -> SomeApi -someCutApi (FromSingChainwebVersion (SChainwebVersion :: Sing v)) = SomeApi $ cutApi @v +someCutApi :: HasVersion => SomeApi +someCutApi = case implicitVersion of + FromSingChainwebVersion (SChainwebVersion :: Sing v) -> SomeApi $ cutApi @v diff --git a/src/Chainweb/CutDB/RestAPI/Client.hs b/src/Chainweb/CutDB/RestAPI/Client.hs index 1ca26c7c5e..b10aae7932 100644 --- a/src/Chainweb/CutDB/RestAPI/Client.hs +++ b/src/Chainweb/CutDB/RestAPI/Client.hs @@ -31,23 +31,27 @@ import Chainweb.Version -- GET Cut Client cutGetClient - :: ChainwebVersion - -> ClientM CutHashes -cutGetClient (FromSingChainwebVersion (SChainwebVersion :: Sing v)) - = client (cutGetApi @v) Nothing + :: HasVersion + => ClientM CutHashes +cutGetClient = case implicitVersion of + FromSingChainwebVersion (SChainwebVersion :: Sing v) -> + client (cutGetApi @v) Nothing cutGetClientLimit - :: ChainwebVersion - -> MaxRank + :: HasVersion + => MaxRank -> ClientM CutHashes -cutGetClientLimit (FromSingChainwebVersion (SChainwebVersion :: Sing v)) - = client (cutGetApi @v) . Just +cutGetClientLimit = case implicitVersion of + FromSingChainwebVersion (SChainwebVersion :: Sing v) -> + client (cutGetApi @v) . Just -- -------------------------------------------------------------------------- -- -- PUT Cut Client cutPutClient - :: ChainwebVersion - -> CutHashes + :: HasVersion + => CutHashes -> ClientM NoContent -cutPutClient (FromSingChainwebVersion (SChainwebVersion :: Sing v)) = client $ cutPutApi @v +cutPutClient = case implicitVersion of + FromSingChainwebVersion (SChainwebVersion :: Sing v) -> + client $ cutPutApi @v diff --git a/src/Chainweb/CutDB/RestAPI/Server.hs b/src/Chainweb/CutDB/RestAPI/Server.hs index 2167fafd9e..455754fcbb 100644 --- a/src/Chainweb/CutDB/RestAPI/Server.hs +++ b/src/Chainweb/CutDB/RestAPI/Server.hs @@ -48,7 +48,7 @@ import Servant.Server -- internal modules import Chainweb.BlockHeight -import Chainweb.Cut +import Chainweb.Cut.Create import Chainweb.Cut.CutHashes import Chainweb.CutDB import Chainweb.CutDB.RestAPI @@ -65,16 +65,15 @@ import P2P.Peer -- -------------------------------------------------------------------------- -- -- Handlers -cutGetHandler :: CutDb tbl -> Maybe MaxRank -> IO CutHashes +cutGetHandler :: HasVersion => CutDb l -> Maybe MaxRank -> IO CutHashes cutGetHandler db Nothing = liftIO $ cutToCutHashes Nothing <$> _cut db cutGetHandler db (Just (MaxRank (Max mar))) = liftIO $ do !c <- _cut db - let v = _chainwebVersion db - let !bh = BlockHeight $ floor (avgBlockHeightAtCutHeight v (CutHeight $ int mar)) + let !bh = BlockHeight $ floor (avgBlockHeightAtCutHeight (CutHeight $ int mar)) !c' <- limitCut (view cutDbWebBlockHeaderDb db) bh c return $! cutToCutHashes Nothing c' -cutPutHandler :: PeerDb -> CutDb tbl -> CutHashes -> Handler NoContent +cutPutHandler :: PeerDb -> CutDb l -> CutHashes -> Handler NoContent cutPutHandler pdb db c = case _peerAddr <$> _cutOrigin c of Nothing -> throwError $ setErrText "Cut is missing an origin entry" err400 Just addr -> do @@ -87,39 +86,39 @@ cutPutHandler pdb db c = case _peerAddr <$> _cutOrigin c of -- Cut API Server cutServer - :: forall tbl (v :: ChainwebVersionT) - . PeerDb - -> CutDbT tbl v + :: forall (v :: ChainwebVersionT) l + . HasVersion + => PeerDb + -> CutDbT l v -> Server (CutApi v) cutServer pdb (CutDbT db) = liftIO . cutGetHandler db :<|> cutPutHandler pdb db cutGetServer - :: forall tbl (v :: ChainwebVersionT) - . CutDbT tbl v + :: forall (v :: ChainwebVersionT) l + . HasVersion + => CutDbT l v -> Server (CutGetApi v) cutGetServer (CutDbT db) = liftIO . cutGetHandler db -- -------------------------------------------------------------------------- -- -- Some Cut Server -someCutServerT :: PeerDb -> SomeCutDb tbl -> SomeServer -someCutServerT pdb (SomeCutDb (db :: CutDbT tbl v)) = +someCutServerT :: HasVersion => PeerDb -> SomeCutDb -> SomeServer +someCutServerT pdb (SomeCutDb (db :: CutDbT l v)) = SomeServer (Proxy @(CutApi v)) (cutServer pdb db) -someCutServer :: ChainwebVersion -> PeerDb -> CutDb tbl -> SomeServer -someCutServer v pdb = someCutServerT pdb . someCutDbVal v +someCutServer :: HasVersion => PeerDb -> CutDb l -> SomeServer +someCutServer pdb = someCutServerT pdb . someCutDbVal -someCutGetServerT :: SomeCutDb tbl -> SomeServer -someCutGetServerT (SomeCutDb (db :: CutDbT tbl v)) = +someCutGetServerT :: HasVersion => SomeCutDb -> SomeServer +someCutGetServerT (SomeCutDb (db :: CutDbT l v)) = SomeServer (Proxy @(CutGetApi v)) (cutGetServer db) -someCutGetServer :: ChainwebVersion -> CutDb tbl -> SomeServer -someCutGetServer v = someCutGetServerT . someCutDbVal v +someCutGetServer :: HasVersion => CutDb l -> SomeServer +someCutGetServer = someCutGetServerT . someCutDbVal -- -------------------------------------------------------------------------- -- -- Run Server -serveCutOnPort :: Port -> ChainwebVersion -> PeerDb -> CutDb tbl -> IO () -serveCutOnPort p v pdb = run (int p) . someServerApplication . someCutServer v pdb - - +serveCutOnPort :: HasVersion => Port -> PeerDb -> CutDb l -> IO () +serveCutOnPort p pdb = run (int p) . someServerApplication . someCutServer pdb diff --git a/src/Chainweb/CutDB/Sync.hs b/src/Chainweb/CutDB/Sync.hs index 235a084a37..4adc23910e 100644 --- a/src/Chainweb/CutDB/Sync.hs +++ b/src/Chainweb/CutDB/Sync.hs @@ -15,7 +15,8 @@ -- network. -- module Chainweb.CutDB.Sync -( syncSession +( catchupStepSize +, syncSession ) where import Control.Concurrent.Async @@ -48,26 +49,25 @@ import P2P.Session -- -------------------------------------------------------------------------- -- -- Client Env -data CutClientEnv = CutClientEnv - { _envChainwebVersion :: !ChainwebVersion - , _envClientEnv :: !ClientEnv - } +newtype CutClientEnv = CutClientEnv { _envClientEnv :: ClientEnv } deriving (Generic) runClientThrowM :: ClientM a -> ClientEnv -> IO a runClientThrowM req = fromEitherM <=< runClientM req putCut - :: CutClientEnv + :: HasVersion + => CutClientEnv -> CutHashes -> IO () -putCut (CutClientEnv v env) = void . flip runClientThrowM env . cutPutClient v +putCut (CutClientEnv env) = void . flip runClientThrowM env . cutPutClient getCut - :: CutClientEnv + :: HasVersion + => CutClientEnv -> CutHeight -> IO CutHashes -getCut (CutClientEnv v env) h = runClientThrowM (cutGetClientLimit v (int h)) env +getCut (CutClientEnv env) h = runClientThrowM (cutGetClientLimit (int h)) env -- -------------------------------------------------------------------------- -- -- Sync Session @@ -80,15 +80,19 @@ getCut (CutClientEnv v env) h = runClientThrowM (cutGetClientLimit v (int h)) en -- This number MUST BE STRICTLY SMALLER than 'Chainweb.CutDB.farAheadThreshold' -- times the number of chains. -- +-- FIXME FIXME FIXME: +-- The current number works for at least 25 chains. It does not work on current +-- mainet. The type should be changed to BlockHeight to avoid these issues. +-- catchupStepSize :: CutHeight -catchupStepSize = 100 +catchupStepSize = 500 syncSession - :: ChainwebVersion - -> PeerInfo - -> CutDb tbl + :: HasVersion + => PeerInfo + -> CutDb l -> P2pSession -syncSession v p db logg env pinf = do +syncSession p db logg env pinf = do race_ (S.mapM_ send $ S.map (cutToCutHashes (Just p)) $ cutStream db) (forever $ receive >> approximateThreadDelay 2000000 {- 2 seconds -}) @@ -102,7 +106,7 @@ syncSession v p db logg env pinf = do logg @T.Text Error "unexpectedly exited cut sync session" return False where - cenv = CutClientEnv v env + cenv = CutClientEnv env send c = do putCut cenv c diff --git a/src/Chainweb/Graph.hs b/src/Chainweb/Graph.hs index 9f7a148e47..eb65099d12 100644 --- a/src/Chainweb/Graph.hs +++ b/src/Chainweb/Graph.hs @@ -80,7 +80,11 @@ module Chainweb.Graph , petersenChainGraph , twentyChainGraph , hoffmanSingletonChainGraph - +, d3k4ChainGraph +, d4k3ChainGraph +, d4k4ChainGraph +, d5k3ChainGraph +, d5k4ChainGraph ) where import Control.Arrow ((&&&)) diff --git a/src/Chainweb/HostAddress.hs b/src/Chainweb/HostAddress.hs index caf6eee025..555f259bb6 100644 --- a/src/Chainweb/HostAddress.hs +++ b/src/Chainweb/HostAddress.hs @@ -470,7 +470,7 @@ hostAddressProperties o = {-# INLINE hostAddressProperties #-} instance ToJSON HostAddress where - toJSON = object. hostAddressProperties + toJSON = object . hostAddressProperties toEncoding = pairs . mconcat . hostAddressProperties {-# INLINE toJSON #-} {-# INLINE toEncoding #-} diff --git a/src/Chainweb/Logging/Config.hs b/src/Chainweb/Logging/Config.hs index 52273f9c52..756ab6a9e0 100644 --- a/src/Chainweb/Logging/Config.hs +++ b/src/Chainweb/Logging/Config.hs @@ -66,14 +66,9 @@ import Utils.Logging.Config -- newtype ClusterId = ClusterId T.Text deriving (Show, Eq, Ord, Generic) - deriving newtype (IsString, ToJSON, FromJSON) + deriving newtype (IsString, ToJSON, FromJSON, HasTextRepresentation) deriving anyclass (NFData) -instance HasTextRepresentation ClusterId where - toText (ClusterId t) = t - fromText = return . ClusterId - - -- | General logging config -- data LogConfig = LogConfig diff --git a/src/Chainweb/Logging/Miner.hs b/src/Chainweb/Logging/Miner.hs index 0868abad0e..d408382b76 100644 --- a/src/Chainweb/Logging/Miner.hs +++ b/src/Chainweb/Logging/Miner.hs @@ -27,22 +27,26 @@ import GHC.Generics import Chainweb.BlockHeader import Chainweb.Time +import Chainweb.MinerReward +import Numeric.Natural +import Chainweb.Parent +import Chainweb.BlockHash data NewMinedBlock = NewMinedBlock { _minedBlockHeader :: !(ObjectEncoded BlockHeader) - , _minedBlockTrans :: {-# UNPACK #-} !Word - , _minedBlockSize :: {-# UNPACK #-} !Word -- ^ Bytes - , _minedBlockMiner :: !Text + , _minedBlockTrans :: !Natural + , _minedBlockSize :: !Natural + , _minedBlockOutputSize :: !Natural + , _minedBlockFees :: !Stu , _minedBlockDiscoveredAt :: !(Time Micros) } deriving stock (Eq, Show, Generic) deriving anyclass (ToJSON, NFData) data OrphanedBlock = OrphanedBlock - { _orphanedHeader :: !(ObjectEncoded BlockHeader) - , _orphanedBestOnCut :: !(ObjectEncoded BlockHeader) + { _orphanedParent :: !(Parent BlockHash) + , _orphanedPayloadHash :: !BlockPayloadHash , _orphanedDiscoveredAt :: !(Time Micros) - , _orphanedMiner :: !Text , _orphanedReason :: !Text } deriving stock (Eq, Show, Generic) diff --git a/src/Chainweb/Mempool/Consensus.hs b/src/Chainweb/Mempool/Consensus.hs deleted file mode 100644 index 12d2c22336..0000000000 --- a/src/Chainweb/Mempool/Consensus.hs +++ /dev/null @@ -1,193 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} - -module Chainweb.Mempool.Consensus -( chainwebTxsFromPd -, MempoolConsensus(..) -, mkMempoolConsensus -, processFork -, processFork' -, processForkCheckTTL -, ReintroducedTxsLog (..) -) where - ------------------------------------------------------------------------------- -import Control.DeepSeq -import Control.Exception -import Control.Lens (view) -import Control.Monad - -import Data.Aeson -import Data.Either -import Data.Foldable (toList) -import Data.Hashable -import Data.HashSet (HashSet) -import qualified Data.HashSet as HS -import Data.IORef -import Data.Vector (Vector) -import qualified Data.Vector as V - -import GHC.Generics - -import System.LogLevel - ------------------------------------------------------------------------------- -import Chainweb.BlockHeader -import Chainweb.BlockHeaderDB -import Chainweb.Mempool.InMem -import Chainweb.Mempool.Mempool -import Chainweb.Payload -import Chainweb.Payload.PayloadStore -import Chainweb.Time -import qualified Chainweb.Pact4.Transaction as Pact4 -import Chainweb.TreeDB -import Chainweb.Utils - -import Data.LogMessage (JsonLog(..), LogFunction) -import qualified Pact.Types.ChainMeta as Pact4 -import Data.Text (Text) - ------------------------------------------------------------------------------- -data MempoolConsensus = MempoolConsensus - { mpcMempool :: !(MempoolBackend Pact4.UnparsedTransaction) - , mpcLastNewBlockParent :: !(IORef (Maybe BlockHeader)) - , mpcProcessFork - :: LogFunction -> BlockHeader -> IO (Vector Pact4.UnparsedTransaction, Vector Pact4.UnparsedTransaction) - } - -data ReintroducedTxsLog = ReintroducedTxsLog - { oldForkHeader :: ObjectEncoded BlockHeader - , newForkHeader :: ObjectEncoded BlockHeader - , numReintroduced :: Int } - deriving (Eq, Show, Generic) - deriving anyclass (ToJSON, NFData) - -newtype MempoolException = MempoolConsensusException String - -instance Show MempoolException where - show (MempoolConsensusException s) = - "Error with mempool's consensus processing: " ++ s - -instance Exception MempoolException - ------------------------------------------------------------------------------- -mkMempoolConsensus - :: CanReadablePayloadCas tbl - => MempoolBackend Pact4.UnparsedTransaction - -> BlockHeaderDb - -> Maybe (PayloadDb tbl) - -> IO MempoolConsensus -mkMempoolConsensus mempool blockHeaderDb payloadStore = do - lastParentRef <- newIORef Nothing :: IO (IORef (Maybe BlockHeader)) - - return MempoolConsensus - { mpcMempool = mempool - , mpcLastNewBlockParent = lastParentRef - , mpcProcessFork = processFork blockHeaderDb payloadStore lastParentRef - } - - ------------------------------------------------------------------------------- -processFork - :: CanReadablePayloadCas tbl - => BlockHeaderDb - -> Maybe (PayloadDb tbl) - -> IORef (Maybe BlockHeader) - -> LogFunction - -> BlockHeader - -> IO (Vector Pact4.UnparsedTransaction, Vector Pact4.UnparsedTransaction) -processFork blockHeaderDb payloadStore lastHeaderRef logFun newHeader = do - now <- getCurrentTimeIntegral - lastHeader <- readIORef lastHeaderRef - (a, b) <- processFork' logFun blockHeaderDb newHeader lastHeader - (payloadLookup payloadStore) - (processForkCheckTTL now) - return (V.map Pact4.unHashable a, V.map Pact4.unHashable b) - - ------------------------------------------------------------------------------- -processForkCheckTTL - :: Time Micros - -> Pact4.HashableTrans (Pact4.PayloadWithText Pact4.PublicMeta Text) -> Bool -processForkCheckTTL now (Pact4.HashableTrans t) = - either (const False) (const True) $ - txTTLCheck pact4TransactionConfig now t - - ------------------------------------------------------------------------------- --- called directly from some unit tests... -processFork' - :: (Eq x, Hashable x) - => LogFunction - -> BlockHeaderDb - -> BlockHeader - -> Maybe BlockHeader - -> (BlockHeader -> IO (HashSet x)) - -> (x -> Bool) - -> IO (V.Vector x, V.Vector x) -processFork' logFun db newHeader lastHeaderM plLookup flt = - maybe (return (V.empty, V.empty)) go lastHeaderM - where - go lastHeader = do - (_, oldBlocks, newBlocks) <- collectForkBlocks db lastHeader newHeader - oldTrans <- foldM toSet mempty oldBlocks - newTrans <- foldM toSet mempty newBlocks - - -- before re-introducing the transactions from the losing fork (aka - -- oldBlocks), filter out any transactions that have been included in - -- the winning fork (aka newBlocks): - let !results = V.fromList $ filter flt - $ HS.toList - $ oldTrans `HS.difference` newTrans - let !deletes = V.fromList $ HS.toList newTrans - - unless (V.null results) $ do - -- create data for the dashboard showing number or reintroduced - -- transactions: - let !reIntro = ReintroducedTxsLog - { oldForkHeader = ObjectEncoded lastHeader - , newForkHeader = ObjectEncoded newHeader - , numReintroduced = V.length results - } - logFun @(JsonLog ReintroducedTxsLog) Info $ JsonLog reIntro - return (results, deletes) - where - toSet !trans !header = HS.union trans <$!> plLookup header - - ------------------------------------------------------------------------------- -payloadLookup - :: CanReadablePayloadCas tbl - => Maybe (PayloadDb tbl) - -> BlockHeader - -> IO (HashSet (Pact4.HashableTrans (Pact4.PayloadWithText Pact4.PublicMeta Text))) -payloadLookup payloadStore bh = - case payloadStore of - Nothing -> return mempty - Just s -> do - pd <- lookupPayloadDataWithHeight s (Just (view blockHeight bh)) (view blockPayloadHash bh) - pd' <- maybe (throwIO $ PayloadNotFoundException (view blockPayloadHash bh)) pure pd - chainwebTxsFromPd pd' - ------------------------------------------------------------------------------- -chainwebTxsFromPd - :: PayloadData - -> IO (HashSet (Pact4.HashableTrans (Pact4.PayloadWithText Pact4.PublicMeta Text))) -chainwebTxsFromPd pd = do - let transSeq = view payloadDataTransactions pd - let bytes = _transactionBytes <$> transSeq - let eithers = toCWTransaction <$> bytes - -- Note: if any transactions fail to convert, the final validation hash will fail to match - -- the one computed during newBlock - let theRights = rights $ toList eithers - return $! HS.fromList $ Pact4.HashableTrans <$!> theRights - where - toCWTransaction = codecDecode Pact4.rawCommandCodec diff --git a/src/Chainweb/MerkleLogHash.hs b/src/Chainweb/MerkleLogHash.hs index 689cbe5034..e3d4b06f9e 100644 --- a/src/Chainweb/MerkleLogHash.hs +++ b/src/Chainweb/MerkleLogHash.hs @@ -22,7 +22,8 @@ module Chainweb.MerkleLogHash ( -- * MerkleLogHash - MerkleLogHash(..) -- FIXME import this only internally + MerkleLogHash(..) +, merkleLogHashBytes , MerkleLogHashBytesCount , merkleLogHashBytesCount , merkleLogHash @@ -39,26 +40,23 @@ import Control.Monad.Catch (MonadThrow, displayException, throwM) import Data.Aeson (FromJSON(..), FromJSONKey(..), ToJSON(..), ToJSONKey(..)) import Data.Aeson.Types (FromJSONKeyFunction(..), toJSONKeyText) import Data.Bits -import qualified Data.ByteArray as BA import qualified Data.ByteString as B import Data.Hashable (Hashable(..)) import Data.MerkleLog hiding (Expected, Actual) import Data.Proxy import qualified Data.Text as T -import Foreign.Storable - import GHC.Generics import GHC.Stack (HasCallStack) import GHC.TypeNats -import System.IO.Unsafe - -- internal imports -import Chainweb.Crypto.MerkleLog import Chainweb.Utils import Chainweb.Utils.Serialization +import Data.Either +import Data.Array.Byte +import Data.Hash.Class.Mutable -- -------------------------------------------------------------------------- -- -- MerkleLogHash @@ -75,22 +73,29 @@ merkleLogHashBytesCount = natVal $ Proxy @MerkleLogHashBytesCount newtype MerkleLogHash a = MerkleLogHash (MerkleRoot a) deriving stock (Show, Eq, Ord, Generic) - deriving newtype (BA.ByteArrayAccess) deriving anyclass (NFData) +instance Bytes (MerkleLogHash a) where + byteArray (MerkleLogHash r) = merkleRootBytes r + {-# INLINE byteArray #-} + -- | Smart constructor -- merkleLogHash :: MonadThrow m - => MerkleHashAlgorithm a + => IncrementalHash a => B.ByteString -> m (MerkleLogHash a) merkleLogHash = fmap MerkleLogHash . decodeMerkleRoot {-# INLINE merkleLogHash #-} +merkleLogHashBytes :: MerkleLogHash a -> ByteArray +merkleLogHashBytes (MerkleLogHash r) = merkleRootBytes r +{-# INLINE merkleLogHashBytes #-} + unsafeMerkleLogHash :: HasCallStack - => MerkleHashAlgorithm a + => IncrementalHash a => B.ByteString -> MerkleLogHash a unsafeMerkleLogHash = MerkleLogHash @@ -98,28 +103,27 @@ unsafeMerkleLogHash = MerkleLogHash . decodeMerkleRoot {-# INLINE unsafeMerkleLogHash #-} -encodeMerkleLogHash :: MerkleLogHash a -> Put +encodeMerkleLogHash :: MerkleHashAlgorithm a => MerkleLogHash a -> Put encodeMerkleLogHash (MerkleLogHash bytes) = putByteString $ encodeMerkleRoot bytes {-# INLINE encodeMerkleLogHash #-} decodeMerkleLogHash - :: MerkleHashAlgorithm a + :: IncrementalHash a => Get (MerkleLogHash a) decodeMerkleLogHash = unsafeMerkleLogHash <$> getByteString (int merkleLogHashBytesCount) {-# INLINE decodeMerkleLogHash #-} instance Hashable (MerkleLogHash a) where - hashWithSalt s = xor s - . unsafeDupablePerformIO . flip BA.withByteArray (peek @Int) + hashWithSalt s = xor s . int . fromRight 0 . peekByteArray64 -- BlockHashes are already cryptographically strong hashes -- that include the chain id. {-# INLINE hashWithSalt #-} -nullHashBytes :: MerkleHashAlgorithm a => MerkleLogHash a +nullHashBytes :: IncrementalHash a => MerkleLogHash a nullHashBytes = unsafeMerkleLogHash $ B.replicate (int merkleLogHashBytesCount) 0x00 {-# NOINLINE nullHashBytes #-} -oneHashBytes :: MerkleHashAlgorithm a => MerkleLogHash a +oneHashBytes :: IncrementalHash a => MerkleLogHash a oneHashBytes = unsafeMerkleLogHash $ B.replicate (int merkleLogHashBytesCount) 0xff {-# NOINLINE oneHashBytes #-} @@ -128,7 +132,7 @@ merkleLogHashToText = encodeB64UrlNoPaddingText . runPutS . encodeMerkleLogHash {-# INLINE merkleLogHashToText #-} merkleLogHashFromText - :: MerkleHashAlgorithm a + :: IncrementalHash a => MonadThrow m => T.Text -> m (MerkleLogHash a) @@ -143,13 +147,13 @@ instance MerkleHashAlgorithm a => HasTextRepresentation (MerkleLogHash a) where {-# INLINE fromText #-} instance MerkleHashAlgorithm a => ToJSON (MerkleLogHash a) where - toJSON = toJSON . toText - toEncoding = toEncoding . toText + toJSON = toJSON . merkleLogHashToText + toEncoding = toEncoding . merkleLogHashToText {-# INLINE toJSON #-} {-# INLINE toEncoding #-} instance MerkleHashAlgorithm a => ToJSONKey (MerkleLogHash a) where - toJSONKey = toJSONKeyText toText + toJSONKey = toJSONKeyText merkleLogHashToText {-# INLINE toJSONKey #-} instance MerkleHashAlgorithm a => FromJSON (MerkleLogHash a) where @@ -158,5 +162,5 @@ instance MerkleHashAlgorithm a => FromJSON (MerkleLogHash a) where instance MerkleHashAlgorithm a => FromJSONKey (MerkleLogHash a) where fromJSONKey = FromJSONKeyTextParser - $ either fail return . eitherFromText + $ either (fail . displayException) return . fromText {-# INLINE fromJSONKey #-} diff --git a/src/Chainweb/MerkleUniverse.hs b/src/Chainweb/MerkleUniverse.hs index 8bdea24e08..1287041915 100644 --- a/src/Chainweb/MerkleUniverse.hs +++ b/src/Chainweb/MerkleUniverse.hs @@ -1,15 +1,24 @@ -{-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE EmptyCase #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE ImportQualifiedPost #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeAbstractions #-} +{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# OPTIONS_GHC -fno-warn-orphans #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE TypeOperators #-} -- | -- Module: Chainweb.MerkleUniverse @@ -31,15 +40,22 @@ module Chainweb.MerkleUniverse , merkleRootTypeToText , merkleRootTypeFromText , MerkleRootMismatch(..) + +, fromSomeTagVal +, fromTagVal +, Sing (..) +, pattern STagVal +, sTagVal ) where import Control.DeepSeq import Control.Monad.Catch -import Crypto.Hash.Algorithms - import Data.Aeson -import qualified Data.Text as T +import Data.Hash.SHA2 +import Data.Kind +import Data.Singletons +import Data.Text qualified as T import Data.Void import GHC.Generics @@ -49,20 +65,25 @@ import GHC.Stack import Chainweb.Crypto.MerkleLog import Chainweb.Utils +import Control.Monad +import Data.Word +import GHC.TypeNats +import Data.Type.Equality +import Unsafe.Coerce -- -------------------------------------------------------------------------- -- -- Chainweb Merkle Hash Algorithm -type ChainwebMerkleHashAlgorithm = SHA512t_256 +type ChainwebMerkleHashAlgorithm = Sha2_512_256 -- -------------------------------------------------------------------------- -- -- Chainweb Merkle Universe --- | Tags for Leaf Nodes in the Chainweb Merkle Tree +-- | The closed kind of tags for Leaf Nodes in the Chainweb Merkle Tree. -- -- IMPORTANT NOTE: -- --- A tag MUST uniquely identify the each particular use of a type in the Merkle +-- A tag MUST uniquely identify each particular use of a type in the Merkle -- Tree. NEVER EVER reuse a tag at a different place in the tree. -- -- Merkle Proofs for the Chainweb Merkle tree witness the existence of a given @@ -70,6 +91,12 @@ type ChainwebMerkleHashAlgorithm = SHA512t_256 -- in different roles in multiple places in the tree, the proof will be -- ambiguous. -- +-- Particular care must be taken for types that are used as roots of the tree +-- (MerkleRoot :: MerkleNotType). It is generally assumed that the preimage of +-- of the respective hashes are computed from leafs that themselfs are tagged. +-- If an attack can control the preimage of a root hash, they can create valid +-- proofs for arbtirary values. +-- data ChainwebHashTag = VoidTag | MerkleRootTag @@ -97,7 +124,34 @@ data ChainwebHashTag | BlockEventsHashTag | RequestKeyTag | PactEventTag - deriving (Show, Eq) + + -- Minimal Payload Provider + | MinimalPayloadTag + + -- Ethereum EL + | EthParentHashTag + | EthOmmersHashTag + | EthBeneficiaryTag + | EthStateRootTag + | EthTransactionsRootTag + | EthReceiptsRootTag + | EthBloomTag + | EthDifficultyTag + | EthBlockNumberTag + | EthGasLimitTag + | EthGasUsedTag + | EthTimestampTag + | EthExtraDataTag + | EthRandaoTag + | EthNonceTag + | EthBaseFeePerGasTag + | EthWithdrawalsRootTag + | EthBlobGasUsedTag + | EthExcessBlobGasTag + | EthParentBeaconBlockRootTag + | EthReceiptTag + | EthRequestsHashTag + deriving (Show, Eq, Bounded, Enum) instance MerkleUniverse ChainwebHashTag where type MerkleTagVal ChainwebHashTag 'VoidTag = 0x0000 @@ -127,7 +181,34 @@ instance MerkleUniverse ChainwebHashTag where type MerkleTagVal ChainwebHashTag 'RequestKeyTag = 0x0032 type MerkleTagVal ChainwebHashTag 'PactEventTag = 0x0034 -instance HashAlgorithm a => IsMerkleLogEntry a ChainwebHashTag Void where + -- Minimal Payload Provider + type MerkleTagVal ChainwebHashTag 'MinimalPayloadTag = 0x0035 + + -- Ethereum EL + type MerkleTagVal ChainwebHashTag 'EthParentHashTag = 0x0040 + type MerkleTagVal ChainwebHashTag 'EthOmmersHashTag = 0x0041 + type MerkleTagVal ChainwebHashTag 'EthBeneficiaryTag = 0x0042 + type MerkleTagVal ChainwebHashTag 'EthStateRootTag = 0x0043 + type MerkleTagVal ChainwebHashTag 'EthTransactionsRootTag = 0x0044 + type MerkleTagVal ChainwebHashTag 'EthReceiptsRootTag = 0x0045 + type MerkleTagVal ChainwebHashTag 'EthBloomTag = 0x0046 + type MerkleTagVal ChainwebHashTag 'EthDifficultyTag = 0x0047 + type MerkleTagVal ChainwebHashTag 'EthBlockNumberTag = 0x0048 + type MerkleTagVal ChainwebHashTag 'EthGasLimitTag = 0x0049 + type MerkleTagVal ChainwebHashTag 'EthGasUsedTag = 0x004a + type MerkleTagVal ChainwebHashTag 'EthTimestampTag = 0x004b + type MerkleTagVal ChainwebHashTag 'EthExtraDataTag = 0x004c + type MerkleTagVal ChainwebHashTag 'EthRandaoTag = 0x004d + type MerkleTagVal ChainwebHashTag 'EthNonceTag = 0x004e + type MerkleTagVal ChainwebHashTag 'EthBaseFeePerGasTag = 0x004f + type MerkleTagVal ChainwebHashTag 'EthWithdrawalsRootTag = 0x0050 + type MerkleTagVal ChainwebHashTag 'EthBlobGasUsedTag = 0x0051 + type MerkleTagVal ChainwebHashTag 'EthExcessBlobGasTag = 0x0052 + type MerkleTagVal ChainwebHashTag 'EthParentBeaconBlockRootTag = 0x0053 + type MerkleTagVal ChainwebHashTag 'EthReceiptTag = 0x0054 + type MerkleTagVal ChainwebHashTag 'EthRequestsHashTag = 0x0055 + +instance MerkleHashAlgorithm a => IsMerkleLogEntry a ChainwebHashTag Void where type Tag Void = 'VoidTag toMerkleNode = \case fromMerkleNode _ = throwM @@ -177,3 +258,387 @@ data MerkleRootMismatch = MerkleRootMismatch instance Exception MerkleRootMismatch +-- -------------------------------------------------------------------------- -- +-- Singletons + +data instance Sing :: ChainwebHashTag -> Type where + SVoidTag + :: SNat (MerkleTagVal ChainwebHashTag VoidTag) + -> Sing 'VoidTag + SMerkleRootTag + :: SNat (MerkleTagVal ChainwebHashTag MerkleRootTag) + -> Sing 'MerkleRootTag + SChainIdTag + :: SNat (MerkleTagVal ChainwebHashTag ChainIdTag) + -> Sing 'ChainIdTag + SBlockHeightTag + :: SNat (MerkleTagVal ChainwebHashTag BlockHeightTag) + -> Sing 'BlockHeightTag + SBlockWeightTag + :: SNat (MerkleTagVal ChainwebHashTag BlockWeightTag) + -> Sing 'BlockWeightTag + SBlockPayloadHashTag + :: SNat (MerkleTagVal ChainwebHashTag BlockPayloadHashTag) + -> Sing 'BlockPayloadHashTag + SForkStateTag + :: SNat (MerkleTagVal ChainwebHashTag ForkStateTag) + -> Sing 'ForkStateTag + SBlockCreationTimeTag + :: SNat (MerkleTagVal ChainwebHashTag BlockCreationTimeTag) + -> Sing 'BlockCreationTimeTag + SChainwebVersionTag + :: SNat (MerkleTagVal ChainwebHashTag ChainwebVersionTag) + -> Sing 'ChainwebVersionTag + SPowHashTag + :: SNat (MerkleTagVal ChainwebHashTag PowHashTag) + -> Sing 'PowHashTag + SBlockHashTag + :: SNat (MerkleTagVal ChainwebHashTag BlockHashTag) + -> Sing 'BlockHashTag + SHashTargetTag + :: SNat (MerkleTagVal ChainwebHashTag HashTargetTag) + -> Sing 'HashTargetTag + STransactionTag + :: SNat (MerkleTagVal ChainwebHashTag TransactionTag) + -> Sing 'TransactionTag + STransactionOutputTag + :: SNat (MerkleTagVal ChainwebHashTag TransactionOutputTag) + -> Sing 'TransactionOutputTag + SBlockTransactionsHashTag + :: SNat (MerkleTagVal ChainwebHashTag BlockTransactionsHashTag) + -> Sing 'BlockTransactionsHashTag + SBlockOutputsHashTag + :: SNat (MerkleTagVal ChainwebHashTag BlockOutputsHashTag) + -> Sing 'BlockOutputsHashTag + SMinerDataTag + :: SNat (MerkleTagVal ChainwebHashTag MinerDataTag) + -> Sing 'MinerDataTag + SCoinbaseOutputTag + :: SNat (MerkleTagVal ChainwebHashTag CoinbaseOutputTag) + -> Sing 'CoinbaseOutputTag + SEpochStartTimeTag + :: SNat (MerkleTagVal ChainwebHashTag EpochStartTimeTag) + -> Sing 'EpochStartTimeTag + SBlockNonceTag + :: SNat (MerkleTagVal ChainwebHashTag BlockNonceTag) + -> Sing 'BlockNonceTag + SOutputEventsTag + :: SNat (MerkleTagVal ChainwebHashTag OutputEventsTag) + -> Sing 'OutputEventsTag + SBlockEventsHashTag + :: SNat (MerkleTagVal ChainwebHashTag BlockEventsHashTag) + -> Sing 'BlockEventsHashTag + SRequestKeyTag + :: SNat (MerkleTagVal ChainwebHashTag RequestKeyTag) + -> Sing 'RequestKeyTag + SPactEventTag + :: SNat (MerkleTagVal ChainwebHashTag PactEventTag) + -> Sing 'PactEventTag + SMinimalPayloadTag + :: SNat (MerkleTagVal ChainwebHashTag MinimalPayloadTag) + -> Sing 'MinimalPayloadTag + SEthParentHashTag + :: SNat (MerkleTagVal ChainwebHashTag EthParentHashTag) + -> Sing 'EthParentHashTag + SEthOmmersHashTag + :: SNat (MerkleTagVal ChainwebHashTag EthOmmersHashTag) + -> Sing 'EthOmmersHashTag + SEthBeneficiaryTag + :: SNat (MerkleTagVal ChainwebHashTag EthBeneficiaryTag) + -> Sing 'EthBeneficiaryTag + SEthStateRootTag + :: SNat (MerkleTagVal ChainwebHashTag EthStateRootTag) + -> Sing 'EthStateRootTag + SEthTransactionsRootTag + :: SNat (MerkleTagVal ChainwebHashTag EthTransactionsRootTag) + -> Sing 'EthTransactionsRootTag + SEthReceiptsRootTag + :: SNat (MerkleTagVal ChainwebHashTag EthReceiptsRootTag) + -> Sing 'EthReceiptsRootTag + SEthBloomTag + :: SNat (MerkleTagVal ChainwebHashTag EthBloomTag) + -> Sing 'EthBloomTag + SEthDifficultyTag + :: SNat (MerkleTagVal ChainwebHashTag EthDifficultyTag) + -> Sing 'EthDifficultyTag + SEthBlockNumberTag + :: SNat (MerkleTagVal ChainwebHashTag EthBlockNumberTag) + -> Sing 'EthBlockNumberTag + SEthGasLimitTag + :: SNat (MerkleTagVal ChainwebHashTag EthGasLimitTag) + -> Sing 'EthGasLimitTag + SEthGasUsedTag + :: SNat (MerkleTagVal ChainwebHashTag EthGasUsedTag) + -> Sing 'EthGasUsedTag + SEthTimestampTag + :: SNat (MerkleTagVal ChainwebHashTag EthTimestampTag) + -> Sing 'EthTimestampTag + SEthExtraDataTag + :: SNat (MerkleTagVal ChainwebHashTag EthExtraDataTag) + -> Sing 'EthExtraDataTag + SEthRandaoTag + :: SNat (MerkleTagVal ChainwebHashTag EthRandaoTag) + -> Sing 'EthRandaoTag + SEthNonceTag + :: SNat (MerkleTagVal ChainwebHashTag EthNonceTag) + -> Sing 'EthNonceTag + SEthBaseFeePerGasTag + :: SNat (MerkleTagVal ChainwebHashTag EthBaseFeePerGasTag) + -> Sing 'EthBaseFeePerGasTag + SEthWithdrawalsRootTag + :: SNat (MerkleTagVal ChainwebHashTag EthWithdrawalsRootTag) + -> Sing 'EthWithdrawalsRootTag + SEthBlobGasUsedTag + :: SNat (MerkleTagVal ChainwebHashTag EthBlobGasUsedTag) + -> Sing 'EthBlobGasUsedTag + SEthExcessBlobGasTag + :: SNat (MerkleTagVal ChainwebHashTag EthExcessBlobGasTag) + -> Sing 'EthExcessBlobGasTag + SEthParentBeaconBlockRootTag + :: SNat (MerkleTagVal ChainwebHashTag EthParentBeaconBlockRootTag) + -> Sing 'EthParentBeaconBlockRootTag + SEthReceiptTag + :: SNat (MerkleTagVal ChainwebHashTag EthReceiptTag) + -> Sing 'EthReceiptTag + SEthRequestsHashTag + :: SNat (MerkleTagVal ChainwebHashTag EthRequestsHashTag) + -> Sing 'EthRequestsHashTag + +deriving instance Show (Sing (a :: ChainwebHashTag)) + +instance Eq (Sing (a :: ChainwebHashTag)) where + _ == _ = True + +instance TestEquality (Sing @ChainwebHashTag) where + testEquality a b = case testEquality (sTagVal a) (sTagVal b) of + Just Refl -> Just $ unsafeCoerce Refl + -- This is justified by the injectivity of 'MerkleTagVal' + Nothing -> Nothing + +sTagVal :: Sing (a :: ChainwebHashTag) -> SNat (MerkleTagVal ChainwebHashTag a) +sTagVal (SVoidTag n) = n +sTagVal (SMerkleRootTag n) = n +sTagVal (SChainIdTag n) = n +sTagVal (SBlockHeightTag n) = n +sTagVal (SBlockWeightTag n) = n +sTagVal (SBlockPayloadHashTag n) = n +sTagVal (SForkStateTag n) = n +sTagVal (SBlockCreationTimeTag n) = n +sTagVal (SChainwebVersionTag n) = n +sTagVal (SPowHashTag n) = n +sTagVal (SBlockHashTag n) = n +sTagVal (SHashTargetTag n) = n +sTagVal (STransactionTag n) = n +sTagVal (STransactionOutputTag n) = n +sTagVal (SBlockTransactionsHashTag n) = n +sTagVal (SBlockOutputsHashTag n) = n +sTagVal (SMinerDataTag n) = n +sTagVal (SCoinbaseOutputTag n) = n +sTagVal (SEpochStartTimeTag n) = n +sTagVal (SBlockNonceTag n) = n +sTagVal (SOutputEventsTag n) = n +sTagVal (SBlockEventsHashTag n) = n +sTagVal (SRequestKeyTag n) = n +sTagVal (SPactEventTag n) = n +sTagVal (SMinimalPayloadTag n) = n +sTagVal (SEthParentHashTag n) = n +sTagVal (SEthOmmersHashTag n) = n +sTagVal (SEthBeneficiaryTag n) = n +sTagVal (SEthStateRootTag n) = n +sTagVal (SEthTransactionsRootTag n) = n +sTagVal (SEthReceiptsRootTag n) = n +sTagVal (SEthBloomTag n) = n +sTagVal (SEthDifficultyTag n) = n +sTagVal (SEthBlockNumberTag n) = n +sTagVal (SEthGasLimitTag n) = n +sTagVal (SEthGasUsedTag n) = n +sTagVal (SEthTimestampTag n) = n +sTagVal (SEthExtraDataTag n) = n +sTagVal (SEthRandaoTag n) = n +sTagVal (SEthNonceTag n) = n +sTagVal (SEthBaseFeePerGasTag n) = n +sTagVal (SEthWithdrawalsRootTag n) = n +sTagVal (SEthBlobGasUsedTag n) = n +sTagVal (SEthExcessBlobGasTag n) = n +sTagVal (SEthParentBeaconBlockRootTag n) = n +sTagVal (SEthReceiptTag n) = n +sTagVal (SEthRequestsHashTag n) = n + +pattern STagVal + :: forall (a :: ChainwebHashTag) + . SNat (MerkleTagVal ChainwebHashTag a) + -> Sing a +pattern STagVal n <- (sTagVal -> n) +{-# COMPLETE STagVal #-} + +instance SingI 'VoidTag where sing = SVoidTag SNat +instance SingI 'MerkleRootTag where sing = SMerkleRootTag SNat +instance SingI 'ChainIdTag where sing = SChainIdTag SNat +instance SingI 'BlockHeightTag where sing = SBlockHeightTag SNat +instance SingI 'BlockWeightTag where sing = SBlockWeightTag SNat +instance SingI 'BlockPayloadHashTag where sing = SBlockPayloadHashTag SNat +instance SingI 'ForkStateTag where sing = SForkStateTag SNat +instance SingI 'BlockCreationTimeTag where sing = SBlockCreationTimeTag SNat +instance SingI 'ChainwebVersionTag where sing = SChainwebVersionTag SNat +instance SingI 'PowHashTag where sing = SPowHashTag SNat +instance SingI 'BlockHashTag where sing = SBlockHashTag SNat +instance SingI 'HashTargetTag where sing = SHashTargetTag SNat +instance SingI 'TransactionTag where sing = STransactionTag SNat +instance SingI 'TransactionOutputTag where sing = STransactionOutputTag SNat +instance SingI 'BlockTransactionsHashTag where sing = SBlockTransactionsHashTag SNat +instance SingI 'BlockOutputsHashTag where sing = SBlockOutputsHashTag SNat +instance SingI 'MinerDataTag where sing = SMinerDataTag SNat +instance SingI 'CoinbaseOutputTag where sing = SCoinbaseOutputTag SNat +instance SingI 'EpochStartTimeTag where sing = SEpochStartTimeTag SNat +instance SingI 'BlockNonceTag where sing = SBlockNonceTag SNat +instance SingI 'OutputEventsTag where sing = SOutputEventsTag SNat +instance SingI 'BlockEventsHashTag where sing = SBlockEventsHashTag SNat +instance SingI 'RequestKeyTag where sing = SRequestKeyTag SNat +instance SingI 'PactEventTag where sing = SPactEventTag SNat +instance SingI 'MinimalPayloadTag where sing = SMinimalPayloadTag SNat +instance SingI 'EthParentHashTag where sing = SEthParentHashTag SNat +instance SingI 'EthOmmersHashTag where sing = SEthOmmersHashTag SNat +instance SingI 'EthBeneficiaryTag where sing = SEthBeneficiaryTag SNat +instance SingI 'EthStateRootTag where sing = SEthStateRootTag SNat +instance SingI 'EthTransactionsRootTag where sing = SEthTransactionsRootTag SNat +instance SingI 'EthReceiptsRootTag where sing = SEthReceiptsRootTag SNat +instance SingI 'EthBloomTag where sing = SEthBloomTag SNat +instance SingI 'EthDifficultyTag where sing = SEthDifficultyTag SNat +instance SingI 'EthBlockNumberTag where sing = SEthBlockNumberTag SNat +instance SingI 'EthGasLimitTag where sing = SEthGasLimitTag SNat +instance SingI 'EthGasUsedTag where sing = SEthGasUsedTag SNat +instance SingI 'EthTimestampTag where sing = SEthTimestampTag SNat +instance SingI 'EthExtraDataTag where sing = SEthExtraDataTag SNat +instance SingI 'EthRandaoTag where sing = SEthRandaoTag SNat +instance SingI 'EthNonceTag where sing = SEthNonceTag SNat +instance SingI 'EthBaseFeePerGasTag where sing = SEthBaseFeePerGasTag SNat +instance SingI 'EthWithdrawalsRootTag where sing = SEthWithdrawalsRootTag SNat +instance SingI 'EthBlobGasUsedTag where sing = SEthBlobGasUsedTag SNat +instance SingI 'EthExcessBlobGasTag where sing = SEthExcessBlobGasTag SNat +instance SingI 'EthParentBeaconBlockRootTag where sing = SEthParentBeaconBlockRootTag SNat +instance SingI 'EthReceiptTag where sing = SEthReceiptTag SNat +instance SingI 'EthRequestsHashTag where sing = SEthRequestsHashTag SNat + +instance SingKind ChainwebHashTag where + type Demote ChainwebHashTag = ChainwebHashTag + fromSing (SVoidTag SNat) = VoidTag + fromSing (SMerkleRootTag SNat) = MerkleRootTag + fromSing (SChainIdTag SNat) = ChainIdTag + fromSing (SBlockHeightTag SNat) = BlockHeightTag + fromSing (SBlockWeightTag SNat) = BlockWeightTag + fromSing (SBlockPayloadHashTag SNat) = BlockPayloadHashTag + fromSing (SForkStateTag SNat) = ForkStateTag + fromSing (SBlockCreationTimeTag SNat) = BlockCreationTimeTag + fromSing (SChainwebVersionTag SNat) = ChainwebVersionTag + fromSing (SPowHashTag SNat) = PowHashTag + fromSing (SBlockHashTag SNat) = BlockHashTag + fromSing (SHashTargetTag SNat) = HashTargetTag + fromSing (STransactionTag SNat) = TransactionTag + fromSing (STransactionOutputTag SNat) = TransactionOutputTag + fromSing (SBlockTransactionsHashTag SNat) = BlockTransactionsHashTag + fromSing (SBlockOutputsHashTag SNat) = BlockOutputsHashTag + fromSing (SMinerDataTag SNat) = MinerDataTag + fromSing (SCoinbaseOutputTag SNat) = CoinbaseOutputTag + fromSing (SEpochStartTimeTag SNat) = EpochStartTimeTag + fromSing (SBlockNonceTag SNat) = BlockNonceTag + fromSing (SOutputEventsTag SNat) = OutputEventsTag + fromSing (SBlockEventsHashTag SNat) = BlockEventsHashTag + fromSing (SRequestKeyTag SNat) = RequestKeyTag + fromSing (SPactEventTag SNat) = PactEventTag + fromSing (SMinimalPayloadTag SNat) = MinimalPayloadTag + fromSing (SEthParentHashTag SNat) = EthParentHashTag + fromSing (SEthOmmersHashTag SNat) = EthOmmersHashTag + fromSing (SEthBeneficiaryTag SNat) = EthBeneficiaryTag + fromSing (SEthStateRootTag SNat) = EthStateRootTag + fromSing (SEthTransactionsRootTag SNat) = EthTransactionsRootTag + fromSing (SEthReceiptsRootTag SNat) = EthReceiptsRootTag + fromSing (SEthBloomTag SNat) = EthBloomTag + fromSing (SEthDifficultyTag SNat) = EthDifficultyTag + fromSing (SEthBlockNumberTag SNat) = EthBlockNumberTag + fromSing (SEthGasLimitTag SNat) = EthGasLimitTag + fromSing (SEthGasUsedTag SNat) = EthGasUsedTag + fromSing (SEthTimestampTag SNat) = EthTimestampTag + fromSing (SEthExtraDataTag SNat) = EthExtraDataTag + fromSing (SEthRandaoTag SNat) = EthRandaoTag + fromSing (SEthNonceTag SNat) = EthNonceTag + fromSing (SEthBaseFeePerGasTag SNat) = EthBaseFeePerGasTag + fromSing (SEthWithdrawalsRootTag SNat) = EthWithdrawalsRootTag + fromSing (SEthBlobGasUsedTag SNat) = EthBlobGasUsedTag + fromSing (SEthExcessBlobGasTag SNat) = EthExcessBlobGasTag + fromSing (SEthParentBeaconBlockRootTag SNat) = EthParentBeaconBlockRootTag + fromSing (SEthReceiptTag SNat) = EthReceiptTag + fromSing (SEthRequestsHashTag SNat) = EthRequestsHashTag + + toSing VoidTag = SomeSing (SVoidTag SNat) + toSing MerkleRootTag = SomeSing (SMerkleRootTag SNat) + toSing ChainIdTag = SomeSing (SChainIdTag SNat) + toSing BlockHeightTag = SomeSing (SBlockHeightTag SNat) + toSing BlockWeightTag = SomeSing (SBlockWeightTag SNat) + toSing BlockPayloadHashTag = SomeSing (SBlockPayloadHashTag SNat) + toSing ForkStateTag = SomeSing (SForkStateTag SNat) + toSing BlockCreationTimeTag = SomeSing (SBlockCreationTimeTag SNat) + toSing ChainwebVersionTag = SomeSing (SChainwebVersionTag SNat) + toSing PowHashTag = SomeSing (SPowHashTag SNat) + toSing BlockHashTag = SomeSing (SBlockHashTag SNat) + toSing HashTargetTag = SomeSing (SHashTargetTag SNat) + toSing TransactionTag = SomeSing (STransactionTag SNat) + toSing TransactionOutputTag = SomeSing (STransactionOutputTag SNat) + toSing BlockTransactionsHashTag = SomeSing (SBlockTransactionsHashTag SNat) + toSing BlockOutputsHashTag = SomeSing (SBlockOutputsHashTag SNat) + toSing MinerDataTag = SomeSing (SMinerDataTag SNat) + toSing CoinbaseOutputTag = SomeSing (SCoinbaseOutputTag SNat) + toSing EpochStartTimeTag = SomeSing (SEpochStartTimeTag SNat) + toSing BlockNonceTag = SomeSing (SBlockNonceTag SNat) + toSing OutputEventsTag = SomeSing (SOutputEventsTag SNat) + toSing BlockEventsHashTag = SomeSing (SBlockEventsHashTag SNat) + toSing RequestKeyTag = SomeSing (SRequestKeyTag SNat) + toSing PactEventTag = SomeSing (SPactEventTag SNat) + toSing MinimalPayloadTag = SomeSing (SMinimalPayloadTag SNat) + toSing EthParentHashTag = SomeSing (SEthParentHashTag SNat) + toSing EthOmmersHashTag = SomeSing (SEthOmmersHashTag SNat) + toSing EthBeneficiaryTag = SomeSing (SEthBeneficiaryTag SNat) + toSing EthStateRootTag = SomeSing (SEthStateRootTag SNat) + toSing EthTransactionsRootTag = SomeSing (SEthTransactionsRootTag SNat) + toSing EthReceiptsRootTag = SomeSing (SEthReceiptsRootTag SNat) + toSing EthBloomTag = SomeSing (SEthBloomTag SNat) + toSing EthDifficultyTag = SomeSing (SEthDifficultyTag SNat) + toSing EthBlockNumberTag = SomeSing (SEthBlockNumberTag SNat) + toSing EthGasLimitTag = SomeSing (SEthGasLimitTag SNat) + toSing EthGasUsedTag = SomeSing (SEthGasUsedTag SNat) + toSing EthTimestampTag = SomeSing (SEthTimestampTag SNat) + toSing EthExtraDataTag = SomeSing (SEthExtraDataTag SNat) + toSing EthRandaoTag = SomeSing (SEthRandaoTag SNat) + toSing EthNonceTag = SomeSing (SEthNonceTag SNat) + toSing EthBaseFeePerGasTag = SomeSing (SEthBaseFeePerGasTag SNat) + toSing EthWithdrawalsRootTag = SomeSing (SEthWithdrawalsRootTag SNat) + toSing EthBlobGasUsedTag = SomeSing (SEthBlobGasUsedTag SNat) + toSing EthExcessBlobGasTag = SomeSing (SEthExcessBlobGasTag SNat) + toSing EthParentBeaconBlockRootTag = SomeSing (SEthParentBeaconBlockRootTag SNat) + toSing EthReceiptTag = SomeSing (SEthReceiptTag SNat) + toSing EthRequestsHashTag = SomeSing (SEthRequestsHashTag SNat) + +tagList :: [ChainwebHashTag] +tagList = [minBound .. maxBound] + +fromTagVal :: forall m . MonadThrow m => Word16 -> m ChainwebHashTag +fromTagVal x = case msum (f <$> tagList) of + Just t -> return t + Nothing -> throwM $ DecodeException $ "unknown tag value: " <> sshow x + where + f :: ChainwebHashTag -> Maybe ChainwebHashTag + f t = case (toSing @ChainwebHashTag t) of + (SomeSing (STagVal (SNat @s))) -> do + guard (natVal_ @s == int x) + Just t + +fromSomeTagVal :: forall m . MonadThrow m => Word16 -> m (SomeSing ChainwebHashTag) +fromSomeTagVal x = case msum (f <$> tagList) of + Just t -> return t + Nothing -> throwM $ DecodeException $ "unknown tag value: " <> sshow x + where + f :: ChainwebHashTag -> Maybe (SomeSing ChainwebHashTag) + f t = case (toSing @ChainwebHashTag t) of + r@(SomeSing (STagVal (SNat @s))) -> do + guard (natVal_ @s == int x) + Just r + diff --git a/src/Chainweb/Miner/Config.hs b/src/Chainweb/Miner/Config.hs index 97fc76fbd4..1ea306d03a 100644 --- a/src/Chainweb/Miner/Config.hs +++ b/src/Chainweb/Miner/Config.hs @@ -6,6 +6,7 @@ {-# LANGUAGE NumericUnderscores #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ImportQualifiedPost #-} -- | -- Module: Chainweb.Miner.Config @@ -26,41 +27,30 @@ module Chainweb.Miner.Config , CoordinationConfig(..) , pCoordinationConfig , coordinationEnabled -, coordinationMiners -, coordinationUpdateStreamLimit +-- , coordinationMiners +-- , coordinationUpdateStreamLimit , coordinationUpdateStreamTimeout -, coordinationPayloadRefreshDelay , coordinationTargetForkOverride , NodeMiningConfig(..) , defaultNodeMining , nodeMiningEnabled -, nodeMiner , nodeTestMiners , MinerCount(..) -, invalidMiner ) where import Configuration.Utils -import Control.Lens (lens, view) +import Control.Lens (lens) import Control.Monad (when) import Control.Monad.Except (throwError) import Control.Monad.Writer (tell) -import qualified Data.Set as S - import GHC.Generics (Generic) import Numeric.Natural (Natural) -import Options.Applicative - -import qualified Pact.JSON.Encode as J -import Pact.Types.Term (mkKeySet, PublicKeyText(..)) - -- internal modules -import Chainweb.Miner.Pact (Miner(..), MinerKeys(..), MinerId(..), minerId) import Chainweb.Time import Chainweb.Utils (hostArch, sshow) import Chainweb.Version @@ -78,8 +68,8 @@ newtype MinerCount = MinerCount { _minerCount :: Natural } -- -------------------------------------------------------------------------- -- -- Mining Config -validateMinerConfig :: ChainwebVersion -> ConfigValidation MiningConfig [] -validateMinerConfig v c = do +validateMinerConfig :: HasVersion => ConfigValidation MiningConfig [] +validateMinerConfig c = do when (_nodeMiningEnabled nmc) $ do tell [ "In-node mining is enabled. This should only be used for testing" @@ -87,9 +77,6 @@ validateMinerConfig v c = do ] when (not (_coordinationEnabled cc)) $ throwError "In-node mining is enabled but mining coordination is disabled" - when (view minerId (_nodeMiner nmc) == "") - $ throwError "In-node Mining is enabled but no miner id is configured" - when (_coordinationEnabled cc && isProd) $ do when (hostArch `notElem` supportedArchs) $ do throwError $ mconcat @@ -104,13 +91,14 @@ validateMinerConfig v c = do -- future we may also consider uname -m and/or cpuinfo (including flags) here. -- supportedArchs = [ "x86_64" ] - isProd = v `elem` [Mainnet01, Testnet04] + isProd = implicitVersion `elem` [Mainnet01, Testnet04] -- | Full configuration for Mining. -- data MiningConfig = MiningConfig { _miningCoordination :: !CoordinationConfig - , _miningInNode :: !NodeMiningConfig } + , _miningInNode :: !NodeMiningConfig + } deriving stock (Eq, Show) miningCoordination :: Lens' MiningConfig CoordinationConfig @@ -122,7 +110,8 @@ miningInNode = lens _miningInNode (\m c -> m { _miningInNode = c }) instance ToJSON MiningConfig where toJSON o = object [ "coordination" .= _miningCoordination o - , "nodeMining" .= _miningInNode o ] + , "nodeMining" .= _miningInNode o + ] instance FromJSON (MiningConfig -> MiningConfig) where parseJSON = withObject "MiningConfig" $ \o -> id @@ -142,7 +131,8 @@ pMiningConfig = id defaultMining :: MiningConfig defaultMining = MiningConfig { _miningCoordination = defaultCoordination - , _miningInNode = defaultNodeMining } + , _miningInNode = defaultNodeMining + } -- -------------------------------------------------------------------------- -- -- Mining Coordination Config @@ -152,18 +142,8 @@ data CoordinationConfig = CoordinationConfig { _coordinationEnabled :: !Bool -- ^ Is mining coordination enabled? If not, the @/mining/@ won't even be -- present on the node. - , _coordinationMiners :: !(S.Set Miner) - -- ^ This field must contain at least one `Miner` identity in order for - -- work requests to be made. - , _coordinationReqLimit :: !Int - -- ^ The number of @/mining/work/@ requests that can be made to this node - -- in a 5 minute period. - , _coordinationUpdateStreamLimit :: !Int - -- ^ the maximum number of concurrent update streams that is supported , _coordinationUpdateStreamTimeout :: !Seconds -- ^ the duration that an update stream is kept open in seconds - , _coordinationPayloadRefreshDelay :: !(TimeSpan Micros) - -- ^ the duration between payload refreshes in microseconds , _coordinationTargetForkOverride :: !Bool -- ^ whether to hold back voting on the next fork number increment } deriving stock (Eq, Show, Generic) @@ -171,24 +151,10 @@ data CoordinationConfig = CoordinationConfig coordinationEnabled :: Lens' CoordinationConfig Bool coordinationEnabled = lens _coordinationEnabled (\m c -> m { _coordinationEnabled = c }) -coordinationLimit :: Lens' CoordinationConfig Int -coordinationLimit = lens _coordinationReqLimit (\m c -> m { _coordinationReqLimit = c }) - -coordinationMiners :: Lens' CoordinationConfig (S.Set Miner) -coordinationMiners = lens _coordinationMiners (\m c -> m { _coordinationMiners = c }) - -coordinationUpdateStreamLimit :: Lens' CoordinationConfig Int -coordinationUpdateStreamLimit = - lens _coordinationUpdateStreamLimit (\m c -> m { _coordinationUpdateStreamLimit = c }) - coordinationUpdateStreamTimeout :: Lens' CoordinationConfig Seconds coordinationUpdateStreamTimeout = lens _coordinationUpdateStreamTimeout (\m c -> m { _coordinationUpdateStreamTimeout = c }) -coordinationPayloadRefreshDelay :: Lens' CoordinationConfig (TimeSpan Micros) -coordinationPayloadRefreshDelay = - lens _coordinationPayloadRefreshDelay (\m c -> m { _coordinationPayloadRefreshDelay = c }) - coordinationTargetForkOverride :: Lens' CoordinationConfig Bool coordinationTargetForkOverride = lens _coordinationTargetForkOverride (\m c -> m { _coordinationTargetForkOverride = c }) @@ -196,32 +162,20 @@ coordinationTargetForkOverride = instance ToJSON CoordinationConfig where toJSON o = object [ "enabled" .= _coordinationEnabled o - , "limit" .= _coordinationReqLimit o - , "miners" .= (J.toJsonViaEncode <$> S.toList (_coordinationMiners o)) - , "updateStreamLimit" .= _coordinationUpdateStreamLimit o , "updateStreamTimeout" .= _coordinationUpdateStreamTimeout o - , "payloadRefreshDelay" .= _coordinationPayloadRefreshDelay o , "targetForkOverride" .= _coordinationTargetForkOverride o ] instance FromJSON (CoordinationConfig -> CoordinationConfig) where parseJSON = withObject "CoordinationConfig" $ \o -> id <$< coordinationEnabled ..: "enabled" % o - <*< coordinationLimit ..: "limit" % o - <*< coordinationMiners .fromLeftMonoidalUpdate %.: "miners" % o - <*< coordinationUpdateStreamLimit ..: "updateStreamLimit" % o <*< coordinationUpdateStreamTimeout ..: "updateStreamTimeout" % o - <*< coordinationPayloadRefreshDelay ..: "payloadRefreshDelay" % o <*< coordinationTargetForkOverride ..: "targetForkOverride" % o defaultCoordination :: CoordinationConfig defaultCoordination = CoordinationConfig { _coordinationEnabled = False - , _coordinationMiners = mempty - , _coordinationReqLimit = 1200 - , _coordinationUpdateStreamLimit = 2000 , _coordinationUpdateStreamTimeout = 240 - , _coordinationPayloadRefreshDelay = TimeSpan (Micros 15_000_000) , _coordinationTargetForkOverride = False } @@ -230,32 +184,22 @@ pCoordinationConfig = id <$< coordinationEnabled .:: enableDisableFlag % long "mining-coordination" <> help "whether to enable the mining coordination API" - <*< coordinationMiners %:: pLeftMonoidalUpdate (S.singleton <$> pMiner "") - <*< coordinationLimit .:: jsonOption - % long "mining-request-limit" - <> help "Number of /mining/work requests that can be made within a 5min period" - <*< coordinationUpdateStreamLimit .:: jsonOption - % long "mining-update-stream-limit" - <> help "maximum number of concurrent update streams that is supported" <*< coordinationUpdateStreamTimeout .:: jsonOption % long "mining-update-stream-timeout" <> help "duration that an update stream is kept open in seconds" - <*< coordinationPayloadRefreshDelay .:: jsonOption - % long "mining-payload-refresh-delay" - <> help "frequency that the mining payload is refreshed" <*< coordinationTargetForkOverride .:: flag' True % long "mining-target-fork-override" <> help "do not vote for the next fork number increment" -pMiner :: String -> Parser Miner -pMiner prefix = pkToMiner <$> pPk - where - pkToMiner pk = Miner - (MinerId $ "k:" <> _pubKey pk) - (MinerKeys $ mkKeySet [pk] "keys-all") - pPk = strOption - % long (prefix <> "mining-public-key") - <> help "public key of a miner in hex decimal encoding. The account name is the public key prefix by 'k:'. (This option can be provided multiple times.)" +-- pMiner :: String -> MParser Miner +-- pMiner prefix = pkToMiner <$> pPk +-- where +-- pkToMiner pk = Miner +-- (MinerId $ "k:" <> _pubKey pk) +-- (MinerKeys $ mkKeySet [pk] "keys-all") +-- pPk = strOption +-- % long (prefix <> "mining-public-key") +-- <> help "public key of a miner in hex decimal encoding. The account name is the public key prefix by 'k:'. (This option can be provided multiple times.)" -- -------------------------------------------------------------------------- -- -- Node Mining Config @@ -264,9 +208,6 @@ data NodeMiningConfig = NodeMiningConfig { _nodeMiningEnabled :: !Bool -- ^ If enabled, this node will mine with a single CPU along with its -- other responsibilities. - , _nodeMiner :: !Miner - -- ^ If enabled, a `Miner` identity must be supplied in order to assign - -- mining rewards. , _nodeTestMiners :: !MinerCount -- ^ Strictly for testing. } deriving stock (Eq, Show, Generic) @@ -274,36 +215,26 @@ data NodeMiningConfig = NodeMiningConfig nodeMiningEnabled :: Lens' NodeMiningConfig Bool nodeMiningEnabled = lens _nodeMiningEnabled (\m c -> m { _nodeMiningEnabled = c }) -nodeMiner :: Lens' NodeMiningConfig Miner -nodeMiner = lens _nodeMiner (\m c -> m { _nodeMiner = c }) - nodeTestMiners :: Lens' NodeMiningConfig MinerCount nodeTestMiners = lens _nodeTestMiners (\m c -> m { _nodeTestMiners = c }) instance ToJSON NodeMiningConfig where toJSON o = object [ "enabled" .= _nodeMiningEnabled o - , "miner" .= J.toJsonViaEncode (_nodeMiner o) ] instance FromJSON (NodeMiningConfig -> NodeMiningConfig) where parseJSON = withObject "NodeMiningConfig" $ \o -> id <$< nodeMiningEnabled ..: "enabled" % o - <*< nodeMiner ..: "miner" % o pNodeMiningConfig :: MParser NodeMiningConfig pNodeMiningConfig = id <$< nodeMiningEnabled .:: enableDisableFlag % long "node-mining" <> help "ONLY FOR TESTING NETWORKS: whether to enable in node mining" - <*< nodeMiner .:: pMiner "node-" defaultNodeMining :: NodeMiningConfig defaultNodeMining = NodeMiningConfig { _nodeMiningEnabled = False - , _nodeMiner = invalidMiner , _nodeTestMiners = MinerCount 10 } - -invalidMiner :: Miner -invalidMiner = Miner "" . MinerKeys $ mkKeySet [] "keys-all" diff --git a/src/Chainweb/Miner/Coordinator.hs b/src/Chainweb/Miner/Coordinator.hs index a5a2fc210d..812f8db381 100644 --- a/src/Chainweb/Miner/Coordinator.hs +++ b/src/Chainweb/Miner/Coordinator.hs @@ -1,82 +1,64 @@ {-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE BlockArguments #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE ImportQualifiedPost #-} {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NumericUnderscores #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternGuards #-} {-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE ViewPatterns #-} -{-# LANGUAGE MultiWayIf #-} -- | -- Module: Chainweb.Miner.Coordinator --- Copyright: Copyright © 2018 - 2020 Kadena LLC. +-- Copyright: Copyright © 2018 - 2024 Kadena LLC. -- License: MIT -- Maintainer: Lars Kuhtz , Colin Woodbury -- Stability: experimental -- --- - module Chainweb.Miner.Coordinator -( -- * Types - MiningState(..) -, miningState -, MiningStats(..) -, PrevTime(..) -, ChainChoice(..) -, PrimedWork(..) -, WorkState(..) -, MiningCoordination(..) +( -- * Mining Coordination API + MiningCoordination(..) , NoAsscociatedPayload(..) - --- * Mining API Functions +, runCoordination +, newMiningCoordination , work , solve --- ** Internal Functions -, publish -) where +-- * Internal -import Control.Concurrent -import Control.Concurrent.Async (withAsync) -import Control.Concurrent.STM (atomically, retry) -import Control.Concurrent.STM.TVar -import Control.DeepSeq (NFData) -import Control.Lens -import Control.Monad -import Control.Monad.Catch - -import Data.Aeson (ToJSON) -import qualified Data.ByteString as BS -import qualified Data.HashMap.Strict as HM -import qualified Data.HashSet as HS -import Data.IORef -import qualified Data.List as List -import qualified Data.Map.Strict as M -import Data.Maybe(mapMaybe) -import qualified Data.Text as T -import qualified Data.Vector as V +-- * ParentState +, ParentState(..) +, awaitLatestPayloadForParentStateSTM -import GHC.Generics (Generic) -import GHC.Stack +-- ** Payload Caches +, type PayloadCaches +, newPayloadCaches +, awaitPayloadsNext -import System.LogLevel (LogLevel(..)) +-- ** MiningState +, updateForCut +, updateForSolved --- internal modules +-- ** Delivery +, randomWork + +) where import Chainweb.BlockCreationTime -import Chainweb.BlockHash (BlockHash) +import Chainweb.BlockHash import Chainweb.BlockHeader -import Chainweb.Cut hiding (join) +import Chainweb.BlockHeight +import Chainweb.ChainValue +import Chainweb.Core.Brief +import Chainweb.Cut import Chainweb.Cut.Create import Chainweb.Cut.CutHashes import Chainweb.CutDB @@ -84,373 +66,710 @@ import Chainweb.ForkState(ForkNumber(..)) import Chainweb.Logger (Logger, logFunction) import Chainweb.Logging.Miner import Chainweb.Miner.Config -import Chainweb.Miner.Pact (Miner(..), MinerId(..), minerId) -import Chainweb.Payload -import Chainweb.Sync.WebBlockHeaderStore -import Chainweb.Time (Micros(..), Time(..), getCurrentTimeIntegral) +import Chainweb.Miner.PayloadCache +import Chainweb.Parent +import Chainweb.PayloadProvider +import Chainweb.Storage.Table +import Chainweb.Time (Micros(..), getCurrentTimeIntegral) import Chainweb.Utils hiding (check) import Chainweb.Version -import Chainweb.Version.Utils import Chainweb.WebBlockHeaderDB -import Chainweb.WebPactExecutionService - -import Data.LogMessage (JsonLog(..), LogFunction) +import Control.Applicative +import Control.Concurrent.STM (atomically, STM, retry) +import Control.Concurrent.STM.TVar +import Control.Exception.Safe +import Control.Lens +import Control.Monad +import Control.Monad.Except +import Control.Monad.IO.Class +import Control.Monad.Trans.Class +import Data.HashMap.Strict qualified as HM +import Data.HashSet qualified as HS +import Data.Hashable +import Data.List qualified as List +import Data.LogMessage (JsonLog(..), LogFunction, LogFunctionText) +import Data.Maybe +import Data.Text qualified as T +import Data.Vector qualified as V +import GHC.Generics (Generic) +import Numeric.Natural +import Pact.JSON.Encode qualified as J +import Streaming.Prelude qualified as S +import System.LogLevel (LogLevel(..)) +import System.Random (randomRIO) -- -------------------------------------------------------------------------- -- -- Utils --- | Lookup a 'BlockHeader' for a 'ChainId' in a cut and raise a meaningfull --- error if the lookup fails. --- --- Generally, failing lookup in a cut is a code invariant violation. In almost --- all circumstances there should be a invariant in scope that guarantees that --- the lookup succeeds. This function is useful when debugging corner cases of --- new code logic, like graph changes. --- -lookupInCut :: HasCallStack => HasChainId cid => Cut -> cid -> BlockHeader -lookupInCut c cid - | Just x <- lookupCutM cid c = x - | otherwise = error $ T.unpack - $ "Chainweb.Miner.Coordinator.lookupInCut: failed to lookup chain in cut." - <> " Chain: " <> sshow (_chainId cid) <> "." - <> " Cut Hashes: " <> encodeToText (cutToCutHashes Nothing c) <> "." +type WorkParentsId = (Parent BlockHash, AdjacentsHash) --- -------------------------------------------------------------------------- -- --- MiningCoordination +parentsId :: WorkParents -> WorkParentsId +parentsId ps = + ( view blockHash <$> _workParent ps + , adjacentsHash (_workParentsAdjacentHashes ps) + ) --- | For coordinating requests for work and mining solutions from remote Mining --- Clients. --- -data MiningCoordination logger tbl = MiningCoordination - { _coordLogger :: !logger - , _coordCutDb :: !(CutDb tbl) - , _coordState :: !(TVar MiningState) - , _coordLimit :: !Int - , _coord503s :: !(IORef Int) - , _coord403s :: !(IORef Int) - , _coordConf :: !CoordinationConfig - , _coordUpdateStreamCount :: !(IORef Int) - , _coordPrimedWork :: !(TVar PrimedWork) - , _coordTargetFork :: !ForkNumber - } +solvedId :: SolvedWork -> WorkParentsId +solvedId s = + ( _solvedParentHash s + , _solvedAdjacentHash s + ) --- | Precached payloads for Private Miners. This allows new work requests to be --- made as often as desired, without clogging the Pact queue. --- -newtype PrimedWork = - PrimedWork (HM.HashMap MinerId (HM.HashMap ChainId WorkState)) - deriving newtype (Semigroup, Monoid) - deriving stock Generic - deriving anyclass (Wrapped) +-- -------------------------------------------------------------------------- -- +-- Payload Caches -data WorkState - = WorkReady NewBlock - -- ^ We have work ready for the miner - | WorkAlreadyMined BlockHash - -- ^ A block with this parent has already been mined and submitted to the - -- cut pipeline - we don't want to mine it again. - | WorkStale - -- ^ No work has been produced yet with the latest parent block on this - -- chain. - deriving stock (Show) +type PayloadCaches = ChainMap PayloadCache -isWorkReady :: WorkState -> Bool -isWorkReady = \case - WorkReady {} -> True - _ -> False +newPayloadCaches :: HasVersion => IO PayloadCaches +newPayloadCaches = tabulateChainsM (\_ -> newIO depth) + where + -- FIXME: Make this configurable? + depth :: Natural + depth = diameter (chainGraphAt (maxBound :: BlockHeight)) --- | Data shared between the mining threads represented by `newWork` and --- `publish`. +-- | Await the next payload for a cut that is different from the latest payload. -- --- The key is hash of the current block's payload. +-- FIXME: can this race if some chains get new payloads at a very high rate? +-- How can we make this fair? Maybe shuffle xs? -- -newtype MiningState = MiningState - { _miningState :: M.Map BlockPayloadHash (T3 Miner PayloadWithOutputs (Time Micros)) } - deriving stock (Generic) - deriving newtype (Semigroup, Monoid) +awaitPayloadsNext + :: PayloadCaches + -> Cut + -- ^ The cut for which the new payload is awaited. + -> V.Vector Int + -- ^ The hash/fingerprint of the previous value for each chain. + -> STM NewPayload +awaitPayloadsNext caches c prevs = msum (awaitChain <$> itoList xs) + where + xs = chainIntersect (,) caches rhs + rhs = ChainMap $ Parent . _rankedBlockHash <$> _cutHeaders c -makeLenses ''MiningState + awaitChain (ChainId cid, (ca, rh)) = do + x <- awaitLatestSTM ca rh + -- unsafeIndex relies on caches prevs being as least as long as caches + -- and chainids being a prefix of the natural numbers. + guard (hash x /= V.unsafeIndex prevs(int cid)) + return x --- | For logging during `MiningState` manipulation. --- -data MiningStats = MiningStats - { _statsCacheSize :: !Int - , _stats503s :: !Int - , _stats403s :: !Int - , _statsAvgTxs :: !Int - , _statsPrimedSize :: !Int } - deriving stock (Generic) - deriving anyclass (ToJSON, NFData) +-- -------------------------------------------------------------------------- -- +-- Work State --- | The `BlockCreationTime` of the parent of some current, "working" --- `BlockHeader`. +-- | The mining work state of a chain. +-- +-- Two things must happen for work to be ready: +-- +-- 1. The payload provider must provide a 'NewPayload' and +-- 2. Consensus must provide a cut on which the chain is mineable. +-- +-- When both is available a 'WorkHeader' can be created. +-- +-- We call a chain "blocked" when it can not be mined in the current cut because +-- some adjacent header is missing for a correctly braided extension of the +-- chain. +-- +-- We call a chain "stale" when there is no payload available for extending the +-- chain with a new block. +-- +-- We call a chain "not ready" if a chain is "blocked" and "stale". We call a +-- chain "ready" when it is neither "blocked" nor "stale". +-- +-- We call a chain "solved" if new block has been mined on the chain for the +-- current cut, but the cut has not yet been updated to include the new block. +-- +-- The following demonstrates how cuts are extended: -- -newtype PrevTime = PrevTime BlockCreationTime +-- - n: new work +-- - p: work parent +-- - a: work adjacent parent +-- +-- @ +-- * n +-- | x | \ +-- a p a +-- | x | x | +-- * * * +-- @ +-- +-- The extension of indiviual chains in cuts is non-monotonic. It is possible +-- that the parent header remains the same but the adjacent parents change. It +-- is also possible that stale work becomes NotReady or that ready work becomes +-- blocked. Similarly, solved work can become blocked again. If the parent +-- header stayls the same the same payload may be used again. Only if the parent +-- header changes the a new (or an previously used) payload must be obtained. +-- +-- The transition function for the work state machine is as follows: +-- +-- @ +-- "" -> NotReady [label="header"]; +-- NotReady -> Blocked [label=payload]; +-- NotReady -> Stale [label=unblock]; +-- Blocked -> Ready [label=unblock]; +-- Blocked -> Blocked [label=payload]; +-- Stale -> Ready [label=payload]; +-- Stale -> NotReady [label=block]; +-- Stale -> Stale [label=unblock]; +-- Ready -> Solved [label=solve]; +-- Ready -> Blocked [label=block]; +-- Ready -> Ready [label="payload,unblock"]; +-- Solved -> Blocked [label=block]; +-- Solved -> Ready [label=unblock]; +-- Solved -> Solved [label=payload]; +-- @ +-- +data ParentState = ParentState + { parentStateParents :: !WorkParents + -- ^ Invariant: The work parents must match the ranked block hash. + , parentStateSolved :: !(Maybe SolvedWork) + -- ^ A block with these parents has already been solved and submitted to the + -- cut pipeline - we don't want to mine it again. So we wait until the + -- current cut is updated with a new parent header for this chain. + } + deriving stock (Show, Eq, Generic) -data ChainChoice = Anything | TriedLast !ChainId | Suggestion !ChainId +awaitLatestPayloadForParentStateSTM :: PayloadCache -> ParentState -> STM NewPayload +awaitLatestPayloadForParentStateSTM payloadCache parentState = do + let parent = fmap (view rankedBlockHash) $ _workParent' $ parentStateParents parentState + awaitLatestSTM payloadCache parent --- | Construct a new `BlockHeader` to mine on. --- -newWork - :: LogFunction - -> ChainChoice - -> ForkNumber - -> Miner - -> WebBlockHeaderDb - -- ^ this is used to lookup parent headers that are not in the cut - -- itself. - -> PactExecutionService - -> TVar PrimedWork - -> Cut - -> IO (Maybe (T2 WorkHeader PayloadWithOutputs)) -newWork logFun choice targetFork eminer@(Miner mid _) hdb pact tpw c = do +instance Brief ParentState where + brief ParentState{..} = + "ParentState:" <> brief parentStateParents + <> ":solved=" <> brief parentStateSolved - -- Randomly pick a chain to mine on. we no longer support the caller - -- specifying any particular one. - -- - cid <- case choice of - Anything -> randomChainIdAt c (_cutMinHeight c) - Suggestion cid' -> pure cid' - TriedLast _ -> randomChainIdAt c (_cutMinHeight c) - logFun @T.Text Debug $ "newWork: picked chain " <> toText cid - - -- wait until at least one chain has primed work. we don't wait until *our* - -- chain has primed work, because if other chains have primed work, we want - -- to loop and select one of those chains. it is not a normal situation to - -- have no chains with primed work if there are more than a couple chains. - mpw <- atomically $ do - PrimedWork pw <- readTVar tpw - mpw <- maybe retry return (HM.lookup mid pw) - guard (any isWorkReady mpw) - return mpw - let mr = T2 - <$> HM.lookup cid mpw - <*> getCutExtension c cid - - case mr of - Just (T2 WorkStale _) -> do - logFun @T.Text Debug $ "newWork: chain " <> toText cid <> " has stale work" - newWork logFun Anything targetFork eminer hdb pact tpw c - Just (T2 (WorkAlreadyMined _) _) -> do - logFun @T.Text Debug $ "newWork: chain " <> sshow cid <> " has a payload that was already mined" - newWork logFun Anything targetFork eminer hdb pact tpw c - Nothing -> do - logFun @T.Text Debug $ "newWork: chain " <> toText cid <> " not mineable" - newWork logFun Anything targetFork eminer hdb pact tpw c - Just (T2 (WorkReady newBlock) extension) -> do - let (primedParentHash, primedParentHeight, _) = newBlockParent newBlock - if primedParentHash == view blockHash (_parentHeader (_cutExtensionParent extension)) - then do - let payload = newBlockToPayloadWithOutputs newBlock - let !phash = _payloadWithOutputsPayloadHash payload - !wh <- newWorkHeader hdb targetFork extension phash - pure $ Just $ T2 wh payload - else do - -- The cut is too old or the primed work is outdated. Probably - -- the former because it the mining coordination background job - -- is updating the primed work cache regularly. We could try - -- another chain, but it's safer to just return 'Nothing' here - -- and retry with an updated cut. - -- - let !extensionParent = _parentHeader (_cutExtensionParent extension) - logFun @T.Text Info - $ "newWork: chain " <> toText cid <> " not mineable because of parent header mismatch" - <> ". Primed parent hash: " <> toText primedParentHash - <> ". Primed parent height: " <> sshow primedParentHeight - <> ". Extension parent: " <> toText (view blockHash extensionParent) - <> ". Extension height: " <> sshow (view blockHeight extensionParent) - - return Nothing +-- -------------------------------------------------------------------------- -- +-- Mining State + +newMiningState :: HasVersion => IO (ChainMap (TVar (Maybe ParentState))) +newMiningState = do + states <- forM cids $ \cid -> do + var <- newTVarIO Nothing + return (cid, var) + return $! onChains states + where --- | Accepts a "solved" `BlockHeader` from some external source (e.g. a remote --- mining client), attempts to reassociate it with the current best `Cut`, and --- publishes the result to the `Cut` network. + cids :: [ChainId] + cids = HS.toList chainIds + +-- TODO: consider storing the mining state more efficiently: -- --- There are a number of "fail fast" conditions which will kill the candidate --- `BlockHeader` before it enters the Cut pipeline. +-- Do not recompute cut extensions more often than needed. -- -publish - :: LogFunction - -> CutDb tbl - -> TVar PrimedWork - -> MinerId - -> PayloadWithOutputs - -> SolvedWork +-- * store the current cut +-- * when a new cut arrive compute which chains need update + +-- | Update work state for all chains for a new cut. +-- +updateForCut + :: HasVersion + => (ChainValue BlockHash -> IO BlockHeader) + -> ChainMap (TVar (Maybe ParentState)) + -> Cut -> IO () -publish lf cdb pwVar miner pwo s = do - c <- _cut cdb - now <- getCurrentTimeIntegral - try (extend c pwo s) >>= \case - - -- Publish CutHashes to CutDb and log success - Right (bh, Just ch) -> do - - -- reset the primed payload for this cut extension - atomically $ modifyTVar pwVar $ \(PrimedWork pw) -> - PrimedWork $! HM.adjust (HM.insert (_chainId bh) (WorkAlreadyMined (view blockParent bh))) miner pw - - addCutHashes cdb ch - - let bytes = sum . fmap (BS.length . _transactionBytes . fst) $ - _payloadWithOutputsTransactions pwo - lf Info $ JsonLog $ NewMinedBlock - { _minedBlockHeader = ObjectEncoded bh - , _minedBlockTrans = int . V.length $ _payloadWithOutputsTransactions pwo - , _minedBlockSize = int bytes - , _minedBlockMiner = _minerId miner - , _minedBlockDiscoveredAt = now - } - - -- Log Orphaned Block - Right (bh, Nothing) -> do - let !p = lookupInCut c bh - lf Info $ orphandMsg now p bh "orphaned solution" - - -- Log failure and rethrow - Left e@(InvalidSolvedHeader bh msg) -> do - let !p = lookupInCut c bh - lf Info $ orphandMsg now p bh msg - throwM e +updateForCut hdb ms c = do + forM_ (HM.keys (c ^. cutMap)) forChain where - orphandMsg now p bh msg = JsonLog OrphanedBlock - { _orphanedHeader = ObjectEncoded bh - , _orphanedBestOnCut = ObjectEncoded p + forChain cid = do + let parentStateVar = ms ^?! atChain cid + maybeNewParents <- workParents hdb c cid + atomically $ do + maybeOldParentState <- readTVar parentStateVar + case (maybeOldParentState, maybeNewParents) of + (_, Nothing) -> + writeTVar parentStateVar Nothing + (Just oldParentState, Just newParents) + | parentStateParents oldParentState == newParents + -> return () + (_, Just newParents) -> + writeTVar parentStateVar $ Just + ParentState + { parentStateParents = newParents + , parentStateSolved = Nothing + } + +updateForSolved + :: HasVersion + => LogFunction + -> ForkNumber + -> CutDb l + -> PayloadCache + -> TVar (Maybe ParentState) + -> SolvedWork + -> IO () +updateForSolved lf targetFork cdb payloadCache var sw = do + stateOrErr <- runExceptT $ do + solvedParentState <- mapExceptT atomically $ do + lift (readTVar var) >>= \case + Just parentState + | solvedId sw /= parentsId (parentStateParents parentState) -> + throwError (Just parentState, Info, "orphaned; this block is for an older parent set") + | Just _ <- parentStateSolved parentState -> + throwError (Just parentState, Debug, "this block has already been solved") + | otherwise -> do + let newState = parentState { parentStateSolved = Just sw } + -- speculatively set the work state's solved work. if we have + -- trouble integrating this block, we will revert this after. + lift (writeTVar var (Just newState)) + return newState + -- orphaned by parent disappearance + Nothing -> + throwError (Nothing, Info, "orphaned; this block is for a blocked chain") + + c <- lift $ _cut cdb + lift (lookupIO payloadCache (fmap (view rankedBlockHash) $ _workParent $ parentStateParents solvedParentState) (_solvedPayloadHash sw)) >>= \case + Nothing -> throwError (Just solvedParentState, Warn, "updateForSolved: missing payload in cache: " <> brief solvedParentState) + Just payload -> do + let pld = _newPayloadEncodedPayloadData payload + let pwo = _newPayloadEncodedPayloadOutputs payload + + try (extend targetFork c pld pwo (parentStateParents solvedParentState) sw) >>= \case + + -- Publish CutHashes to CutDb and log success + Right (bh, Just ch) -> do + lift $ publish cdb ch + lift $ logMinedBlock lf bh payload + return solvedParentState + + -- Log Orphaned Block + Right (_, Nothing) -> do + throwError (Just solvedParentState, Info, "orphaned; this block is for an older parent set") + + Left (InvalidSolvedHeader msg) -> do + throwError (Just solvedParentState, Warn, "invalid solved header: " <> msg) + + case stateOrErr of + Right s' -> lf Info $ "updateForSolved: new block solved: " <> brief s' + Left (staleMaybeParentState, level, err) -> do + lf level $ "updateForSolved: block not solved: " <> err + -- an error has occurred when trying to integrate this block; + -- reset the work state's solved work, if the parents have not + -- changed since the failure. + forM_ staleMaybeParentState $ \staleParentState -> atomically $ do + latestMaybeParentState <- readTVar var + case latestMaybeParentState of + Just latestParentState + | parentsId (parentStateParents staleParentState) + == parentsId (parentStateParents latestParentState) + -> writeTVar var $ Just latestParentState { parentStateSolved = Nothing } + _ -> return () + now <- getCurrentTimeIntegral + lf Info $ orphandMsg now err + where + + orphandMsg now msg = JsonLog OrphanedBlock + { _orphanedParent = _solvedParentHash sw + , _orphanedPayloadHash = _solvedPayloadHash sw , _orphanedDiscoveredAt = now - , _orphanedMiner = _minerId miner , _orphanedReason = msg } -- -------------------------------------------------------------------------- -- --- Mining API +-- MiningCoordination --- | Get new work +-- | For coordinating requests for work and mining solutions from remote Mining +-- Clients. -- --- This function does not check if the miner is authorized. If the miner doesn't --- yet exist in the primed work cache it is added. +data MiningCoordination logger = MiningCoordination + { _coordLogger :: !logger + , _coordCutDb :: !(CutDb logger) + , _coordParentState :: !(ChainMap (TVar (Maybe ParentState))) + , _coordConf :: !CoordinationConfig + , _coordPayloadCache :: !PayloadCaches + , _coordTargetFork :: !ForkNumber + } + +newMiningCoordination + :: Logger logger + => HasVersion + => logger + -> CoordinationConfig + -> CutDb logger + -> IO (MiningCoordination logger) +newMiningCoordination logger conf cdb = do + state <- newMiningState + caches <- newPayloadCaches + return $ MiningCoordination + { _coordLogger = logger + , _coordCutDb = cdb + , _coordParentState = state + , _coordConf = conf + , _coordPayloadCache = caches + , _coordTargetFork = + if _coordinationTargetForkOverride conf + then pred $ max 1 (_versionForkNumber implicitVersion) + else _versionForkNumber implicitVersion + } + +-- | Listen on the cut stream and payloads stream and update the mining state +-- accordingly. -- -work - :: forall l tbl +-- FIXME: be more concrete about the following: +-- +-- Updates are intentionally not transactional. We value low latencies and and +-- progress over consistency with respect to the latest state of the payload +-- caches or cut pipeline. However, individual payload states are internally +-- consistent. +-- +-- It can thus happen that updates to payloads and cuts are lost due to races. +-- This is supposed to be rare. +-- +runCoordination + :: forall l . Logger l - => MiningCoordination l tbl - -> Maybe ChainId - -> Miner - -> IO WorkHeader -work mr mcid m = do - T2 wh pwo <- - withAsync (logDelays False 0) $ \_ -> newWorkForCut - now <- getCurrentTimeIntegral - atomically - . modifyTVar' (_coordState mr) - . over miningState - . M.insert (_payloadWithOutputsPayloadHash pwo) - $ T3 m pwo now - return wh + => HasVersion + => MiningCoordination l + -> IO () +runCoordination mr = do + -- Initialize Work State for provider caches, without this isolated networks + -- fail to start mining. + initializeState + + updateWork where - -- here we log the case that the work loop has stalled. - logDelays :: Bool -> Int -> IO () - logDelays loggedOnce n = do - if loggedOnce - then threadDelay 60_000_000 - else threadDelay 10_000_000 - let !n' = n + 1 - PrimedWork primedWork <- readTVarIO (_coordPrimedWork mr) - -- technically this is in a race with the newWorkForCut function, - -- which is likely benign when the mining loop has stalled for 10 seconds. - currentCut <- _cut cdb - let primedWorkMsg = - case HM.lookup (view minerId m) primedWork of - Nothing -> - "no primed work for miner key" <> sshow m - Just mpw -> - let chainsWithBlocks = HS.fromMap $ flip HM.mapMaybe mpw $ \case - WorkReady {} -> Just () - _ -> Nothing - in if - | HS.null chainsWithBlocks -> - "no chains have primed blocks" - | cids == chainsWithBlocks -> - "all chains have primed blocks" - | otherwise -> - "chains with primed blocks may be stalled. chains with primed work: " - <> sshow (toText <$> List.sort (HS.toList chainsWithBlocks)) - let extensibleChains = - HS.fromList $ mapMaybe (\cid -> cid <$ getCutExtension currentCut cid) $ HS.toList cids - let extensibleChainsMsg = - if HS.null extensibleChains - then "no chains are extensible in the current cut! here it is: " <> sshow currentCut - else "the following chains can be extended in the current cut: " <> sshow (toText <$> HS.toList extensibleChains) - logf @T.Text Warn $ - "findWork: stalled for " <> - ( - if loggedOnce - then "10s" - else sshow n' <> "m" - ) <> - ". " <> primedWorkMsg <> ". " <> extensibleChainsMsg - - logDelays True n' - - v = _chainwebVersion hdb - cids = chainIds v - - -- There is no strict synchronization between the primed work cache and the - -- new work selection. There is a chance that work selection picks a primed - -- work that is out of sync with the current cut. In that case we just try - -- again with a new cut. In case the cut was good but the primed work was - -- outdated, chances are that in the next attempt we pick a different chain - -- with update work or that the primed work cache caught up in the meantime. - -- - newWorkForCut = do - c' <- _cut cdb - newWork logf choice (_coordTargetFork mr) m hdb pact (_coordPrimedWork mr) c' >>= \case - Nothing -> newWorkForCut - Just x -> return x + lf :: LogFunctionText + lf = logFunction $ _coordLogger mr - logf :: LogFunction - logf = logFunction $ _coordLogger mr + caches = _coordPayloadCache mr + state = _coordParentState mr hdb :: WebBlockHeaderDb - hdb = view cutDbWebBlockHeaderDb cdb + hdb = view cutDbWebBlockHeaderDb (_coordCutDb mr) - choice :: ChainChoice - choice = maybe Anything Suggestion mcid + f :: ChainValue BlockHash -> IO BlockHeader + f = fmap _chainValueValue . casLookupM hdb - cdb :: CutDb tbl cdb = _coordCutDb mr - pact :: PactExecutionService - pact = _webPactExecutionService $ view cutDbPactService cdb + -- Update the work state + -- + updateWork = runForever lf "miningCoordination" $ do + lf Debug "start updateWork event stream" + eventStream cdb caches + & S.chain (\e -> lf Debug $ "coordination event: " <> brief e) + & S.mapM_ \case + CutEvent c -> updateForCut f state c + NewPayloadEvent _ -> return () + -- There is a race with solved events. Does it matter? + -- We could synchronize those by delivering those via an + -- STM variable, too. + -- TODO: is there still? + + initializeState = do + lf Debug "initialize mining state" + curCut <- _cut cdb + updateForCut f state curCut + lf Debug "done initializing mining state for all chains" + +-- | Note that this stream is lossy. It always delivers the latest available +-- item and skips over any previous items that have not been consumed. +-- +-- We want this behavior, because we want to alway operate on the latest +-- available cut and payload. +-- +-- FIXME: would it be better to use a mutable vector in an IORef (or TVar, if +-- supported)? It would probably be more efficient. +-- +eventStream + :: MonadIO m + => CutDb l + -> PayloadCaches + -> S.Stream (S.Of MiningStateEvent) m r +eventStream cdb caches = do + liftIO (_cut cdb) >>= \c -> do + S.yield (CutEvent c) + + -- Initialze the vector with the previous NewPayload fingerprints with + -- all 0 hashes. + go c (V.replicate (length caches) 0) + where + go cur prevs = do + timeout <- liftIO $ registerDelay 1_000_000 + new <- liftIO $ atomically $ do + CutEvent cur <$ (readTVar timeout >>= guard) + <|> + awaitEvent cdb caches cur prevs + S.yield new + case new of + CutEvent c -> go c prevs + NewPayloadEvent p -> + go cur (V.unsafeUpd prevs [(chainIdInt (_chainId p), hash p)]) + +data MiningStateEvent + = CutEvent Cut + | NewPayloadEvent NewPayload + deriving (Show, Eq, Generic) + +instance Brief MiningStateEvent where + brief (CutEvent c) = "CutEvent::" <> brief c + brief (NewPayloadEvent p) = "NewPayloadEvent::" <> brief p + +-- | NOTE: Cut and payload event race, with precedence given to cuts. If cut +-- arrive at a rate faster than they can be consumed, no payloads are going to +-- be delivered and work will always be 'Stale'. +-- +-- On average cuts arrive at a rate of 1.5 seconds, which is plenty of time to +-- process payload events in between. However, we should monitor for this +-- condition and either warn or throttle cut processing if it ever happens. +-- +awaitEvent + :: CutDb l + -> PayloadCaches + -> Cut + -> V.Vector Int + -> STM MiningStateEvent +awaitEvent cdb caches c p = + CutEvent <$> awaitNewCutStm cdb c + <|> + NewPayloadEvent <$> awaitPayloadsNext caches c p + +-- -------------------------------------------------------------------------- -- +-- Work Delivery Strategy +-- -------------------------------------------------------------------------- -- + +-- | Get Work from a random Chain. +-- +-- In a chainweb it can never happen that all chains are blocked at the same +-- time. Therefore, if there is no work ready, some chains must be stale. This +-- means that either +-- +-- 1. mining is disableled for some payload providers, +-- 2. consensus did not request new payloads from providers in the latest +-- 'syncToBlock' calls, +-- 3. some payload providers are deadlocked, or +-- 4. some payload providers are very slow in producing new payloads. +-- +randomWork + :: HasVersion + => LogFunction + -> ForkNumber + -> CutDb l + -> PayloadCaches + -> ChainMap (TVar (Maybe ParentState)) + -> IO MiningWork +randomWork logFun targetFork cdb caches parentStateVars = do + + -- Pick a random chain. + -- + -- This is done by picking a random start index and traversing the work + -- states for all chains in order until ready work is found. + -- + -- Before a graph transition (from when the new graph is declared until it + -- goes into effect) this code is somewhat inefficient, because the new + -- chains do already exist but are always blocked. This means that sometimes + -- the algorithm has to iterate over all new chains to find the next chain + -- that has work ready. We could prune the random range and search space, + -- but at this, point the slight, temporary overhead seems acceptable. + -- + n <- randomRIO (0, length parentStateVars) + + -- NOTE: it is tempting to search for a matching chain within a single STM + -- transaction. However, that is problematic: the search restarts when the + -- work for a chain is updated, which could result in redundant and possibly + -- unbound spinning. Even worse, it could also skew the result due to some + -- chains being more likely to trigger a retry than others. + -- + -- The actual implemention is not transactional but the returned work will + -- still be up to date for the chain. There might be a risk for a small bias + -- towards chains for which block are produced more quickly, but we think, + -- that it is negligible. + -- + let (s0, s1) = splitAt n (itoList parentStateVars) + go (s1 <> s0) + where + awaitWorkReady + :: ChainId + -> TVar (Maybe ParentState) + -> STM (WorkParents, NewPayload) + awaitWorkReady cid var = do + parentState <- maybe retry return =<< readTVar var + guard (isNothing $ parentStateSolved parentState) + case cdb ^?! cutDbPayloadProviders . atChain cid of + ConfiguredPayloadProvider pp -> + latestPayloadSTM pp >>= insertSTM (caches ^?! atChain cid) + DisabledPayloadProvider -> + error $ "payload provider disabled on chain " <> sshow cid <> ", which is illegal for miners" + payload <- awaitLatestPayloadForParentStateSTM (caches ^?! atChain cid) parentState + return (parentStateParents parentState, payload) + + go [] = do + + logFun @T.Text Info "randomWork: no work is ready. Awaiting work" + + -- We shall check for the following conditions: + -- + -- 1. No chain is ready and we haven't received neither new cuts nor + -- new payloads. This is some sort of deadlock in the system. + -- + -- 2. We get new cuts (i.e. chains become unblocked and blocked), but + -- no chain becomes ready. Either payload providers are + -- misconfigured or consensus does not request payload creation. + -- + -- It is also possible that payload production is too slow and + -- chains get updated before a value payload is produced + -- + -- We shall detect the problem by waiting for the respective condition + -- and return the info from the STM loop. + -- + -- We may also retry before we fail definitely. + -- + -- There is a small risk that work gets updated to often and this check + -- spins. But this is very unlikely, because otherwise we wouldn't have + -- gotten stuck in first place. + -- + -- There is a (small) chance that the overall system got too hot, i.e. + -- block are produced too fast for this node to keep up. But the fact + -- that blocks are produced means other mining nodes can keep up. This + -- node will recover, once DA causes the system to cool down. + -- + timeoutVar <- registerDelay (int staleMiningStateDelay) + w <- atomically $ + Right <$> msum (imap awaitWorkReady parentStateVars) + <|> awaitTimeout timeoutVar + case w of + Right (ps, npld) -> do + ct <- BlockCreationTime <$> getCurrentTimeIntegral + return $ newWork targetFork ct ps (_newPayloadBlockPayloadHash npld) + Left e -> error $ + "Chainweb.Miner.Coordinator.randomWork: " <> T.unpack e + -- FIXME: throw a proper exception and log what is going on + + go ((cid, var):t) = do + readyCheck <- atomically $ optional $ awaitWorkReady cid var + case readyCheck of + Just (parents, payload) -> do + ct <- BlockCreationTime <$> getCurrentTimeIntegral + logFun @T.Text Debug $ "randomWork: picked chain " <> brief cid + return $ newWork targetFork ct parents (_newPayloadBlockPayloadHash payload) + Nothing -> do + logFun @T.Text Debug $ "randomWork: not ready for " <> brief cid + go t + + awaitTimeout var = do + + -- this retries until the timeout triggers + readTVar var >>= guard + + -- FIXME: + -- Try to find out what happend: + -- + -- if all chains are not ready or stale we did not get any payload + -- We log a warning and retry + -- + -- if all chains are not ready or blocked we have a consensus problem + -- This is clearly an error, probably even a bug. + -- We should try to find out what happend. + -- + workStatusSummary <- summarizeWorkStatus + return $ Left $ "Chainweb.Miner.Coordinator.randomWork: timeout while waiting for work to become ready. " <> workStatusSummary + + summarizeWorkStatus = do + parentStates <- forM parentStateVars readTVar + let chainsWithMissingParents = + [ cid | (cid, Nothing) <- itoList parentStates ] + let chainsWithParents = onChains + [ (cid, p) | (cid, Just p) <- itoList parentStates ] + payloads <- forM + (chainIntersect (,) chainsWithParents caches) + (\(parent, cache) -> optional $ awaitLatestPayloadForParentStateSTM cache parent) + let chainsWithMissingPayloads = + [ cid | (cid, Nothing) <- itoList payloads ] + c <- _cutStm cdb + return $ J.encodeText $ J.object + [ "blocked" J..= J.array (List.sort (toText <$> chainsWithMissingParents)) + , "stale" J..= J.array (List.sort (toText <$> chainsWithMissingPayloads)) + , "cut" J..= brief c + ] + +staleMiningStateDelay :: Micros +staleMiningStateDelay = 2_000_000 + +-- | This is the legacy work delivery API +-- +work + :: forall l + . Logger l + => HasVersion + => MiningCoordination l + -> IO MiningWork +work mr = randomWork lf (_coordTargetFork mr) (_coordCutDb mr) (_coordPayloadCache mr) (_coordParentState mr) + where + lf :: LogFunction + lf = logFunction $ _coordLogger mr + +-- -------------------------------------------------------------------------- -- +-- Solve Work data NoAsscociatedPayload = NoAsscociatedPayload deriving (Show, Eq) instance Exception NoAsscociatedPayload +-- | Accepts a "solved" `BlockHeader` from some external source (e.g. a remote +-- mining client). +-- +-- It looks up the payload of the solved header from the payload cache and +-- attempts to reassociate it with the current best `Cut`. +-- +-- When the solved work is still valid it is marked as solved in the mining +-- state, logged, injected into the local cut pipline, and finally published to +-- the cut P2P network. +-- +-- There are a number of "fail fast" conditions which will kill the candidate +-- `BlockHeader` before it enters the Cut pipeline. +-- +-- NEW DOC: +-- +-- First we check wether the state is still up to date. If the parents in the +-- mining state for the chain do not match the parents of the solved work, we +-- can't build a header for it and reject it. +-- +-- Next we lookup the payload in the cache. This is expected to succeed. It is +-- an exceptional case if it does not. +-- +-- We then try to extend the current cut. This can fail if the current cut +-- changed asynchronously. If it fails we log an orphaned block. +-- +-- If the cut is extended successfully we publish the new cut and updated +-- the mining state. This can race with other updates to the mining state. +-- However, at this point we don't care. +-- (Should we remove the solved state all together?) +-- solve - :: forall l tbl + :: forall l . Logger l - => MiningCoordination l tbl + => HasVersion + => MiningCoordination l -> SolvedWork -> IO () -solve mr solved@(SolvedWork hdr) = do - -- Fail Early: If a `BlockHeader` comes in that isn't associated with any - -- Payload we know about, reject it. - -- - MiningState ms <- readTVarIO tms - case M.lookup key ms of - Nothing -> throwM NoAsscociatedPayload - Just x -> publishWork x `finally` deleteKey - -- There is a race here, but we don't care if the same cut - -- is published twice. There is also the risk that an item - -- doesn't get deleted. Items get GCed on a regular basis by - -- the coordinator. +solve mr solved = + updateForSolved + lf + (_coordTargetFork mr) + (_coordCutDb mr) + (_coordPayloadCache mr ^?! atChain cid) + (_coordParentState mr ^?! atChain cid) + solved where - key = view blockPayloadHash hdr - tms = _coordState mr + cid = _chainId solved lf :: LogFunction lf = logFunction $ _coordLogger mr - deleteKey = atomically . modifyTVar' tms . over miningState $ M.delete key - publishWork (T3 m pwo _) = - publish lf (_coordCutDb mr) (_coordPrimedWork mr) (view minerId m) pwo solved +logMinedBlock + :: HasVersion + => LogFunction + -> BlockHeader + -> NewPayload + -> IO () +logMinedBlock lf bh np = do + now <- getCurrentTimeIntegral + lf Info $ JsonLog $ NewMinedBlock + { _minedBlockHeader = ObjectEncoded bh + , _minedBlockTrans = _newPayloadTxCount np + , _minedBlockSize = _newPayloadSize np + , _minedBlockOutputSize = _newPayloadOutputSize np + , _minedBlockFees = _newPayloadFees np + , _minedBlockDiscoveredAt = now + } + +publish :: CutDb l -> CutHashes -> IO () +publish = addCutHashes diff --git a/src/Chainweb/Miner/Core.hs b/src/Chainweb/Miner/Core.hs index f775f105e7..8532065316 100644 --- a/src/Chainweb/Miner/Core.hs +++ b/src/Chainweb/Miner/Core.hs @@ -46,6 +46,7 @@ import Chainweb.Difficulty import Chainweb.Time hiding (second) import Chainweb.Utils import Chainweb.Utils.Serialization +import Chainweb.Version (HasVersion) --- @@ -93,9 +94,9 @@ timestampPosition = 8 -- mine :: forall a - . HashAlgorithm a + . (HashAlgorithm a, HasVersion) => Nonce - -> WorkHeader + -> MiningWork -> IO SolvedWork mine orig work = do when (bufSize < noncePosition + sizeOf (0 :: Word64)) $ @@ -137,8 +138,8 @@ mine orig work = do go0 100000 t orig runGetS decodeSolvedWork new where - tbytes = runPutS $ encodeHashTarget (_workHeaderTarget work) - hbytes = BS.fromShort $ _workHeaderBytes work + tbytes = runPutS $ encodeHashTarget (_miningWorkTarget work) + hbytes = BS.fromShort $ _miningWorkBytes work bufSize :: Int !bufSize = B.length hbytes diff --git a/src/Chainweb/Miner/Miners.hs b/src/Chainweb/Miner/Miners.hs index 0b9b3de4ad..c95620d66c 100644 --- a/src/Chainweb/Miner/Miners.hs +++ b/src/Chainweb/Miner/Miners.hs @@ -1,14 +1,13 @@ -{-# LANGUAGE BangPatterns #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ImportQualifiedPost #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NumericUnderscores #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeOperators #-} -- | -- Module: Chainweb.Miner.Miners @@ -38,16 +37,16 @@ import Control.Monad import Crypto.Hash.Algorithms (Blake2s_256) -import qualified Data.ByteString.Short as BS +import Data.ByteString.Short qualified as BS import Data.HashMap.Strict (HashMap) -import qualified Data.HashMap.Strict as HashMap +import Data.HashMap.Strict qualified as HashMap import Numeric.Natural (Natural) import GHC.Stack -import qualified System.Random.MWC as MWC -import qualified System.Random.MWC.Distributions as MWC +import System.Random.MWC qualified as MWC +import System.Random.MWC.Distributions qualified as MWC -- internal modules @@ -59,19 +58,21 @@ import Chainweb.CutDB import Chainweb.Difficulty import Chainweb.Graph import Chainweb.Logger -import Chainweb.Mempool.Mempool -import qualified Chainweb.Mempool.Mempool as Mempool +import Chainweb.Pact.Mempool.Mempool +import Chainweb.Pact.Mempool.Mempool qualified as Mempool import Chainweb.Miner.Config (MinerCount(..)) import Chainweb.Miner.Coordinator import Chainweb.Miner.Core -import Chainweb.Miner.Pact import Chainweb.RestAPI.Orphans () -import qualified Chainweb.Pact4.Transaction as Pact4 +import Chainweb.Pact.Transaction qualified as Pact import Chainweb.Utils import Chainweb.Utils.Serialization import Chainweb.Version -import Data.LogMessage (LogFunction) +import Data.LogMessage (LogFunction, LogFunctionText) +import System.LogLevel +import Control.Concurrent.STM +import Data.Maybe (fromMaybe) -------------------------------------------------------------------------------- -- Local Mining @@ -83,39 +84,40 @@ import Data.LogMessage (LogFunction) localTest :: HasCallStack => Logger logger + => HasVersion => LogFunction - -> ChainwebVersion - -> MiningCoordination logger tbl - -> Miner - -> CutDb tbl + -> MiningCoordination logger + -> CutDb logger -> MWC.GenIO -> MinerCount -> IO () -localTest lf v coord m cdb gen miners = +localTest lf coord cdb gen miners = runForever lf "Chainweb.Miner.Miners.localTest" $ do c <- _cut cdb - wh <- work coord Nothing m - let height = c ^?! ixg (_workHeaderChainId wh) . blockHeight + wh <- work coord + let height = fromMaybe + (genesisHeight (_miningWorkChainId wh)) + (c ^? ixg (_miningWorkChainId wh) . blockHeight) - race (awaitNewCutByChainId cdb (_workHeaderChainId wh) c) (go height wh) >>= \case + race (awaitNewCutByChainId cdb (_miningWorkChainId wh) c) (go height wh) >>= \case Left _ -> return () Right new -> do solve coord new void $ awaitNewCut cdb c where meanBlockTime :: Double - meanBlockTime = int (_getBlockDelay (_versionBlockDelay v)) / 1_000_000 + meanBlockTime = int (_getBlockDelay (_versionBlockDelay implicitVersion)) / 1_000_000 - go :: BlockHeight -> WorkHeader -> IO SolvedWork + go :: BlockHeight -> MiningWork -> IO SolvedWork go height w = do MWC.geometric1 t gen >>= threadDelay - runGetS decodeSolvedWork $ BS.fromShort $ _workHeaderBytes w + runGetS decodeSolvedWork $ BS.fromShort $ _miningWorkBytes w where t :: Double t = int graphOrder / (int (_minerCount miners) * meanBlockTime * 1_000_000) graphOrder :: Natural - graphOrder = order $ chainGraphAt v height + graphOrder = order $ chainGraphAt height -- | A miner that grabs new blocks from mempool and discards them. Mempool -- pruning happens during new-block time, so we need to ask for a new block @@ -123,7 +125,7 @@ localTest lf v coord m cdb gen miners = -- mempoolNoopMiner :: LogFunction - -> HashMap ChainId (MempoolBackend Pact4.UnparsedTransaction) + -> HashMap ChainId (MempoolBackend Pact.Transaction) -> IO () mempoolNoopMiner lf chainRes = runForever lf "Chainweb.Miner.Miners.mempoolNoopMiner" $ do @@ -136,19 +138,44 @@ mempoolNoopMiner lf chainRes = -- localPOW :: Logger logger - => LogFunction - -> MiningCoordination logger tbl - -> Miner - -> CutDb tbl + => HasVersion + => LogFunctionText + -> MiningCoordination logger + -> CutDb logger -> IO () -localPOW lf coord m cdb = runForever lf "Chainweb.Miner.Miners.localPOW" $ do +localPOW lf coord cdb = runForever lf "Chainweb.Miner.Miners.localPOW" $ do c <- _cut cdb - wh <- work coord Nothing m - race (awaitNewCutByChainId cdb (_workHeaderChainId wh) c) (go wh) >>= \case - Left _ -> return () - Right new -> do + lf Debug "request new work for localPOW miner" + wh <- work coord + let cid = _miningWorkChainId wh + lf Debug $ "run localPOW miner on chain " <> toText cid + race (awaitNewCutByChainId cdb cid c) (go wh) >>= \case + Left _ -> do + lf Debug "abondond work due to chain update" + return () + Right (new, h) -> do + lf Debug $ "solved work on chain " <> toText cid solve coord new - void $ awaitNewCut cdb c + + -- There is a potential race here, if the solved block got orphaned. + -- If work isn't updated quickly enough, it can happen that the + -- miner uses an old header. We resolve that by awaiting that the + -- chain is at least as high as the solved work. + -- This can still dead-lock if for some reason the solved work is + -- invalid. + awaitHeight (_chainId new) h where - go :: WorkHeader -> IO SolvedWork - go = mine @Blake2s_256 (Nonce 0) + go :: MiningWork -> IO (SolvedWork, BlockHeight) + go w = do + h <- workHeight w + s <- mine @Blake2s_256 (Nonce 0) w + return (s, h) + + workHeight w = runGetS (skip 258 >> decodeBlockHeight) + $ BS.fromShort + $ _miningWorkBytes w + + awaitHeight cid h = atomically $ do + c <- _cutStm cdb + let h' = view blockHeight $ c ^?! ixg cid + guard (h <= h') diff --git a/src/Chainweb/Miner/Pact.hs b/src/Chainweb/Miner/Pact.hs index 99343addfd..34a7be78b2 100644 --- a/src/Chainweb/Miner/Pact.hs +++ b/src/Chainweb/Miner/Pact.hs @@ -14,19 +14,16 @@ -- Maintainer: Emily Pillmore -- Stability: experimental -- --- The definition of the Pact miner and the Pact miner reward. +-- The definition of the Pact miner. -- module Chainweb.Miner.Pact ( -- * Data MinerId(..) -, MinerKeys(..) +, MinerGuard(..) , Miner(..) -, MinerRewards(..) -- * Combinators , toMinerData , fromMinerData -, readRewards -, rawMinerRewards -- * Optics , minerId , minerKeys @@ -42,27 +39,22 @@ import Control.Lens hiding ((.=)) import Control.Monad.Catch (MonadThrow) import Data.Aeson hiding (decode) -import Data.ByteString (ByteString) -import qualified Data.ByteString.Lazy as BL -import qualified Data.Csv as CSV -import Data.Decimal (Decimal) -import Data.FileEmbed (embedFile) import Data.Hashable -import Data.Map.Strict (Map) -import qualified Data.Map.Strict as M import Data.String (IsString(..)) import Data.Text (Text) -import qualified Data.Vector as V -import Data.Word -- internal modules -import Chainweb.BlockHeight (BlockHeight(..)) -import Chainweb.Payload +import Chainweb.Pact.Payload import Chainweb.Utils import qualified Pact.JSON.Encode as J -import qualified Pact.Types.KeySet as Pact4 +import qualified Pact.Core.Guards as Pact +import qualified Pact.Core.Names as Pact +import qualified Pact.Core.PactValue as Pact +import qualified Pact.Core.StableEncoding as Pact +import Control.Applicative ((<|>)) +import qualified Data.Set as Set -- -------------------------------------------------------------------------- -- -- Miner data @@ -74,17 +66,20 @@ newtype MinerId = MinerId { _minerId :: Text } deriving stock (Eq, Ord, Generic) deriving newtype (Show, ToJSON, FromJSON, IsString, NFData, Hashable, J.Encode) --- | `MinerKeys` are a thin wrapper around a Pact `KeySet` to differentiate it --- from user keysets. +-- | `MinerGuard` is a thin wrapper around a Pact `Guard` to differentiate it +-- from user-level guards. -- -newtype MinerKeys = MinerKeys Pact4.KeySet +newtype MinerGuard = MinerGuard (Pact.Guard Pact.QualifiedName Pact.PactValue) deriving stock (Eq, Ord, Generic) deriving newtype (Show, NFData) -- | Miner info data consists of a miner id (text), and its keyset (a pact -- type). -- -data Miner = Miner !MinerId !MinerKeys +data Miner = Miner + { _minerMinerId :: !MinerId + , _minerMinerGuard :: !MinerGuard + } deriving stock (Eq, Ord, Show, Generic) deriving anyclass (NFData) @@ -95,17 +90,29 @@ data Miner = Miner !MinerId !MinerKeys -- the Genesis Payloads. If these change, the payloads become unreadable! -- instance J.Encode Miner where - build (Miner (MinerId m) (MinerKeys ks)) = J.object + build (Miner (MinerId m) (MinerGuard (Pact.GKeyset ks))) = J.object [ "account" J..= m - , "predicate" J..= Pact4._ksPredFun ks - , "public-keys" J..= J.Array (Pact4._ksKeys ks) + , "predicate" J..= Pact.StableEncoding (Pact._ksPredFun ks) + , "public-keys" J..= J.Array (Pact.StableEncoding <$> Set.toList (Pact._ksKeys ks)) + ] + build (Miner (MinerId m) (MinerGuard g)) = J.object + [ "account" J..= m + , "guard" J..= Pact.StableEncoding g ] {-# INLINE build #-} instance FromJSON Miner where parseJSON = withObject "Miner" $ \o -> Miner <$> (MinerId <$> o .: "account") - <*> (MinerKeys <$> (Pact4.KeySet <$> o .: "public-keys" <*> o .: "predicate")) + <*> + ( + MinerGuard . Pact.GKeyset <$> + (Pact.KeySet <$> + (Set.fromList . fmap Pact._stableEncoding <$> o .: "public-keys") <*> + (Pact._stableEncoding <$> o .: "predicate")) + <|> + MinerGuard . Pact._stableEncoding <$> o .: "guard" + ) -- | A lens into the miner id of a miner. -- @@ -115,8 +122,8 @@ minerId = lens (\(Miner i _) -> i) (\(Miner _ k) b -> Miner b k) -- | A lens into the miner keys of a miner. -- -minerKeys :: Lens' Miner MinerKeys -minerKeys = lens (\(Miner _ k) -> k) (\(Miner i _) b -> Miner i b) +minerKeys :: Lens' Miner MinerGuard +minerKeys = lens (\(Miner _ g) -> g) (\(Miner i _) b -> Miner i b) {-# INLINE minerKeys #-} -- | Keyset taken from cp examples in Pact @@ -124,17 +131,19 @@ minerKeys = lens (\(Miner _ k) -> k) (\(Miner i _) b -> Miner i b) -- defaultMiner :: Miner defaultMiner = Miner (MinerId "miner") - $ MinerKeys - $ Pact4.mkKeySet - ["f880a433d6e2a13a32b6169030f56245efdd8c1b8a5027e9ce98a88e886bef27"] - "keys-all" + $ MinerGuard + $ Pact.GKeyset + $ Pact.KeySet + (Set.fromList [Pact.PublicKeyText "f880a433d6e2a13a32b6169030f56245efdd8c1b8a5027e9ce98a88e886bef27"]) + Pact.KeysAll {-# NOINLINE defaultMiner #-} -- | A trivial Miner. -- noMiner :: Miner -noMiner = Miner (MinerId "NoMiner") (MinerKeys $ Pact4.mkKeySet [] "<") +noMiner = Miner (MinerId "NoMiner") + (MinerGuard $ Pact.GKeyset $ Pact.KeySet mempty (Pact.CustomPredicate (Pact.TBN (Pact.BareName "<")))) {-# NOINLINE noMiner #-} -- | Convert from Pact `Miner` to Chainweb `MinerData`. @@ -148,28 +157,3 @@ toMinerData = MinerData . J.encodeStrict fromMinerData :: MonadThrow m => MinerData -> m Miner fromMinerData = decodeStrictOrThrow' . _minerData {-# INLINABLE fromMinerData #-} - -newtype MinerRewards = MinerRewards - { _minerRewards :: Map BlockHeight Decimal - -- ^ The map of blockheight thresholds to miner rewards - } deriving (Eq, Ord, Show, Generic) - --- | Rewards table mapping 3-month periods to their rewards --- according to the calculated exponential decay over 120 year period --- -readRewards :: MinerRewards -readRewards = - case CSV.decode CSV.NoHeader (BL.fromStrict rawMinerRewards) of - Left e -> error - $ "cannot construct miner reward map: " - <> sshow e - Right vs -> MinerRewards $ M.fromList . V.toList . V.map formatRow $ vs - where - formatRow :: (Word64, CsvDecimal) -> (BlockHeight, Decimal) - formatRow (!a,!b) = (BlockHeight $ int a, _csvDecimal b) - --- | Read in the reward csv via TH for deployment purposes. --- -rawMinerRewards :: ByteString -rawMinerRewards = $(embedFile "rewards/miner_rewards.csv") -{-# NOINLINE rawMinerRewards #-} diff --git a/src/Chainweb/Miner/PayloadCache.hs b/src/Chainweb/Miner/PayloadCache.hs new file mode 100644 index 0000000000..f1b8e51ca3 --- /dev/null +++ b/src/Chainweb/Miner/PayloadCache.hs @@ -0,0 +1,270 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE LambdaCase #-} + +-- | +-- Module: Chainweb.Miner.PayloadCache +-- Copyright: Copyright © 2024 Kadena LLC. +-- License: MIT +-- Maintainer: Lars Kuhtz +-- Stability: experimental +-- +-- As payload providers propose new payloads for the latest blocks those are +-- cached by the miner. +-- +-- NOTE that consensus (and not the mining coordinator or payload provider) +-- decides when it makes sense to produce payloads ontop of a block. It does so +-- by notifying the payload provider in a syncToBlock call. This way block +-- production and mining can be supressed, for instance, during catchup or deep +-- catch merges. +-- +-- Because payloads do not depend on parents on adjacent chains, it always makes +-- sense to compute and cache new payloads because even as chains are still +-- blocked payloads can already be computed. +-- +-- The mining coordinator will request payloads for parent headers as chains +-- become unblocked. +-- +-- The cache will always provide the most recent payload for a given parent +-- header. However, because mining is asynchronous, it is possible that a miner +-- resolves a block for a non-recent parent header. Hence, all payloads for a +-- given parent header must be kept. +-- +-- Payloads can only be deleted when a parent header becomes outdated. Because +-- in Chainweb branches grow non-monotonically, there is no well-defined moment +-- when a payload becomes definitely outdated. However, usually, one or two +-- block heights should be sufficient. The diameter of the graph is a safe +-- choice. For any deeper reorgs payloads would have to be recomputed. Also, we +-- do not expect miners still working on older payloads anyways, so no miner +-- work would be lost. +-- +module Chainweb.Miner.PayloadCache +( PayloadCache(..) +, newIO +, clearSTM +, clearIO +, sizeSTM +, sizeIO +, insertSTM +, insertIO +, getLatestSTM +, getLatestIO +, awaitLatestSTM +, awaitLatestIO +, lookupSTM +, lookupIO + +-- * Misc Tools +, pruneSTM +, pruneIO +, payloadHashesSTM +, payloadHashesIO +) where + +import Chainweb.BlockHash +import Chainweb.BlockPayloadHash +import Chainweb.PayloadProvider +import Control.Concurrent.STM +import Data.List qualified as L +import Data.Map.Strict qualified as M +import Numeric.Natural +import Chainweb.BlockHeight +import Chainweb.Parent + +-- | A new payload cache for a chain. +-- +-- Payloads are pruned from this cache when a new payload is received that is +-- more than graph diameter block heights ahead. Only items that have a block +-- height that is smaller than most recent item are guaranteed to be cached. +-- Items with larger block height may or may not be pruned. +-- +-- TODO: we should probably also limit the size, either globally or per block +-- height. +-- +-- TODO: This could be implemented more efficiently by using a ring buffer with +-- one map per block height. The buffer size would have to change when the graph +-- changes. However, graph changes are rare events and it is fine to always use +-- the largest graph defined by a fork point, even if the graph transition has +-- not yet occurred. +-- +data PayloadCache = PayloadCache + { _payloadCacheDepth :: !Natural + , _payloadCacheMap :: !(TVar (M.Map (Parent RankedBlockHash, Int) NewPayload)) + } + +-- NOTE that we provide separate @STM@ and @IO@ versions for functions. The +-- reason for this is that @readTVarIO v@ is more efficient than @atomically +-- (readTVar v)@. In many cases the @IO@ version can benefit from that. + +newIO + :: Natural + -- ^ depth + -> IO PayloadCache +newIO n = PayloadCache n <$> newTVarIO mempty + +clearSTM :: PayloadCache -> STM () +clearSTM pc = writeTVar (_payloadCacheMap pc) mempty + +clearIO :: PayloadCache -> IO () +clearIO = atomically . clearSTM + +sizeSTM :: PayloadCache -> STM Natural +sizeSTM pc = fromIntegral . M.size <$> readTVar (_payloadCacheMap pc) + +sizeIO :: PayloadCache -> IO Natural +sizeIO pc = fromIntegral . M.size <$> readTVarIO (_payloadCacheMap pc) + +payloadHashesSTM :: PayloadCache -> STM [BlockPayloadHash] +payloadHashesSTM pc = fmap _newPayloadBlockPayloadHash . M.elems + <$> readTVar (_payloadCacheMap pc) + +payloadHashesIO :: PayloadCache -> IO [BlockPayloadHash] +payloadHashesIO pc = fmap _newPayloadBlockPayloadHash . M.elems + <$> readTVarIO (_payloadCacheMap pc) + +-- | Get the most recent payload for the given parent hash +-- +getLatestSTM + :: PayloadCache + -> Parent RankedBlockHash + -> STM (Maybe NewPayload) +getLatestSTM pc rh = do + lookupValueGE (rh, minBound) <$> readTVar (_payloadCacheMap pc) >>= \case + Just x + | _newPayloadRankedParentHash x == rh -> return (Just x) + _ -> return Nothing + +-- | Get the most recent payload for the given parent hash +-- +getLatestIO + :: PayloadCache + -> Parent RankedBlockHash + -> IO (Maybe NewPayload) +getLatestIO pc rh = + lookupValueGE (rh, minBound) <$> readTVarIO (_payloadCacheMap pc) >>= \case + Just x + | _newPayloadRankedParentHash x == rh -> return (Just x) + _ -> return Nothing + +-- | Await the most recent payload for the given parent hash +-- +awaitLatestSTM + :: PayloadCache + -> Parent RankedBlockHash + -> STM NewPayload +awaitLatestSTM pc rh = getLatestSTM pc rh >>= maybe retry return + +-- | Await the most recent payload for the given parent hash +-- +awaitLatestIO + :: PayloadCache + -> Parent RankedBlockHash + -> IO NewPayload +awaitLatestIO pc = atomically . awaitLatestSTM pc + +-- | Lookup a specific new payload by its block payload hash +-- +lookupSTM + :: PayloadCache + -> Parent RankedBlockHash + -> BlockPayloadHash + -> STM (Maybe NewPayload) +lookupSTM pc rh pld = do + m <- readTVar (_payloadCacheMap pc) + + -- Focus on the ranked payload hash search for the payload hash starting + -- with the most recent value. + return + . L.find match + . fmap snd + . M.toDescList + . fst + . M.split (rh, maxBound) + . snd + . M.split (rh, minBound) + $ m + where + match = (== pld) . _newPayloadBlockPayloadHash + +-- | Lookup a specific new payload by its block payload hash +-- +lookupIO + :: PayloadCache + -> Parent RankedBlockHash + -> BlockPayloadHash + -> IO (Maybe NewPayload) +lookupIO pc rh pld = do + m <- readTVarIO (_payloadCacheMap pc) + + -- Focus on the ranked payload hash search for the payload hash starting + -- with the most recent value. + return + . L.find match + . fmap snd + . M.toDescList + . fst + . M.split (rh, maxBound) + . snd + . M.split (rh, minBound) + $ m + where + match = (== pld) . _newPayloadBlockPayloadHash + +-- | Insert a new payload into the cache +-- +insertSTM + :: PayloadCache + -> NewPayload + -> STM () +insertSTM pc pld = + modifyTVar' (_payloadCacheMap pc) $ + M.insert key pld . prune (_payloadCacheDepth pc) h + where + Parent h = _newPayloadParentHeight pld + Parent p = _newPayloadParentHash pld + key = (Parent (RankedBlockHash h p), _newPayloadNumber pld) + +-- | Insert a new payload into the cache. The cache is pruned before the new +-- item is inserted. +-- +insertIO + :: PayloadCache + -> NewPayload + -> IO () +insertIO pc = atomically . insertSTM pc + +-- | Prune the cache for the given block height. Pruning is also performed each +-- time a new item is inserted into the cache +-- +pruneSTM + :: PayloadCache + -> BlockHeight + -> STM() +pruneSTM pc h = modifyTVar' (_payloadCacheMap pc) $! + prune (_payloadCacheDepth pc) h + +-- | Prune the cache for the given block height. Pruning is also performed each +-- time a new item is inserted into the cache +-- +pruneIO + :: PayloadCache + -> BlockHeight + -> IO () +pruneIO pc = atomically . pruneSTM pc + +-- -------------------------------------------------------------------------- -- +-- Utils + +lookupValueGE :: Ord k => k -> M.Map k v -> Maybe v +lookupValueGE k m = snd <$> M.lookupGE k m + +prune + :: Natural + -> BlockHeight + -> M.Map (Parent RankedBlockHash, Int) v + -> M.Map (Parent RankedBlockHash, Int) v +prune d h m + | h < fromIntegral d = m + | otherwise = snd $ M.split pivot m + where + pivot = (Parent $ RankedBlockHash (h - fromIntegral d) nullBlockHash, minBound) diff --git a/src/Chainweb/Miner/RestAPI.hs b/src/Chainweb/Miner/RestAPI.hs index 393f86c3b2..3aeb4fbccb 100644 --- a/src/Chainweb/Miner/RestAPI.hs +++ b/src/Chainweb/Miner/RestAPI.hs @@ -23,14 +23,11 @@ module Chainweb.Miner.RestAPI import Data.Proxy (Proxy(..)) -import Pact.Utils.Servant - import Servant.API -- internal modules import Chainweb.Miner.Core (ChainBytes, HeaderBytes, WorkBytes) -import Chainweb.Miner.Pact (Miner) import Chainweb.RestAPI.Utils (ChainwebEndpoint(..), Reassoc, SomeApi(..)) import Chainweb.Version @@ -44,17 +41,15 @@ import Chainweb.Version -- Chainweb Node for it to be reassociated with its `Chainweb.Cut.Cut` and -- Payload, then published to the rest of the network. -- -type MiningApi_ = - "mining" :> "work" - :> QueryParam "chain" ChainId - :> ReqBody '[PactJson] Miner - :> Get '[OctetStream] WorkBytes +type MiningApi_ + = "mining" :> "work" + :> Get '[OctetStream] WorkBytes :<|> "mining" :> "solved" - :> ReqBody '[OctetStream] HeaderBytes - :> Post '[JSON] NoContent + :> ReqBody '[OctetStream] HeaderBytes + :> Post '[JSON] NoContent :<|> "mining" :> "updates" - :> ReqBody '[OctetStream] ChainBytes - :> Raw + :> ReqBody '[OctetStream] ChainBytes + :> Raw type MiningApi (v :: ChainwebVersionT) = 'ChainwebEndpoint v :> Reassoc MiningApi_ diff --git a/src/Chainweb/Miner/RestAPI/Client.hs b/src/Chainweb/Miner/RestAPI/Client.hs index 0bf8c6d0d6..a848c1cc24 100644 --- a/src/Chainweb/Miner/RestAPI/Client.hs +++ b/src/Chainweb/Miner/RestAPI/Client.hs @@ -23,16 +23,15 @@ import Servant.Client (ClientM, Response, client) -- internal modules import Chainweb.Miner.Core (ChainBytes, HeaderBytes, WorkBytes) -import Chainweb.Miner.Pact (Miner) import Chainweb.Miner.RestAPI (miningApi) import Chainweb.Version -- ----------------------------------------------------------------------------- -- Mining Results -workClient :: ChainwebVersion -> Maybe ChainId -> Miner -> ClientM WorkBytes -workClient v mcid m = case clients v of - f :<|> _ -> f mcid m +workClient :: ChainwebVersion -> ClientM WorkBytes +workClient v = case clients v of + f :<|> _ -> f solvedClient :: ChainwebVersion -> HeaderBytes -> ClientM NoContent solvedClient v hbytes = case clients v of @@ -40,7 +39,7 @@ solvedClient v hbytes = case clients v of clients :: ChainwebVersion - -> (Maybe ChainId -> Miner -> ClientM WorkBytes) + -> (ClientM WorkBytes) :<|> (HeaderBytes -> ClientM NoContent) :<|> (ChainBytes -> Method -> ClientM Response) clients (FromSingChainwebVersion (SChainwebVersion :: Sing v)) = client (miningApi @v) diff --git a/src/Chainweb/Miner/RestAPI/Server.hs b/src/Chainweb/Miner/RestAPI/Server.hs index 26d11ac250..720d8e255c 100644 --- a/src/Chainweb/Miner/RestAPI/Server.hs +++ b/src/Chainweb/Miner/RestAPI/Server.hs @@ -2,6 +2,7 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ImportQualifiedPost #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiWayIf #-} @@ -24,26 +25,31 @@ module Chainweb.Miner.RestAPI.Server , someMiningServer ) where +import Chainweb.Cut.Create +import Chainweb.Logger +import Chainweb.Miner.Config +import Chainweb.Miner.Coordinator +import Chainweb.Miner.Core +import Chainweb.Miner.PayloadCache +import Chainweb.Miner.RestAPI (MiningApi) +import Chainweb.PayloadProvider +import Chainweb.RestAPI.Utils +import Chainweb.Utils +import Chainweb.Utils.Serialization +import Chainweb.Version + import Control.Concurrent.STM.TVar - (TVar, readTVar, readTVarIO, registerDelay) import Control.Lens -import Control.Monad (when, unless) -import Control.Monad.Catch (bracket, try, catches) -import qualified Control.Monad.Catch as E +import Control.Monad +import Control.Monad.Catch (try, catches) +import Control.Monad.Catch qualified as E import Control.Monad.Except (throwError) import Control.Monad.IO.Class (liftIO) import Control.Monad.STM -import Data.Binary.Builder (fromByteString) -import qualified Data.HashMap.Strict as HM -import Data.IORef (IORef, atomicModifyIORef', newIORef, readIORef, writeIORef) -import qualified Data.Map.Strict as M +import Data.Binary.Builder qualified as BB (fromByteString) import Data.Proxy (Proxy(..)) -import qualified Data.Set as S -import qualified Data.Vector as V -import Network.HTTP.Types.Status -import Network.Wai (responseLBS) import Network.Wai.EventSource (ServerEvent(..), eventSourceAppIO) import Servant.API @@ -52,52 +58,26 @@ import Servant.Server import System.LogLevel import System.Random --- internal modules - -import Chainweb.Cut.Create -import Chainweb.Logger -import Chainweb.Miner.Config -import Chainweb.Miner.Coordinator -import Chainweb.Miner.Core -import Chainweb.Miner.Pact -import Chainweb.Miner.RestAPI (MiningApi) -import Chainweb.Pact.Types(BlockInProgress(..), Transactions(..)) -import Chainweb.Payload -import Chainweb.RestAPI.Utils -import Chainweb.Utils -import Chainweb.Utils.Serialization -import Chainweb.Version -import Chainweb.WebPactExecutionService - -- -------------------------------------------------------------------------- -- -- Work Handler workHandler :: Logger l - => MiningCoordination l tbl - -> Maybe ChainId - -> Miner + => HasVersion + => MiningCoordination l -> Handler WorkBytes -workHandler mr mcid m@(Miner (MinerId mid) _) = do - MiningState ms <- liftIO . readTVarIO $ _coordState mr - when (M.size ms > _coordLimit mr) $ do - liftIO $ atomicModifyIORef' (_coord503s mr) (\c -> (c + 1, ())) - throwError $ setErrText "Too many work requests" err503 - let !conf = _coordConf mr - !primed = S.member m $ _coordinationMiners conf - unless primed $ do - liftIO $ atomicModifyIORef' (_coord403s mr) (\c -> (c + 1, ())) - throwError $ setErrText ("Unauthorized Miner: " <> mid) err403 - wh <- liftIO $ work mr mcid m - return $ WorkBytes $ runPutS $ encodeWorkHeader wh +workHandler mr = do + wh <- liftIO $ work mr + return $ WorkBytes $ runPutS $ encodeMiningWork wh -- -------------------------------------------------------------------------- -- -- Solved Handler solvedHandler - :: forall l tbl + :: forall l . Logger l - => MiningCoordination l tbl + => HasVersion + => MiningCoordination l -> HeaderBytes -> Handler NoContent solvedHandler mr (HeaderBytes bytes) = do @@ -110,7 +90,7 @@ solvedHandler mr (HeaderBytes bytes) = do result <- liftIO $ catches (Right () <$ solve mr solved) [ E.Handler $ \NoAsscociatedPayload -> return $ Left $ setErrText "No associated Payload" err404 - , E.Handler $ \(InvalidSolvedHeader _ msg) -> + , E.Handler $ \(InvalidSolvedHeader msg) -> return $ Left $ setErrText ("Invalid solved work: " <> msg) err400 ] case result of @@ -122,33 +102,132 @@ solvedHandler mr (HeaderBytes bytes) = do -- | Whether the work is outdated and should be thrown out immediately, -- or there's just fresher work available and the old work is still valid. -data WorkChange = WorkOutdated | WorkRefreshed | WorkRegressed +-- +-- NOTE: this does not provide any information about whether the chain is ready +-- or not. +-- +-- FIXME: +-- +-- Exposing this information to mining clients is problematic. It assumes that +-- clients are able to pick an optimal mining strategy (which should represent a +-- Nash equilibrium). For instance, if clients request new work each time any +-- event is received for a chain, Clients will spent less time mining chains +-- that receive many 'WorkRefreshed' events, because on each event a new chain +-- is selected uniformily. The currently used difficulty adjustement algorithm +-- assumes that all chains receive and equal amount of hash power. Hence, the +-- system will converge towards a state where chains that receive more hash +-- power are being blocked more often and miners are more likely the race on +-- chains that receive less hash power. As a consequence the number of orphans +-- is going to increase. +-- +-- While it is desirable to provide sufficient information to allow smart and +-- educated miners to pick their own chain selection strategy, the API should +-- ensure that uninformed miners are going to use a reasonable default strategy +-- that distributes hash power uniformily accross all chains. +-- +-- Unlike WorkOutdated events, the distribution of WorkRefreshed events is not +-- generated by the randomized mining process. Instead WorkRefreshed depends on +-- the rate at which transactions are sent to the mempool for the respective +-- chain. Beside of introducing random byzantine skew in the hash power +-- distribution and increasing orphan block counts, this condition can also be +-- exploited explicitely by a malicious actor. +-- +-- (Note that uniform distribution of hash power accross all chains is not the +-- optimal strategy in a collaborative model. In a collaborative model miners +-- could reduce the numbers of orphans be giving a slight preference to chains +-- with a lower block height in the current cut. However, to the best of our +-- knowledge that strategy does not represent an equilibrium in an adversarial +-- model. Uniform distribution is the best strategy that we are aware of for an +-- adversariable setting.) +-- +data WorkChange + = WorkOutdated + -- ^ The current work for the chain is invalid. + -- + -- The mining client should request new work. If the chain is currently + -- blocked it will be excluded in the selection of the new work. + -- + | WorkRefreshed + -- ^ The current work for the chain is still valid, but newer work is + -- available. + -- deriving stock (Show, Eq) +-- | This event triggers when the previous work got outdated +-- +awaitWorkChange + :: TVar (Maybe ParentState) + -> PayloadCache + -> TVar Bool + -- ^ Timer + -> TVar (Maybe ParentState, Maybe NewPayload) + -> IO (Maybe WorkChange) +awaitWorkChange var payloadCache timer prevVar = go + where + go = do + -- await a change in the work state of the chain + atomically $ readTVar timer >>= \case + True -> return Nothing + False -> do + prev <- readTVar prevVar + cur <- readTVar var + (workChange, curPayload) <- case (prev, cur) of + ((Just _, _), Nothing) -> + -- the parent state has been vacated; + -- there are no longer parents to mine on, + -- so stop mining + return (WorkOutdated, Nothing) + ((Nothing, _), Just _) -> + -- the parent state has been populated; + -- there are now parents to mine on, + -- so start mining + return (WorkOutdated, Nothing) + ((Nothing, _), Nothing) -> + -- the parent state is still empty + retry + ((oldMaybeParentState, oldMaybePayload), Just newParentState) -> do + case (oldMaybeParentState, oldMaybePayload) of + (Just oldParentState, oldPayload) + | oldParentState == newParentState -> do + -- the parent state remains the same, + -- so we await a refreshed payload + newPayload <- awaitLatestPayloadForParentStateSTM payloadCache newParentState + guard (Just newPayload /= oldPayload) + return (WorkRefreshed, Just newPayload) + | otherwise -> + return (WorkOutdated, Nothing) + writeTVar prevVar (cur, curPayload) + + return $ Just workChange + +-- | +-- +-- FIXME: the that current API design is broken in several ways. The main issues +-- are: +-- +-- 1. Lack of synchronization between the updates stream and the GET work API. +-- Events from the update stream race against work returned by GET work. +-- 2. It does not support mining clients in deploying a stable and optimal +-- mining strategy. Any use of the WorkRefreshed event requires non-trivial +-- client side logic to guarantee a uniform distribution of hash power +-- across chains. +-- A simple strategy for clients could be to ignore the WorkRefreshed events +-- and instead request new work at a fixed rate. +-- +-- FIXME: consider sending the WorkRefreshed Event at a fixed rate on each +-- chain. +-- +-- FIXME: update openAPI spec for mining API to reflect the "Refreshed Block" +-- event. +-- updatesHandler :: Logger l - => MiningCoordination l tbl + => HasVersion + => MiningCoordination l -> ChainBytes -> Tagged Handler Application -updatesHandler mr (ChainBytes cbytes) = Tagged $ \req resp -> withLimit resp $ do - watchedChain <- runGetS decodeChainId cbytes - (watchedMiner, blockOnChain) <- atomically $ do - PrimedWork pw <- readTVar (_coordPrimedWork mr) - -- we check if `watchedMiner` has new work. we ignore - -- all other miner IDs, because we don't know which miner - -- is asking for updates, and if we watched all of them at once - -- we'd send too many messages. - -- this is deliberately partial, primed work will always have - -- at least one miner or that's an error - let (watchedMiner, minerBlocks) = HM.toList pw ^?! _head - -- and that miner will always have this chain(?) - -- if this chain doesn't exist yet just wait - blockOnChain <- do - case minerBlocks ^? ix watchedChain of - Just (WorkReady newBlock) -> return newBlock - _ -> retry - return (watchedMiner, blockOnChain) - blockOnChainRef <- newIORef (WorkReady blockOnChain) +updatesHandler mr (ChainBytes cbytes) = Tagged $ \req resp -> do + cid <- runGetS decodeChainId cbytes -- An update stream is closed after @timeout@ seconds. We add some jitter to -- availablility of streams is uniformily distributed over time and not @@ -157,141 +236,48 @@ updatesHandler mr (ChainBytes cbytes) = Tagged $ \req resp -> withLimit resp $ d jitter <- randomRIO @Double (0.9, 1.1) timer <- registerDelay (round $ jitter * realToFrac timeout * 1_000_000) - eventSourceAppIO (go timer watchedChain watchedMiner blockOnChainRef) req resp - where - timeout = _coordinationUpdateStreamTimeout $ _coordConf mr - - -- | A nearly empty `ServerEvent` that signals the work on this chain has - -- changed, and how. - -- - eventForWorkChangeType :: WorkChange -> ServerEvent - eventForWorkChangeType WorkOutdated = ServerEvent (Just $ fromByteString "New Cut") Nothing [] - eventForWorkChangeType WorkRefreshed = ServerEvent (Just $ fromByteString "Refreshed Block") Nothing [] - -- this is only different from WorkRefreshed for logging - eventForWorkChangeType WorkRegressed = ServerEvent (Just $ fromByteString "Refreshed Block") Nothing [] + curWork <- atomically $ readTVar (_coordParentState mr ^?! ixg cid) >>= \case + Nothing -> return (Nothing, Nothing) + Just parentState -> do + pload <- awaitLatestPayloadForParentStateSTM (_coordPayloadCache mr ^?! ixg cid) parentState + return (Just parentState, Just pload) - go :: TVar Bool -> ChainId -> MinerId -> IORef WorkState -> IO ServerEvent - go timer watchedChain watchedMiner blockOnChainRef = do - lastBlockOnChain <- readIORef blockOnChainRef + prevVar <- newTVarIO curWork - -- await either a timeout or a new event - maybeNewBlock <- atomically $ do - t <- readTVar timer - if t - then return Nothing - else Just <$> awaitNewPrimedWork watchedChain watchedMiner lastBlockOnChain + eventSourceAppIO (go timer cid prevVar) req resp + where + timeout = _coordinationUpdateStreamTimeout $ _coordConf mr - case maybeNewBlock of - Nothing -> return CloseEvent - Just (workChange, currentBlockOnChain) -> do - writeIORef blockOnChainRef currentBlockOnChain + go :: TVar Bool -> ChainId -> TVar (Maybe ParentState, Maybe NewPayload) -> IO ServerEvent + go timer cid prevVar = do + awaitWorkChange (_coordParentState mr ^?! ixg cid) (_coordPayloadCache mr ^?! ixg cid) timer prevVar >>= \case + Nothing -> do + logFunctionText logger Debug $ + "sent close event to miner on chain " <> toText cid + return CloseEvent + Just WorkOutdated -> do logFunctionText logger Debug $ - "sent update to miner on chain " <> toText watchedChain <> ": " <> sshow workChange - when (workChange == WorkRegressed) $ - logFunctionText logger Warn $ - "miner block regressed: " <> sshow currentBlockOnChain - return (eventForWorkChangeType workChange) + "sent work outdated event to miner on chain " <> toText cid + return $ ServerEvent (Just $ BB.fromByteString "New Cut") Nothing [] + Just WorkRefreshed -> do + logFunctionText logger Debug $ + "sent work outdated event to miner on chain " <> toText cid + return $ ServerEvent (Just $ BB.fromByteString "Refreshed Block") Nothing [] where - logger = addLabel ("chain", toText watchedChain) (_coordLogger mr) - - count = _coordUpdateStreamCount mr - - awaitNewPrimedWork watchedChain watchedMiner lastBlockOnChain = do - PrimedWork pw <- readTVar (_coordPrimedWork mr) - let currentBlockOnChain = pw ^?! ix watchedMiner . ix watchedChain - case (lastBlockOnChain, currentBlockOnChain) of - - -- there was no work, and that hasn't changed. - (WorkStale, WorkStale) -> retry - (WorkAlreadyMined _, WorkAlreadyMined _) -> retry - - (WorkReady (NewBlockInProgress (ForPact4 lastBip)), WorkReady (NewBlockInProgress (ForPact4 currentBip))) - | lastPh <- _blockInProgressParentHeader lastBip - , currentPh <- _blockInProgressParentHeader currentBip - , lastPh /= currentPh -> - -- we've got a new block on a new parent, we must've missed - -- the update where the old block became outdated. - -- miner should restart - return (WorkOutdated, currentBlockOnChain) - - | lastTlen <- V.length (_transactionPairs $ _blockInProgressTransactions lastBip) - , currentTlen <- V.length (_transactionPairs $ _blockInProgressTransactions currentBip) - , lastTlen /= currentTlen -> - if currentTlen < lastTlen - then - -- our refreshed block somehow has less transactions, - -- but the same parent header, log this as a bizarre case - return (WorkRegressed, currentBlockOnChain) - else - -- we've got a block that's been extended with new transactions - -- miner should restart - return (WorkRefreshed, currentBlockOnChain) - - -- no apparent change - | otherwise -> retry - - (WorkReady (NewBlockInProgress (ForPact5 lastBip)), WorkReady (NewBlockInProgress (ForPact5 currentBip))) - | lastPh <- _blockInProgressParentHeader lastBip - , currentPh <- _blockInProgressParentHeader currentBip - , lastPh /= currentPh -> - -- we've got a new block on a new parent, we must've missed - -- the update where the old block became outdated. - -- miner should restart - return (WorkOutdated, currentBlockOnChain) - - | lastTlen <- V.length (_transactionPairs $ _blockInProgressTransactions lastBip) - , currentTlen <- V.length (_transactionPairs $ _blockInProgressTransactions currentBip) - , lastTlen /= currentTlen -> - if currentTlen < lastTlen - then - -- our refreshed block somehow has less transactions, - -- but the same parent header, log this as a bizarre case - return (WorkRegressed, currentBlockOnChain) - else - -- we've got a block that's been extended with new transactions - -- miner should restart - return (WorkRefreshed, currentBlockOnChain) - - -- no apparent change - | otherwise -> retry - (WorkReady (NewBlockPayload lastPh lastPwo), WorkReady (NewBlockPayload currentPh currentPwo)) - | lastPh /= currentPh -> - -- we've got a new block on a new parent, we must've missed - -- the update where the old block became outdated. - -- miner should restart. - return (WorkOutdated, currentBlockOnChain) - - | _payloadWithOutputsPayloadHash lastPwo /= _payloadWithOutputsPayloadHash currentPwo -> - -- this should be impossible because NewBlockPayload is for - -- when Pact is off so blocks can't be refreshed, but we've got - -- a different block with the same parent, so the miner should restart. - return (WorkRefreshed, currentBlockOnChain) - - -- no apparent change - | otherwise -> retry - (WorkReady _, WorkReady _) -> - error "awaitNewPrimedWork: impossible: NewBlockInProgress replaced by a NewBlockPayload" - - _ -> return (WorkOutdated, currentBlockOnChain) - - withLimit resp inner = bracket - (atomicModifyIORef' count $ \x -> (x - 1, x - 1)) - (const $ atomicModifyIORef' count $ \x -> (x + 1, ())) - (\x -> if x <= 0 then ret503 resp else inner) - - ret503 resp = do - resp $ responseLBS status503 [] "No more update streams available currently. Retry later." + logger = addLabel ("chain", toText cid) (_coordLogger mr) -- -------------------------------------------------------------------------- -- -- Mining API Server miningServer - :: forall l tbl (v :: ChainwebVersionT) + :: forall l (v :: ChainwebVersionT) . Logger l - => MiningCoordination l tbl + => HasVersion + => MiningCoordination l -> Server (MiningApi v) miningServer mr = workHandler mr :<|> solvedHandler mr :<|> updatesHandler mr -someMiningServer :: Logger l => ChainwebVersion -> MiningCoordination l tbl -> SomeServer -someMiningServer (FromSingChainwebVersion (SChainwebVersion :: Sing vT)) mr = - SomeServer (Proxy @(MiningApi vT)) $ miningServer mr +someMiningServer :: Logger l => HasVersion => MiningCoordination l -> SomeServer +someMiningServer mr = case implicitVersion of + FromSingChainwebVersion (SChainwebVersion :: Sing vT) -> + SomeServer (Proxy @(MiningApi vT)) $ miningServer mr diff --git a/src/Chainweb/MinerReward.hs b/src/Chainweb/MinerReward.hs index 1cc41a2df1..c07678099e 100644 --- a/src/Chainweb/MinerReward.hs +++ b/src/Chainweb/MinerReward.hs @@ -29,16 +29,29 @@ module Chainweb.MinerReward Stu(..) , divideStu +-- * MStu +, MStu(..) +, divideMStu + +-- * GStu +, GStu(..) +, divideGStu + -- * KDA , Kda , pattern Kda , _kda , stuToKda , kdaToStu +, mstuToKda +, kdaToMStu +, gstuToKda +, kdaToGStu -- * Miner Reward , MinerReward(..) , minerRewardKda +, minerRewardGStu , blockMinerReward , encodeMinerReward , decodeMinerReward @@ -81,22 +94,23 @@ import GHC.Stack import Numeric.Natural -- -------------------------------------------------------------------------- -- --- STU +-- Stu --- | Smallest Unit of KDA: 1 KDA == 1e12 STU. +-- | Stu: 1 KDA == 1e18 Stu. +-- +-- This is the smallest unit of KDA throughout the Chainweb ecosystem. +-- +-- It is used for balances in native X-Channels. +-- +-- It is also used to represent balances and transfered amount of native KDA in +-- the EVM. -- -- Values are non-negative and substraction can result in an arithmetic -- underflow. -- newtype Stu = Stu { _stu :: Natural } - deriving stock (Show, Eq, Ord, Generic) - deriving newtype (Enum, Num, Real, Integral, NFData) - -instance HasTextRepresentation Stu where - toText = toText . _stu - fromText = fmap Stu . fromText - {-# INLINEABLE toText #-} - {-# INLINEABLE fromText #-} + deriving stock (Show, Generic) + deriving newtype (Eq, Ord, Enum, Num, Real, Integral, NFData, HasTextRepresentation) instance ToJSON Stu where toJSON = toJSON . toText @@ -115,6 +129,69 @@ instance FromJSON Stu where divideStu :: Stu -> Natural -> Stu divideStu s n = round $ s % fromIntegral n +-- -------------------------------------------------------------------------- -- +-- Mega Stu + +-- | Mega Stu: 1 KDA == 1e12 MStu. +-- +-- This is smallest unit of KDA on Pact Chains. +-- +-- Values are non-negative and substraction can result in an arithmetic +-- underflow. +-- +newtype MStu = MStu { _mstu :: Natural } + deriving stock (Show, Generic) + deriving newtype (Eq, Ord, Enum, Num, Real, Integral, NFData, HasTextRepresentation) + +instance ToJSON MStu where + toJSON = toJSON . toText + toEncoding = toEncoding . toText + {-# INLINEABLE toJSON #-} + {-# INLINEABLE toEncoding #-} + +instance FromJSON MStu where + parseJSON = parseJsonFromText "MStu" + {-# INLINABLE parseJSON #-} + +-- | Divide a MStu by a Natural number. +-- +-- The result is rounded using bankers rounding. +-- +divideMStu :: MStu -> Natural -> MStu +divideMStu s n = round $ s % fromIntegral n + +-- -------------------------------------------------------------------------- -- +-- Giga Stu + +-- | Giga Stu: 1 KDA == 1e9 gstu. +-- +-- This is used to represent gas and withdrawals in the EVM. In particular, it +-- is used for mining rewards in the EVM. +-- +-- Values are non-negative and substraction can result in an arithmetic +-- underflow. +-- +newtype GStu = GStu { _gstu :: Natural } + deriving stock (Show, Generic) + deriving newtype (Eq, Ord, Enum, Num, Real, Integral, NFData, HasTextRepresentation) + +instance ToJSON GStu where + toJSON = toJSON . toText + toEncoding = toEncoding . toText + {-# INLINEABLE toJSON #-} + {-# INLINEABLE toEncoding #-} + +instance FromJSON GStu where + parseJSON = parseJsonFromText "GStu" + {-# INLINABLE parseJSON #-} + +-- | Divide a GStu by a Natural number. +-- +-- The result is rounded using bankers rounding. +-- +divideGStu :: GStu -> Natural -> GStu +divideGStu s n = round $ s % fromIntegral n + -- -------------------------------------------------------------------------- -- -- KDA @@ -122,8 +199,21 @@ divideStu s n = round $ s % fromIntegral n -- -- No arithmetic conversions or operations are provided. -- --- The precision of KDA values is 1e12 decimal digits. The value is stored in --- a normalized format with the smallest possible mantissa. +-- The available precision of KDA values depends on the payload provider +-- context. +-- +-- The maximum precision across the Chainweb ecosystem is 1e18 decimal digits +-- (Stu). The minimum precision that payload providers must suppport is 1e9 +-- (GStu). +-- +-- Native X-channels use KDA with a precision of 1e18 (Stu). Fractional amounts +-- that are smaller than the precision available at the receiver can not be +-- withdrawn and remain in the channel. +-- +-- Mining rewards are calcuated in KDA with a precision of 1e9 (GStu). +-- +-- The value is stored in a normalized format with the smallest possible +-- mantissa. -- newtype Kda = Kda_ Decimal deriving stock (Show, Eq, Ord, Generic) @@ -134,65 +224,80 @@ newtype Kda = Kda_ Decimal pattern Kda :: HasCallStack => Decimal -> Kda pattern Kda { _kda } <- Kda_ _kda where Kda k - | roundTo 12 k /= k = error "KDA value with a precision of more than 12 decimal digits" + | roundTo 18 k /= k = error "KDA value with a precision of more than 18 decimal digits" | otherwise = Kda_ $ normalizeDecimal k {-# COMPLETE Kda #-} +-- ----------------------------------------------------------------------------- +-- Conversions + stuToKda :: HasCallStack => Stu -> Kda -stuToKda (Stu k) = Kda $ normalizeDecimal $ Decimal 12 (fromIntegral k) +stuToKda (Stu k) = Kda $ normalizeDecimal $ Decimal 18 (fromIntegral k) kdaToStu :: Kda -> Stu -kdaToStu (Kda { _kda = s }) = Stu $ round (s * 1e12) +kdaToStu (Kda { _kda = s }) = Stu $ round (s * 1e18) + +mstuToKda :: MStu -> Kda +mstuToKda (MStu k) = Kda $ normalizeDecimal $ Decimal 12 (fromIntegral k) + +kdaToMStu :: Kda -> MStu +kdaToMStu (Kda { _kda = s }) = MStu $ round (s * 1e12) + +gstuToKda :: GStu -> Kda +gstuToKda (GStu k) = Kda $ normalizeDecimal $ Decimal 9 (fromIntegral k) + +kdaToGStu :: Kda -> GStu +kdaToGStu (Kda { _kda = s }) = GStu $ round (s * 1e9) -- -------------------------------------------------------------------------- -- -- Miner Reward --- | Miner Reward in Stu +-- | Miner Reward in GStu -- --- The maximum miner reward is 23045230000000, which is smaller than 2^51-1. +-- The maximum miner reward is 23045230000, which is smaller than 2^51-1. -- Miner rewards can thus be represented losslessly as JSON numbers. -- -newtype MinerReward = MinerReward { _minerReward :: Stu } +newtype MinerReward = MinerReward { _minerReward :: GStu } deriving (Show, Eq, Ord, Generic) deriving (ToJSON, FromJSON) via JsonTextRepresentation "MinerReward" MinerReward - -instance HasTextRepresentation MinerReward where - toText (MinerReward (Stu n)) = toText n - fromText t = MinerReward . Stu <$> fromText t - {-# INLINE toText #-} - {-# INLINE fromText #-} - + deriving newtype (HasTextRepresentation) minerRewardKda :: MinerReward -> Kda -minerRewardKda (MinerReward d) = stuToKda d +minerRewardKda (MinerReward d) = gstuToKda d + +minerRewardGStu :: MinerReward -> GStu +minerRewardGStu (MinerReward d) = d -- | Calculate miner reward for a block at the given height. -- -- NOTE: -- This used to compute the value as @roundTo 8 $ (_kda $ stuToKda m) / n@. --- The new caclulcation based on Stu is equivalent for 10 and 20 chains, +-- The new caclulcation based on GStu is equivalent for 10 and 20 chains, -- except for the pre-last entry in the miner rewards table, namely --- @(125538056,0.023999333). However, since this value hasen't yet been used +-- @(125538056,0.023999333). However, since this value has not yet been used -- in any network, we can still change the algorithm. -- +-- For other graphs that do not cleanly divide 10000, this value is does not +-- hold and changes in precision constitue a forking change. +-- blockMinerReward - :: ChainwebVersion - -> BlockHeight + :: HasVersion + => BlockHeight -> MinerReward -blockMinerReward v h = case M.lookupGE h minerRewards of - Nothing -> MinerReward $ Stu 0 - Just (_, s) -> MinerReward $ divideStu s n +blockMinerReward h = case M.lookupGE h minerRewards of + Nothing -> MinerReward $ GStu 0 + Just (_, s) -> MinerReward $ divideGStu s n where - !n = int . order $ chainGraphAt v h + !n = int . order $ chainGraphAt h -- | Binary encoding of mining rewards as unsigned integral number in little -- endian encoding. -- --- The maximum miner reward is 23045230000000. The miner reward can therefore be +-- The maximum miner reward is 23045230000. The miner reward can therefore be -- encoded in as Word64 value. -- encodeMinerReward :: MinerReward -> Put -encodeMinerReward (MinerReward (Stu n)) = putWord64le (int n) +encodeMinerReward (MinerReward (GStu n)) = putWord64le (int n) {-# INLINE encodeMinerReward #-} decodeMinerReward :: Get MinerReward @@ -206,7 +311,7 @@ decodeMinerReward = MinerReward . int <$> getWord64le -- -------------------------------------------------------------------------- -- -- Miner Rewards Table -type MinerRewardsTable = M.Map BlockHeight Stu +type MinerRewardsTable = M.Map BlockHeight GStu -- | Rewards table mapping 3-month periods to their rewards according to the -- calculated exponential decay over about a 120 year period (125538057 block @@ -241,10 +346,10 @@ mkMinerRewards = let rewards = M.fromList . V.toList . V.map formatRow $ vs in if minerRewardsHash rewards == expectedMinerRewardsHash then rewards - else error $ "hash of miner rewards table does not match expected hash" + else error "hash of miner rewards table does not match expected hash" where - formatRow :: (Word64, CsvDecimal) -> (BlockHeight, Stu) - formatRow (a, b) = (BlockHeight $ int a, kdaToStu (Kda $ _csvDecimal b)) + formatRow :: (Word64, CsvDecimal) -> (BlockHeight, GStu) + formatRow (a, b) = (BlockHeight $ int a, kdaToGStu (Kda $ _csvDecimal b)) -- -------------------------------------------------------------------------- -- -- Miner Rewards File @@ -273,8 +378,7 @@ minerRewardsHash = hash . M.toAscList expectedMinerRewardsHash :: Digest SHA512 -expectedMinerRewardsHash = read "8e4fb006c5045b3baab638d16d62c952e4981a4ba473ec63620dfb54093d5104abd0be1a62ce52113575d598881fb57e84a41ec5c617e4348e270b9eacd300c9" +expectedMinerRewardsHash = read "264189d9d9181d76e2be948e3b336ab09b723cc095c059b6b3c79ff4e58b5c412c5d0b01882464a4f27fbe297b3f0dcbe3bda6ee6eb85556eeba6224ecb6458e" expectedRawMinerRewardsHash :: Digest SHA512 expectedRawMinerRewardsHash = read "903d10b06666c0d619c8a28c74c3bb0af47209002f005b12bbda7b7df1131b2072ce758c1a8148facb1506022215ea201629f38863feb285c7e66f5965498fe0" - diff --git a/src/Chainweb/NodeVersion.hs b/src/Chainweb/NodeVersion.hs index 3ca6f51939..ef02e3e83d 100644 --- a/src/Chainweb/NodeVersion.hs +++ b/src/Chainweb/NodeVersion.hs @@ -176,12 +176,43 @@ data NodeInfoException | PeerAddrHeaderMissing !HostAddress | HeaderFormatException !HostAddress !SomeException | NodeInfoConnectionFailure !HostAddress !SomeException - | NodeInfoUnsupported !HostAddress !NodeVersion - -- ^ this constructor can be removed once all nodes are running - -- version 2.4 or larger deriving (Show, Generic) -instance Exception NodeInfoException +instance Exception NodeInfoException where + displayException = T.unpack . renderNodeInfoException + +renderNodeInfoException :: NodeInfoException -> T.Text +renderNodeInfoException (VersionHeaderMissing addr) = + "missing " <> CI.original chainwebNodeVersionHeaderName + <> " header from node " <> toText addr +renderNodeInfoException (ServerTimestampHeaderMissing addr) = + "missing " <> CI.original serverTimestampHeaderName + <> " header from node " <> toText addr +renderNodeInfoException (PeerAddrHeaderMissing addr) = + "missing " <> CI.original peerAddrHeaderName + <> " header from node " <> toText addr +renderNodeInfoException (HeaderFormatException addr e) = + "malformed header from node " <> toText addr + <> ": " <> T.pack (displayException e) +renderNodeInfoException (NodeInfoConnectionFailure addr e) = + "failed to connect to node " + <> toText addr <> ": " <> renderConnectionFailure e + +renderConnectionFailure :: SomeException -> T.Text +renderConnectionFailure e = case fromException e of + Just (HTTP.HttpExceptionRequest r msg) -> + "Error connecting to " <> renderRequest r <> ": " <> sshow msg + Just (HTTP.InvalidUrlException url reason) -> + "Invalid URL " <> T.pack url <> ": " <> T.pack reason + Nothing -> T.pack (displayException e) + +renderRequest :: HTTP.Request -> T.Text +renderRequest r + = T.decodeUtf8 (HTTP.method r) + <> " " <> T.decodeUtf8 (HTTP.host r) + <> ":" <> sshow (HTTP.port r) + <> T.decodeUtf8 (HTTP.path r) + <> T.decodeUtf8 (HTTP.queryString r) data RemoteNodeInfo = RemoteNodeInfo { _remoteNodeInfoVersion :: !NodeVersion diff --git a/src/Chainweb/OpenAPIValidation.hs b/src/Chainweb/OpenAPIValidation.hs index ad7e61f31a..b5d5876022 100644 --- a/src/Chainweb/OpenAPIValidation.hs +++ b/src/Chainweb/OpenAPIValidation.hs @@ -25,8 +25,8 @@ import Chainweb.Time import Chainweb.Utils import Chainweb.Version -mkValidationMiddleware :: Logger logger => logger -> ChainwebVersion -> HTTP.Manager -> IO Middleware -mkValidationMiddleware logger v mgr = do +mkValidationMiddleware :: (Logger logger, HasVersion) => logger -> HTTP.Manager -> IO Middleware +mkValidationMiddleware logger mgr = do (chainwebSpec, pactSpec) <- fetchOpenApiSpecs apiCoverageRef <- newIORef $ WV.initialCoverageMap [chainwebSpec, pactSpec] apiCoverageLogTimeRef <- newIORef =<< getCurrentTimeIntegral @@ -38,15 +38,15 @@ mkValidationMiddleware logger v mgr = do ("" : "chainweb" : "0.0" : rawVersion : "chain" : rawChainId : "pact" : rest) -> do findPact pactSpec rawVersion rawChainId rest _ -> Nothing - , (,chainwebSpec) <$> BS8.stripPrefix (T.encodeUtf8 $ "/chainweb/0.0/" <> toText (_versionName v)) path + , (,chainwebSpec) <$> BS8.stripPrefix (T.encodeUtf8 $ "/chainweb/0.0/" <> toText (_versionName implicitVersion)) path , Just (path,chainwebSpec) ] where findPact pactSpec rawVersion rawChainId rest = do let reqVersion = ChainwebVersionName (T.decodeUtf8 rawVersion) - guard (reqVersion == _versionName v) - reqChainId <- chainIdFromText (T.decodeUtf8 rawChainId) - guard (HS.member reqChainId (chainIds v)) + guard (reqVersion == _versionName implicitVersion) + reqChainId <- fromTextM (T.decodeUtf8 rawChainId) + guard (HS.member reqChainId chainIds) return (BS8.intercalate "/" ("":rest), pactSpec) fetchOpenApiSpecs = do diff --git a/src/Chainweb/Pact5/Backend/ChainwebPactDb.hs b/src/Chainweb/Pact/Backend/ChainwebPactDb.hs similarity index 73% rename from src/Chainweb/Pact5/Backend/ChainwebPactDb.hs rename to src/Chainweb/Pact/Backend/ChainwebPactDb.hs index e6baa11dd1..648568ddcb 100644 --- a/src/Chainweb/Pact5/Backend/ChainwebPactDb.hs +++ b/src/Chainweb/Pact/Backend/ChainwebPactDb.hs @@ -1,24 +1,26 @@ {-# LANGUAGE BangPatterns #-} +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE EmptyCase #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE ImportQualifiedPost #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RankNTypes #-} {-# LANGUAGE PartialTypeSignatures #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE ViewPatterns #-} -- TODO pact5: fix the orphan PactDbFor instance {-# OPTIONS_GHC -Wno-orphans #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE ViewPatterns #-} -- | The database operations that manipulate and read the Pact state. @@ -43,46 +45,44 @@ -- | +v--------------------------------------------+ +v----------------------------------------------+ | -- | Pact5Db tx Pact5Db tx | -- +v------------------------------------------------------------------------------------------------------------------------+ --- SQLite tx (withSavepoint) +-- SQLite tx (withTransaction) -- (in some cases multiple blocks in tx) -- -- -- Transactions must be nested in this way. -- --- SQLite transaction ensures that the Pact5Db transaction +-- SQLite transaction ensures that the ChainwebPactDb transaction -- sees a consistent view of the database, especially if its -- writes are committed later. -- --- Pact5Db tx ensures that the Pact tx's writes +-- ChainwebPactDb tx ensures that the Pact tx's writes -- are recorded. -- -- Pact tx ensures that failed transactions' writes are not recorded. -module Chainweb.Pact5.Backend.ChainwebPactDb +module Chainweb.Pact.Backend.ChainwebPactDb ( chainwebPactBlockDb - , Pact5Db(..) + , ChainwebPactDb(..) , BlockHandlerEnv(..) , blockHandlerDb , blockHandlerLogger , toTxLog - , toPactTxLog , domainTableName , convRowKey , commitBlockStateToDatabase , initSchema + , lookupBlockWithHeight + , lookupBlockHash + , lookupRankedBlockHash + , getPayloadsAfter + , getEarliestBlock + , getLatestBlock + , getConsensusState + , setConsensusState + , throwOnDbError ) where -import Chainweb.BlockHash -import Chainweb.BlockHeight -import Chainweb.Logger -import Chainweb.Pact.Backend.InMemDb qualified as InMemDb -import Chainweb.Pact.Backend.Types -import Chainweb.Pact.Backend.Utils -import Chainweb.Utils (sshow, unsafeHead, T2) -import Chainweb.Utils.Serialization (runPutS) -import Chainweb.Version -import Chainweb.Version.Guards import Control.Applicative import Control.Concurrent.MVar import Control.Exception.Safe @@ -100,114 +100,56 @@ import Data.ByteString.Short qualified as SB import Data.DList (DList) import Data.DList qualified as DL import Data.Foldable -import Data.HashMap.Strict (HashMap) import Data.HashMap.Strict qualified as HM import Data.HashMap.Strict qualified as HashMap import Data.HashSet qualified as HashSet import Data.Int -import Data.List(group, sort) +import Data.List(sort) import Data.Map.Strict qualified as M import Data.Maybe import Data.Singletons (Dict(..)) import Data.Text (Text) import Data.Text qualified as T import Data.Text.Encoding qualified as T -import Data.Vector (Vector) import Database.SQLite3.Direct qualified as SQ3 import GHC.Stack + +import Prelude hiding (concat, log) + import Pact.Core.Builtin qualified as Pact import Pact.Core.Command.Types (RequestKey (..)) import Pact.Core.Errors qualified as Pact import Pact.Core.Evaluate qualified as Pact import Pact.Core.Gas qualified as Pact import Pact.Core.Guards qualified as Pact -import Pact.Core.Hash +import Pact.Core.Hash hiding (hash) import Pact.Core.Info qualified as Pact import Pact.Core.Names qualified as Pact import Pact.Core.Persistence (throwDbOpErrorGasM) import Pact.Core.Persistence qualified as Pact import Pact.Core.Serialise qualified as Pact import Pact.Core.StableEncoding (encodeStable) -import Pact.Types.Persistence qualified as Pact4 -import Prelude hiding (concat, log) -data InternalDbException = InternalDbException CallStack Text -instance Show InternalDbException where show = displayException -instance Exception InternalDbException where - displayException (InternalDbException stack text) = - T.unpack text <> "\n\n" <> - prettyCallStack stack - -internalDbError :: HasCallStack => MonadThrow m => Text -> m a -internalDbError = throwM . InternalDbException callStack - -throwOnDbError :: (HasCallStack, MonadThrow m) => ExceptT SQ3.Error m a -> m a -throwOnDbError act = runExceptT act >>= either (internalDbError . sshow) return - --- | Statement input types -data SType = SInt Int64 | SDouble Double | SText SQ3.Utf8 | SBlob BS.ByteString deriving (Eq,Show) --- | Result types -data RType = RInt | RDouble | RText | RBlob deriving (Eq,Show) - -bindParams :: SQ3.Statement -> [SType] -> ExceptT SQ3.Error IO () -bindParams stmt as = - forM_ (zip as [1..]) $ \(a,i) -> ExceptT $ - case a of - SInt n -> SQ3.bindInt64 stmt i n - SDouble n -> SQ3.bindDouble stmt i n - SText n -> SQ3.bindText stmt i n - SBlob n -> SQ3.bindBlob stmt i n - -prepStmt :: HasCallStack => SQ3.Database -> SQ3.Utf8 -> ExceptT SQ3.Error IO SQ3.Statement -prepStmt c q = do - r <- ExceptT $ SQ3.prepare c q - case r of - Nothing -> internalDbError "No SQL statements in prepared statement" - Just s -> return s - -execMulti :: Traversable t => SQ3.Database -> SQ3.Utf8 -> t [SType] -> ExceptT SQ3.Error IO () -execMulti db q rows = bracket (prepStmt db q) (liftIO . SQ3.finalize) $ \stmt -> do - forM_ rows $ \row -> do - ExceptT $ SQ3.reset stmt - liftIO $ SQ3.clearBindings stmt - bindParams stmt row - ExceptT $ SQ3.step stmt - --- | Prepare/execute query with params -qry :: SQ3.Database -> SQ3.Utf8 -> [SType] -> [RType] -> ExceptT SQ3.Error IO [[SType]] -qry e q as rts = bracket (prepStmt e q) (ExceptT . SQ3.finalize) $ \stmt -> do - bindParams stmt as - reverse <$> stepStmt stmt rts - -stepStmt :: SQ3.Statement -> [RType] -> ExceptT SQ3.Error IO [[SType]] -stepStmt stmt rts = do - let acc rs SQ3.Done = return rs - acc rs SQ3.Row = do - as <- lift $ forM (zip rts [0..]) $ \(rt,ci) -> - case rt of - RInt -> SInt <$> SQ3.columnInt64 stmt ci - RDouble -> SDouble <$> SQ3.columnDouble stmt ci - RText -> SText <$> SQ3.columnText stmt ci - RBlob -> SBlob <$> SQ3.columnBlob stmt ci - sr <- ExceptT $ SQ3.step stmt - acc (as:rs) sr - sr <- ExceptT $ SQ3.step stmt - acc [] sr - --- | Prepare/exec statement with no params -exec_ :: SQ3.Database -> SQ3.Utf8 -> ExceptT SQ3.Error IO () -exec_ e q = ExceptT $ over _Left fst <$> SQ3.exec e q - --- | Prepare/exec statement with params -exec' :: SQ3.Database -> SQ3.Utf8 -> [SType] -> ExceptT SQ3.Error IO () -exec' e q as = bracket (prepStmt e q) (ExceptT . SQ3.finalize) $ \stmt -> do - bindParams stmt as - void $ ExceptT (SQ3.step stmt) +import Chainweb.BlockHash +import Chainweb.BlockHeader (encodeBlockPayloadHash, BlockPayloadHash) +import Chainweb.BlockHeight +import Chainweb.Logger +import Chainweb.Pact.Backend.InMemDb qualified as InMemDb +import Chainweb.Pact.Backend.Types +import Chainweb.Pact.Backend.Utils +import Chainweb.Pact.SPV (pactSPV) +import Chainweb.Parent +import Chainweb.Utils (sshow, unsafeHead) +import Chainweb.Utils.Serialization (runPutS) +import Chainweb.Version +import Chainweb.Version.Guards (pact5Serialiser, chainweb230Pact) +import Chainweb.Ranked +import Data.List (group) + data BlockHandlerEnv logger = BlockHandlerEnv { _blockHandlerDb :: !SQLiteEnv , _blockHandlerLogger :: !logger - , _blockHandlerVersion :: !ChainwebVersion , _blockHandlerBlockHeight :: !BlockHeight , _blockHandlerUpperBoundTxId :: !Pact.TxId , _blockHandlerChainId :: !ChainId @@ -215,11 +157,14 @@ data BlockHandlerEnv logger = BlockHandlerEnv , _blockHandlerAtTip :: Bool } +instance HasChainId (BlockHandlerEnv logger) where + _chainId = _blockHandlerChainId + -- | The state used by database operations. -- Includes both the state re: the whole block, and the state re: a transaction in progress. data BlockState = BlockState - { _bsBlockHandle :: !(BlockHandle Pact5) - , _bsPendingTxWrites :: !(SQLitePendingData InMemDb.Store) + { _bsBlockHandle :: !BlockHandle + , _bsPendingTxWrites :: !SQLitePendingData , _bsPendingTxLog :: !(Maybe (DList (Pact.TxLog ByteString))) } @@ -232,27 +177,6 @@ getPendingTxLogOrError msg = do Nothing -> liftGas $ Pact.throwDbOpErrorGasM (Pact.NotInTx msg) Just t -> return t --- | The Pact 5 database as it's provided by the checkpointer. -data Pact5Db = Pact5Db - { doPact5DbTransaction - :: forall a - . BlockHandle Pact5 - -> Maybe RequestKey - -> (Pact.PactDb Pact.CoreBuiltin Pact.Info -> IO a) - -> IO (a, BlockHandle Pact5) - -- ^ Give this function a BlockHandle representing the state of a pending - -- block and it will pass you a PactDb which contains the Pact state as of - -- that point in the block. After you're done, it passes you back a - -- BlockHandle representing the state of the block extended with any writes - -- you made to the PactDb. - -- Note also that this function handles registering - -- transactions as completed, if you pass it a RequestKey. - , lookupPactTransactions :: Vector RequestKey -> IO (HashMap RequestKey (T2 BlockHeight BlockHash)) - -- ^ Used to implement transaction polling. - } - -type instance PactDbFor logger Pact5 = Pact5Db - -- this monad allows access to the database environment "in" a particular -- transaction, and allows charging gas for database operations. newtype BlockHandler logger a = BlockHandler @@ -309,10 +233,11 @@ runOnBlockGassed env stateVar act = do return (newState, fmap fst r) liftEither r -chainwebPactBlockDb :: (Logger logger) => BlockHandlerEnv logger -> Pact5Db -chainwebPactBlockDb env = Pact5Db - { doPact5DbTransaction = \blockHandle maybeRequestKey kont -> do - stateVar <- newMVar $ BlockState blockHandle (_blockHandlePending blockHandle) Nothing +chainwebPactBlockDb :: (Logger logger) => HasVersion => BlockHandlerEnv logger -> ChainwebPactDb +chainwebPactBlockDb env = ChainwebPactDb + { doChainwebPactDbTransaction = \maybeRequestKey kont -> do + blockHandle <- get + stateVar <- liftIO $ newMVar $ BlockState blockHandle (_blockHandlePending blockHandle) Nothing let pactDb = Pact.PactDb { Pact._pdbPurity = Pact.PImpure , Pact._pdbRead = \d k -> runOnBlockGassed env stateVar $ doReadRow d k @@ -329,17 +254,27 @@ chainwebPactBlockDb env = Pact5Db , Pact._pdbRollbackTx = runOnBlockGassed env stateVar doRollback } - r <- kont pactDb - finalState <- readMVar stateVar + let currentHeight = _blockHandlerBlockHeight env + -- TODO: support minimumBlockHeaderHistory + let headerOracle = HeaderOracle + { chain = _chainId env + , consult = \(Parent hsh) -> do + throwOnDbError (lookupBlockHash (_blockHandlerDb env) hsh) <&> \case + Nothing -> False + Just rootHeight -> rootHeight < currentHeight + } + let spv = pactSPV headerOracle + r <- liftIO $ kont pactDb spv + finalState <- liftIO $ readMVar stateVar -- Register a successful transaction in the pending data for the block let registerRequestKey = case maybeRequestKey of Just requestKey -> HashSet.insert (SB.fromShort $ unHash $ unRequestKey requestKey) Nothing -> id - let finalHandle = + let !finalHandle = _bsBlockHandle finalState & blockHandlePending . pendingSuccessfulTxs %~ registerRequestKey - - return (r, finalHandle) + put finalHandle + return r , lookupPactTransactions = fmap (HM.mapKeys (RequestKey . Hash)) . doLookupSuccessful (_blockHandlerDb env) (_blockHandlerBlockHeight env) . @@ -349,7 +284,8 @@ chainwebPactBlockDb env = Pact5Db doReadRow :: forall k v logger -- ^ the highest block we should be reading writes from - . Pact.Domain k v Pact.CoreBuiltin Pact.Info + . HasVersion + => Pact.Domain k v Pact.CoreBuiltin Pact.Info -> k -> BlockHandler logger (Maybe v) doReadRow d k = do @@ -397,7 +333,7 @@ doReadRow d k = do fmap join $ withTableExistenceCheck pactTableName fetchRowFromDb _ -> throwOnDbError $ fetchRowFromDb where - fetchRowFromDb :: ExceptT SQ3.Error (BlockHandler logger) (Maybe (Int, v)) + fetchRowFromDb :: ExceptT LocatedSQ3Error (BlockHandler logger) (Maybe (Int, v)) fetchRowFromDb = do (decodeValueDoc, encodedKey) <- lift codec let decodeValue = fmap (view Pact.document) . decodeValueDoc @@ -413,7 +349,7 @@ doReadRow d k = do case result of [] -> return Nothing [[SBlob a]] -> return $ (BS.length a,) <$> decodeValue a - err -> internalDbError $ + err -> error $ "doReadRow: Expected (at most) a single result, but got: " <> sshow err @@ -468,20 +404,20 @@ checkTableStatus tableName = do -- `checkTableStatus`, too. returns `Nothing` if the table is pending creation -- in this block; usually, this means that we halt before accessing the db to -- look in the table. -withTableExistenceCheck :: HasCallStack => Pact.TableName -> ExceptT SQ3.Error (BlockHandler logger) a -> BlockHandler logger (Maybe a) +withTableExistenceCheck :: HasCallStack => Pact.TableName -> ExceptT LocatedSQ3Error (BlockHandler logger) a -> BlockHandler logger (Maybe a) withTableExistenceCheck tableName action = do atTip <- view blockHandlerAtTip if atTip -- at tip, speculatively execute the statement, and only check if the table -- was missing if the statement threw an error then runExceptT action >>= \case - Left err@SQ3.ErrorError -> do + Left err@(LocatedSQ3Error _ SQ3.ErrorError) -> do tableStatus <- checkTableStatus tableName case tableStatus of TableDoesNotExist -> liftGas $ throwDbOpErrorGasM $ Pact.NoSuchTable tableName TableCreationPending -> return Nothing - TableExists -> internalDbError (sshow err) - Left err -> internalDbError (sshow err) + TableExists -> error (sshow err) + Left err -> error (sshow err) Right result -> return (Just result) else do -- if we're rewound, we just check if the table exists first @@ -495,7 +431,8 @@ latestTxId :: Lens' BlockState Pact.TxId latestTxId = bsBlockHandle . blockHandleTxId . coerced writeSys - :: Pact.Domain k v Pact.CoreBuiltin Pact.Info + :: HasVersion + => Pact.Domain k v Pact.CoreBuiltin Pact.Info -> k -> v -> BlockHandler logger () @@ -513,7 +450,8 @@ writeSys d k v = do recordTxLog d encodedKey encodedValue recordPendingUpdate - :: Pact.Domain k v Pact.CoreBuiltin Pact.Info + :: HasVersion + => Pact.Domain k v Pact.CoreBuiltin Pact.Info -> k -> Pact.TxId -> (ByteString, v) @@ -523,7 +461,8 @@ recordPendingUpdate d k txid (encodedValue, decodedValue) = InMemDb.insert d k (InMemDb.WriteEntry txid encodedValue decodedValue) writeUser - :: Pact.WriteType + :: HasVersion + => Pact.WriteType -> Pact.TableName -> Pact.RowKey -> Pact.RowData @@ -553,8 +492,8 @@ writeUser wt tableName k (Pact.RowData newRow) = do (Nothing, Pact.Update) -> liftGas $ Pact.throwDbOpErrorGasM (Pact.NoRowFound tableName k) doWriteRow - -- ^ the highest block we should be reading writes from - :: Pact.WriteType + :: HasVersion + => Pact.WriteType -> Pact.Domain k v Pact.CoreBuiltin Pact.Info -> k -> v @@ -565,8 +504,9 @@ doWriteRow wt d k v = case d of doKeys :: forall k v logger + . HasVersion -- ^ the highest block we should be reading writes from - . Pact.Domain k v Pact.CoreBuiltin Pact.Info + => Pact.Domain k v Pact.CoreBuiltin Pact.Info -> BlockHandler logger [k] doKeys d = do dbKeys <- getDbKeys @@ -578,12 +518,12 @@ doKeys d = do Pact.DKeySets -> do let parsed = traverse Pact.parseAnyKeysetName dbKeys case parsed of - Left msg -> internalDbError $ "doKeys.DKeySets: unexpected decoding " <> T.pack msg + Left msg -> error $ "doKeys.DKeySets: unexpected decoding " <> msg Right v -> pure (v, Dict ()) Pact.DModules -> do let parsed = traverse Pact.parseModuleName dbKeys case parsed of - Nothing -> internalDbError $ "doKeys.DModules: unexpected decoding" + Nothing -> error $ "doKeys.DModules: unexpected decoding" Just v -> pure (v, Dict ()) Pact.DNamespaces -> pure (map Pact.NamespaceName dbKeys, Dict ()) Pact.DDefPacts -> pure (map Pact.DefPactId dbKeys, Dict ()) @@ -592,13 +532,12 @@ doKeys d = do let parsed = map Pact.parseHashedModuleName dbKeys case sequence parsed of Just v -> pure (v, Dict ()) - Nothing -> internalDbError $ "doKeys.DModuleSources: unexpected decoding" + Nothing -> error $ "doKeys.DModuleSources: unexpected decoding" case ordDict of Dict () -> do - v <- view blockHandlerVersion cid <- view blockHandlerChainId bh <- view blockHandlerBlockHeight - if chainweb230Pact v cid bh + if chainweb230Pact cid bh -- the read-cache contains duplicate keys that we need to remove. then return $ fmap (unsafeHead "doKeys") $ group $ sort (memKeys ++ parsedKeys) else return $ sort (memKeys ++ parsedKeys) @@ -611,7 +550,7 @@ doKeys d = do fromMaybe [] <$> withTableExistenceCheck pactTableName fetchKeys _ -> throwOnDbError fetchKeys where - fetchKeys :: ExceptT SQ3.Error (BlockHandler logger) [Text] + fetchKeys :: ExceptT LocatedSQ3Error (BlockHandler logger) [Text] fetchKeys = do Pact.TxId txIdUpperBoundWord64 <- view blockHandlerUpperBoundTxId db <- view blockHandlerDb @@ -621,7 +560,7 @@ doKeys d = do forM ks $ \row -> do case row of [SText k] -> return $ fromUtf8 k - _ -> internalDbError "doKeys: The impossible happened." + _ -> error "doKeys: The impossible happened." tn = toUtf8 $ Pact.renderDomain d collect p = InMemDb.keys d (_pendingWrites p) @@ -646,8 +585,8 @@ recordTableCreationTxLog tn = do !uti = Pact.UserTableInfo (Pact._tableModuleName tn) doCreateUserTable - -- ^ the highest block we should be seeing tables from - :: Pact.TableName + :: HasVersion + => Pact.TableName -> BlockHandler logger () doCreateUserTable tableName = do -- first check if tablename already exists in pending queues @@ -695,18 +634,18 @@ doBegin _m = do bsPendingTxLog .= Just mempty Just <$> use latestTxId -toTxLog :: MonadThrow m => ChainwebVersion -> ChainId -> BlockHeight -> T.Text -> SQ3.Utf8 -> BS.ByteString -> m (Pact.TxLog Pact.RowData) -toTxLog version cid bh d key value = do - let serialiser = pact5Serialiser version cid bh +toTxLog + :: (MonadThrow m, HasVersion) + => ChainId -> BlockHeight + -> T.Text -> SQ3.Utf8 -> BS.ByteString -> m (Pact.TxLog Pact.RowData) +toTxLog cid bh d key value = do + let serialiser = pact5Serialiser cid bh case fmap (view Pact.document) $ Pact._decodeRowData serialiser value of - Nothing -> internalDbError $ "toTxLog: Unexpected value, unable to deserialize log: " <> sshow value + Nothing -> error $ "toTxLog: Unexpected value, unable to deserialize log: " <> sshow value Just v -> return $! Pact.TxLog d (fromUtf8 key) v -toPactTxLog :: Pact.TxLog Pact.RowData -> Pact4.TxLog Pact.RowData -toPactTxLog (Pact.TxLog d k v) = Pact4.TxLog d k v - -commitBlockStateToDatabase :: SQLiteEnv -> BlockHash -> BlockHeight -> BlockHandle Pact5 -> IO () -commitBlockStateToDatabase db hsh bh blockHandle = throwOnDbError $ do +commitBlockStateToDatabase :: SQLiteEnv -> Ranked (BlockHash, BlockPayloadHash) -> BlockHandle -> IO () +commitBlockStateToDatabase db blockInfo blockHandle = throwOnDbError $ do let newTables = _pendingTableCreation $ _blockHandlePending blockHandle mapM_ (\tn -> createUserTable (toUtf8 tn)) newTables backendWriteUpdateBatch (_pendingWrites (_blockHandlePending blockHandle)) @@ -717,7 +656,7 @@ commitBlockStateToDatabase db hsh bh blockHandle = throwOnDbError $ do backendWriteUpdateBatch :: InMemDb.Store - -> ExceptT SQ3.Error IO () + -> ExceptT LocatedSQ3Error IO () backendWriteUpdateBatch store = do writeTable (domainToTableName Pact.DKeySets) $ mapMaybe (uncurry $ prepRow . convKeySetName) @@ -755,32 +694,33 @@ commitBlockStateToDatabase db hsh bh blockHandle = throwOnDbError $ do ] prepRow _ InMemDb.ReadEntry {} = Nothing - writeTable :: SQ3.Utf8 -> [[SType]] -> ExceptT SQ3.Error IO () + writeTable :: SQ3.Utf8 -> [[SType]] -> ExceptT LocatedSQ3Error IO () writeTable table writes = when (not (null writes)) $ do execMulti db q writes - markTableMutation table bh + markTableMutation table where q = "INSERT OR REPLACE INTO " <> tbl table <> "(rowkey,txid,rowdata) VALUES(?,?,?)" -- Mark the table as being mutated during this block, so that we know -- to delete from it if we rewind past this block. - markTableMutation tablename blockheight = do - exec' db mutq [SText tablename, SInt (fromIntegral blockheight)] + markTableMutation tablename = do + exec' db mutq [SText tablename, SInt (fromIntegral $ rank blockInfo)] where mutq = "INSERT OR IGNORE INTO VersionedTableMutation VALUES (?,?);" -- | Record a block as being in the history of the checkpointer. - blockHistoryInsert :: Pact4.TxId -> ExceptT SQ3.Error IO () - blockHistoryInsert t = + blockHistoryInsert :: Pact.TxId -> ExceptT LocatedSQ3Error IO () + blockHistoryInsert (Pact.TxId t) = exec' db stmt - [ SInt (fromIntegral bh) - , SBlob (runPutS (encodeBlockHash hsh)) + [ SInt (fromIntegral $ rank blockInfo) + , SBlob (runPutS $ encodeBlockHash $ fst $ _ranked blockInfo) + , SBlob (runPutS $ encodeBlockPayloadHash $ snd $ _ranked blockInfo) , SInt (fromIntegral t) ] where - stmt = "INSERT INTO BlockHistory ('blockheight','hash','endingtxid') VALUES (?,?,?);" + stmt = "INSERT INTO BlockHistory2 ('blockheight', 'hash', 'payloadhash', 'endingtxid') VALUES (?,?,?,?);" - createUserTable :: SQ3.Utf8 -> ExceptT SQ3.Error IO () + createUserTable :: SQ3.Utf8 -> ExceptT LocatedSQ3Error IO () createUserTable tablename = do createVersionedTable tablename db markTableCreation tablename @@ -791,22 +731,22 @@ commitBlockStateToDatabase db hsh bh blockHandle = throwOnDbError $ do exec' db insertstmt insertargs where insertstmt = "INSERT OR IGNORE INTO VersionedTableCreation VALUES (?,?)" - insertargs = [SText tablename, SInt (fromIntegral bh)] + insertargs = [SText tablename, SInt (fromIntegral $ rank blockInfo)] -- | Commit the index of pending successful transactions to the database - indexPendingPactTransactions :: ExceptT SQ3.Error IO () + indexPendingPactTransactions :: ExceptT LocatedSQ3Error IO () indexPendingPactTransactions = do let txs = _pendingSuccessfulTxs $ _blockHandlePending blockHandle dbIndexTransactions txs where - toRow b = [SBlob b, SInt (fromIntegral bh)] + toRow b = [SBlob b, SInt (fromIntegral $ rank blockInfo)] dbIndexTransactions txs = do let rows = map toRow $ toList txs let q = "INSERT INTO TransactionIndex (txhash, blockheight) VALUES (?, ?)" execMulti db q rows -createVersionedTable :: SQ3.Utf8 -> SQ3.Database -> ExceptT SQ3.Error IO () +createVersionedTable :: SQ3.Utf8 -> SQ3.Database -> ExceptT LocatedSQ3Error IO () createVersionedTable tablename db = do exec_ db createtablestmt exec_ db indexcreationstmt @@ -821,64 +761,77 @@ createVersionedTable tablename db = do indexcreationstmt = "CREATE INDEX IF NOT EXISTS " <> tbl ixName <> " ON " <> tbl tablename <> "(txid DESC);" - -- | Create all tables that exist pre-genesis -- TODO: migrate this logic to the checkpointer itself? initSchema :: SQLiteEnv -> IO () -initSchema sql = - withSavepoint sql DbTransaction $ throwOnDbError $ do - 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 +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 - - createBlockHistoryTable :: ExceptT SQ3.Error IO () - createBlockHistoryTable = - exec_ sql - "CREATE TABLE IF NOT EXISTS BlockHistory \ - \(blockheight UNSIGNED BIGINT NOT NULL,\ - \ hash BLOB NOT NULL,\ - \ endingtxid UNSIGNED BIGINT NOT NULL, \ - \ CONSTRAINT blockHashConstraint UNIQUE (blockheight));" - - createTableCreationTable :: ExceptT SQ3.Error IO () + createVersionedTable tablename sql + + createConsensusStateTable :: ExceptT LocatedSQ3Error IO () + createConsensusStateTable = do + exec_ sql + "CREATE TABLE IF NOT EXISTS ConsensusState \ + \(blockheight UNSIGNED BIGINT NOT NULL, \ + \ hash BLOB NOT NULL, \ + \ payloadhash BLOB NOT NULL, \ + \ safety TEXT NOT NULL, \ + \ CONSTRAINT safetyConstraint UNIQUE (safety) \ + \ ON CONFLICT REPLACE);" + + createBlockHistoryTable :: ExceptT LocatedSQ3Error IO () + createBlockHistoryTable = do + exec_ sql + "CREATE TABLE IF NOT EXISTS BlockHistory2 \ + \(blockheight UNSIGNED BIGINT NOT NULL, \ + \ endingtxid UNSIGNED BIGINT NOT NULL, \ + \ hash BLOB NOT NULL, \ + \ payloadhash BLOB NOT NULL, \ + \ CONSTRAINT blockHeightConstraint UNIQUE (blockheight), \ + \ CONSTRAINT hashConstraint UNIQUE (hash));" + -- TODO PP: payload hash should really be NOT NULL but there may exist old databases without it. + -- making a block hash index at block height 5,658,430 on us-e3 took around 2.5 minutes + + createTableCreationTable :: ExceptT LocatedSQ3Error IO () createTableCreationTable = - exec_ sql - "CREATE TABLE IF NOT EXISTS VersionedTableCreation\ - \(tablename TEXT NOT NULL\ - \, createBlockheight UNSIGNED BIGINT NOT NULL\ - \, CONSTRAINT creation_unique UNIQUE(createBlockheight, tablename));" + exec_ sql + "CREATE TABLE IF NOT EXISTS VersionedTableCreation\ + \(tablename TEXT NOT NULL\ + \, createBlockheight UNSIGNED BIGINT NOT NULL\ + \, CONSTRAINT creation_unique UNIQUE(createBlockheight, tablename));" - createTableMutationTable :: ExceptT SQ3.Error IO () + createTableMutationTable :: ExceptT LocatedSQ3Error IO () createTableMutationTable = - exec_ sql - "CREATE TABLE IF NOT EXISTS VersionedTableMutation\ - \(tablename TEXT NOT NULL\ - \, blockheight UNSIGNED BIGINT NOT NULL\ - \, CONSTRAINT mutation_unique UNIQUE(blockheight, tablename));" + exec_ sql + "CREATE TABLE IF NOT EXISTS VersionedTableMutation\ + \(tablename TEXT NOT NULL\ + \, blockheight UNSIGNED BIGINT NOT NULL\ + \, CONSTRAINT mutation_unique UNIQUE(blockheight, tablename));" - createTransactionIndexTable :: ExceptT SQ3.Error IO () + createTransactionIndexTable :: ExceptT LocatedSQ3Error IO () createTransactionIndexTable = do - exec_ sql - "CREATE TABLE IF NOT EXISTS TransactionIndex \ - \ (txhash BLOB NOT NULL, \ - \ blockheight UNSIGNED BIGINT NOT NULL, \ - \ CONSTRAINT transactionIndexConstraint UNIQUE(txhash));" - exec_ sql - "CREATE INDEX IF NOT EXISTS \ - \ transactionIndexByBH ON TransactionIndex(blockheight)"; - -getSerialiser :: BlockHandler logger (Pact.PactSerialise Pact.CoreBuiltin Pact.LineInfo) + exec_ sql + "CREATE TABLE IF NOT EXISTS TransactionIndex \ + \ (txhash BLOB NOT NULL, \ + \ blockheight UNSIGNED BIGINT NOT NULL, \ + \ CONSTRAINT transactionIndexConstraint UNIQUE(txhash));" + exec_ sql + "CREATE INDEX IF NOT EXISTS \ + \ transactionIndexByBH ON TransactionIndex(blockheight)"; + +getSerialiser :: HasVersion => BlockHandler logger (Pact.PactSerialise Pact.CoreBuiltin Pact.LineInfo) getSerialiser = do - version <- view blockHandlerVersion cid <- view blockHandlerChainId blockHeight <- view blockHandlerBlockHeight - return $ pact5Serialiser version cid blockHeight + return $ pact5Serialiser cid blockHeight diff --git a/src/Chainweb/Pact/Backend/Compaction.hs b/src/Chainweb/Pact/Backend/Compaction.hs index b0c1a9c116..a21fdae878 100644 --- a/src/Chainweb/Pact/Backend/Compaction.hs +++ b/src/Chainweb/Pact/Backend/Compaction.hs @@ -1,23 +1,21 @@ -{-# language - BangPatterns - , CPP - , DeriveAnyClass - , DeriveGeneric - , DerivingStrategies - , DuplicateRecordFields - , FlexibleContexts - , GeneralizedNewtypeDeriving - , ImportQualifiedPost - , LambdaCase - , NumericUnderscores - , OverloadedRecordDot - , OverloadedStrings - , PackageImports - , ScopedTypeVariables - , TypeApplications - , RecordWildCards - , ApplicativeDo -#-} +{-# LANGUAGE ApplicativeDo #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NumericUnderscores #-} +{-# LANGUAGE OverloadedRecordDot #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PackageImports #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} module Chainweb.Pact.Backend.Compaction ( @@ -36,37 +34,7 @@ module Chainweb.Pact.Backend.Compaction ) where -import "base" Control.Exception hiding (Handler) -import "base" Control.Monad (forM, forM_, unless, void, when) -import "base" Control.Monad.IO.Class (MonadIO(liftIO)) -import "base" Data.Function ((&)) -import "base" Data.Int (Int64) -import "base" Data.Maybe (fromMaybe) -import "base" Prelude hiding (log) -import "base" System.Exit (exitFailure) -import "base" System.IO (Handle) -import "base" System.IO qualified as IO -import "chainweb-storage" Chainweb.Storage.Table (Iterator(..), Entry(..), withTableIterator, unCasify, tableInsert) -import "chainweb-storage" Chainweb.Storage.Table.RocksDB (RocksDb, withRocksDb, withReadOnlyRocksDb, modernDefaultOptions) -import "direct-sqlite" Database.SQLite3 qualified as Lite -import "direct-sqlite" Database.SQLite3.Direct (Utf8(..), Database) -import "directory" System.Directory (createDirectoryIfMissing, doesDirectoryExist) -import "filepath" System.FilePath (()) -import "lens" Control.Lens (set, over, (^.), _3, view) -import "loglevel" System.LogLevel qualified as LL -import "monad-control" Control.Monad.Trans.Control (MonadBaseControl, liftBaseOp) -import "optparse-applicative" Options.Applicative qualified as O -import "pact" Pact.Types.SQLite (SType(..), RType(..)) -import "pact" Pact.Types.SQLite qualified as Pact -import "rocksdb-haskell-kadena" Database.RocksDB.Types (Options(..), Compression(..)) -import "streaming" Streaming qualified as S -import "streaming" Streaming.Prelude qualified as S -import "text" Data.Text (Text) -import "text" Data.Text qualified as Text -import "unliftio" UnliftIO.Async (pooledForConcurrently_) -import "yet-another-logger" System.Logger hiding (Logger) -import "yet-another-logger" System.Logger qualified as YAL -import "yet-another-logger" System.Logger.Backend.ColorOption (useColor) +import Control.Exception hiding (Handler) import Chainweb.BlockHash import Chainweb.BlockHeader (blockHeight, blockForkNumber, blockHash, blockPayloadHash) import Chainweb.BlockHeaderDB.Internal (BlockHeaderDb(..), RankedBlockHeader(..)) @@ -74,20 +42,49 @@ import Chainweb.BlockHeight (BlockHeight(..)) import Chainweb.Cut.CutHashes (cutIdToText) import Chainweb.CutDB (cutHashesTable) import Chainweb.Logger (Logger, l2l, setComponent, logFunctionText) -import Chainweb.Pact4.Backend.ChainwebPactDb () +import Chainweb.Pact.Backend.ChainwebPactDb () import Chainweb.Pact.Backend.PactState import Chainweb.Pact.Backend.Types import Chainweb.Pact.Backend.Utils -import Chainweb.Payload.PayloadStore (initializePayloadDb, addNewPayload, lookupPayloadWithHeight) -import Chainweb.Payload.PayloadStore.RocksDB (newPayloadDb) -import Chainweb.Utils (sshow, fromText, toText, int) -import Chainweb.Version (ChainId, ChainwebVersion(..), chainIdToText) +import Chainweb.Pact.Payload.PayloadStore (addNewPayload, lookupPayloadWithHeight) +import Chainweb.Pact.Payload.PayloadStore.RocksDB (newPayloadDb) +import Chainweb.Storage.Table (Iterator(..), Entry(..), withTableIterator, unCasify, tableInsert) +import Chainweb.Storage.Table.RocksDB (RocksDb, withRocksDb, withReadOnlyRocksDb, modernDefaultOptions) +import Chainweb.Utils (sshow, fromTextM, toText, int) +import Chainweb.Version (ChainId, HasVersion(..), withVersion, ChainwebVersion(..)) import Chainweb.Version.Guards (minimumBlockHeaderHistory) import Chainweb.Version.Mainnet (mainnet) -import Chainweb.Version.Registry (lookupVersionByName) +import Chainweb.Version.Registry (findKnownVersion) import Chainweb.Version.Testnet04 (testnet04) import Chainweb.WebBlockHeaderDB (getWebBlockHeaderDb, initWebBlockHeaderDb) +import Control.Lens (set, over, (^.), _3, view) +import Control.Monad (forM, forM_, unless, void, when) +import Control.Monad.IO.Class (MonadIO(liftIO)) +import Control.Monad.Trans.Control (MonadBaseControl, liftBaseOp) +import Control.Monad.Trans.Resource (runResourceT) +import Data.Function ((&)) +import Data.Int (Int64) import Data.LogMessage (SomeLogMessage, logText) +import Data.Maybe (fromMaybe) +import Data.Text (Text) +import Data.Text qualified as Text +import Database.RocksDB.Types (Options(..), Compression(..)) +import Database.SQLite3 qualified as Lite +import Database.SQLite3.Direct (Utf8(..), Database) +import Options.Applicative qualified as O +import Prelude hiding (log) +import Streaming qualified as S +import Streaming.Prelude qualified as S +import System.Directory (createDirectoryIfMissing, doesDirectoryExist) +import System.Exit (exitFailure) +import System.FilePath (()) +import System.IO (Handle) +import System.IO qualified as IO +import System.LogLevel qualified as LL +import System.Logger hiding (Logger) +import System.Logger qualified as YAL +import System.Logger.Backend.ColorOption (useColor) +import UnliftIO.Async (pooledForConcurrently_) withDefaultLogger :: LL.LogLevel -> (YAL.Logger SomeLogMessage -> IO a) -> IO a withDefaultLogger ll f = withHandleBackend_ logText handleCfg $ \b -> @@ -122,11 +119,11 @@ withPerChainFileLogger ld chainId ll f = do IO.hSetBuffering h IO.LineBuffering withLogger defaultLoggerConfig b $ \l -> do let logger = setComponent "compaction" - $ over setLoggerScope (("chain", chainIdToText chainId) :) + $ over setLoggerScope (("chain", toText chainId) :) $ set setLoggerLevel (l2l ll) l f logger where - cid = Text.unpack (chainIdToText chainId) + cid = Text.unpack (toText chainId) withHandleBackend_' :: (MonadIO m, MonadBaseControl IO m) => (msg -> Text) @@ -206,9 +203,9 @@ getConfig = do parseVersion :: Text -> ChainwebVersion parseVersion = - lookupVersionByName - . fromMaybe (error "ChainwebVersion parse failed") - . fromText + fromMaybe (error "ChainwebVersion parse failed") + . (>>= findKnownVersion) + . fromTextM main :: IO () main = do @@ -238,7 +235,7 @@ doCompactPactState logger rt targetBlockHeight srcDb targetDb = do -- Note that we can't apply pragmas to the src -- because we can't guarantee it's not being accessed -- by another process. - Pact.runPragmas targetDb fastBulkInsertPragmas + runPragmas targetDb fastBulkInsertPragmas -- Create checkpointer tables on the target createCheckpointerTables targetDb logger @@ -248,7 +245,7 @@ doCompactPactState logger rt targetBlockHeight srcDb targetDb = do do logfun LL.Info "Compacting BlockHistory" activeRow <- getBlockHistoryRowAt logger srcDb targetBlockHeight - Pact.exec' targetDb "INSERT INTO BlockHistory VALUES (?1, ?2, ?3)" activeRow + throwOnDbError $ exec' targetDb "INSERT INTO BlockHistory2 ('blockheight', 'hash', 'payloadhash', 'endingtxid') VALUES (?1, ?2, ?3, ?4)" activeRow -- Compact VersionedTableMutation -- This is extremely fast and low residency @@ -257,7 +254,7 @@ doCompactPactState logger rt targetBlockHeight srcDb targetDb = do activeRows <- getVersionedTableMutationRowsAt logger srcDb targetBlockHeight Lite.withStatement targetDb "INSERT INTO VersionedTableMutation VALUES (?1, ?2)" $ \stmt -> do forM_ activeRows $ \row -> do - Pact.bindParams stmt row + throwOnDbError $ bindParams stmt row void $ stepThenReset stmt -- Copy over VersionedTableCreation. Read-only rewind needs to know @@ -270,7 +267,7 @@ doCompactPactState logger rt targetBlockHeight srcDb targetDb = do throwSqlError $ qryStream srcDb wholeTableQuery [] [RText, RInt] $ \tblRows -> do Lite.withStatement targetDb "INSERT INTO VersionedTableCreation VALUES (?1, ?2)" $ \stmt -> do flip S.mapM_ tblRows $ \row -> do - Pact.bindParams stmt row + throwOnDbError $ bindParams stmt row void $ stepThenReset stmt -- Copy over TransactionIndex. @@ -283,7 +280,7 @@ doCompactPactState logger rt targetBlockHeight srcDb targetDb = do -- Maybe consider -- https://tableplus.com/blog/2018/07/sqlite-how-to-copy-table-to-another-database.html do - (qry, args) <- + (query, args) <- if not rt.compactTransactionIndex then do logfun LL.Info "Copying over entire TransactionIndex table. This could take a while" @@ -294,7 +291,7 @@ doCompactPactState logger rt targetBlockHeight srcDb targetDb = do let wholeTableQuery = "SELECT txhash, blockheight FROM TransactionIndex WHERE blockheight >= ?1 ORDER BY blockheight" pure (wholeTableQuery, [SInt (int (targetBlockHeight - blockHeightKeepDepth))]) - throwSqlError $ qryStream srcDb qry args [RBlob, RInt] $ \tblRows -> do + throwSqlError $ qryStream srcDb query args [RBlob, RInt] $ \tblRows -> do Lite.withStatement targetDb "INSERT INTO TransactionIndex VALUES (?1, ?2)" $ \stmt -> do -- I experimented a bunch with chunk sizes, to keep transactions -- small. As far as I can tell, there isn't really much @@ -304,14 +301,14 @@ doCompactPactState logger rt targetBlockHeight srcDb targetDb = do S.chunksOf 10_000 tblRows & S.mapsM_ (\chunk -> do inTx targetDb $ flip S.mapM_ chunk $ \row -> do - Pact.bindParams stmt row + throwOnDbError $ bindParams stmt row void (stepThenReset stmt) ) -- Vacuuming after copying over all of the TransactionIndex data, -- but before creating its indices, makes a big differences in -- memory residency (~0.5G), at the expense of speed (~20s increase) - Pact.exec_ targetDb "VACUUM;" + throwOnDbError $ exec_ targetDb "VACUUM;" -- Create the checkpointer table indices after bulk-inserting into them -- This is faster than creating the indices before @@ -347,8 +344,8 @@ blockHeightKeepDepth :: BlockHeight blockHeightKeepDepth = 2_000 compact :: Config -> IO () -compact cfg = do - let cids = allChains cfg.chainwebVersion +compact cfg = withVersion cfg.chainwebVersion $ do + let cids = allChains let _compactThese = case (cfg.compactRocksDb, cfg.compactPactState) of (False, False) -> CompactNeither @@ -394,7 +391,7 @@ compact cfg = do withRocksDbFileLogger cfg.logDir LL.Debug $ \logger -> do withReadOnlyRocksDb (rocksDir cfg.fromDir) modernDefaultOptions $ \srcRocksDb -> do withRocksDb (rocksDir cfg.toDir) (modernDefaultOptions { compression = NoCompression }) $ \targetRocksDb -> do - doCompactRocksDb (set setLoggerLevel (l2l LL.Info) logger) cfg.chainwebVersion cids (targetBlockHeight - blockHeightKeepDepth) srcRocksDb targetRocksDb + doCompactRocksDb (set setLoggerLevel (l2l LL.Info) logger) cids (targetBlockHeight - blockHeightKeepDepth) srcRocksDb targetRocksDb -- Compact the pact state. let retainment = Retainment @@ -403,10 +400,10 @@ compact cfg = do } when cfg.compactPactState $ do forChains_ cfg.concurrent cids $ \cid -> do - withPerChainFileLogger cfg.logDir cid LL.Debug $ \logger -> do - withChainDb cid logger (pactDir cfg.fromDir) $ \_ srcDb -> do - withChainDb cid logger (pactDir cfg.toDir) $ \_ targetDb -> do - doCompactPactState logger retainment targetBlockHeight srcDb targetDb + withPerChainFileLogger cfg.logDir cid LL.Debug $ \logger -> runResourceT $ do + srcDb <- withChainDb cid logger (pactDir cfg.fromDir) + targetDb <- withChainDb cid logger (pactDir cfg.toDir) + liftIO $ doCompactPactState logger retainment targetBlockHeight srcDb targetDb compactTable :: (Logger logger) => logger -- ^ logger @@ -439,7 +436,7 @@ compactTable logger srcDb targetDb tblname endingTxId = do -- Create a temporary index on 'rowkey' for a user table, so that upserts work correctly. inTx targetDb $ do - Pact.exec_ targetDb $ mconcat + throwOnDbError $ exec_ targetDb $ mconcat [ "CREATE UNIQUE INDEX IF NOT EXISTS ", tbl (tblnameUtf8 <> "_rowkey_unique_ix_TEMP"), " ON " , tbl tblnameUtf8, " (rowkey)" ] @@ -479,7 +476,7 @@ compactTable logger srcDb targetDb tblname endingTxId = do inTx targetDb $ flip S.mapM_ chunk $ \row -> do case row of [SText _, SInt _, SBlob _] -> do - Pact.bindParams upsertRow row + throwOnDbError $ bindParams upsertRow row void $ stepThenReset upsertRow _badRowShape -> do exitLog logger "Encountered invalid row shape while compacting" @@ -489,7 +486,7 @@ compactTable logger srcDb targetDb tblname endingTxId = do -- If we were to keep this index around, the node would not be able to operate, since -- we need to update new rows for the same rowkey. inTx targetDb $ do - Pact.exec_ targetDb $ mconcat + throwOnDbError $ exec_ targetDb $ mconcat [ "DROP INDEX IF EXISTS ", tbl (tblnameUtf8 <> "_rowkey_unique_ix_TEMP") ] @@ -509,16 +506,17 @@ createCheckpointerTables db logger = do let logfun = logFunctionText logger LL.Info logfun "Creating Checkpointer table BlockHistory" - inTx db $ Pact.exec_ db $ mconcat - [ "CREATE TABLE IF NOT EXISTS BlockHistory " + inTx db $ throwOnDbError $ exec_ db $ mconcat + [ "CREATE TABLE IF NOT EXISTS BlockHistory2 " , "(blockheight UNSIGNED BIGINT NOT NULL" - , ", hash BLOB NOT NULL" , ", endingtxid UNSIGNED BIGINT NOT NULL" + , ", hash BLOB NOT NULL" + , ", payloadhash BLOB NOT NULL" , ");" ] logfun "Creating Checkpointer table VersionedTableCreation" - inTx db $ Pact.exec_ db $ mconcat + inTx db $ throwOnDbError $ exec_ db $ mconcat [ "CREATE TABLE IF NOT EXISTS VersionedTableCreation " , "(tablename TEXT NOT NULL" , ", createBlockheight UNSIGNED BIGINT NOT NULL" @@ -526,7 +524,7 @@ createCheckpointerTables db logger = do ] logfun "Creating Checkpointer table VersionedTableMutation" - inTx db $ Pact.exec_ db $ mconcat + inTx db $ throwOnDbError $ exec_ db $ mconcat [ "CREATE TABLE IF NOT EXISTS VersionedTableMutation " , "(tablename TEXT NOT NULL" , ", blockheight UNSIGNED BIGINT NOT NULL" @@ -534,7 +532,7 @@ createCheckpointerTables db logger = do ] logfun "Creating Checkpointer table TransactionIndex" - inTx db $ Pact.exec_ db $ mconcat + inTx db $ throwOnDbError $ exec_ db $ mconcat [ "CREATE TABLE IF NOT EXISTS TransactionIndex " , "(txhash BLOB NOT NULL" , ", blockheight UNSIGNED BIGINT NOT NULL" @@ -543,9 +541,9 @@ createCheckpointerTables db logger = do -- We have to delete from these tables because of the way the test harnesses work. -- Ideally in the future this can be removed. - forM_ ["BlockHistory", "VersionedTableCreation", "VersionedTableMutation", "TransactionIndex"] $ \tblname -> do + forM_ ["BlockHistory2", "VersionedTableCreation", "VersionedTableMutation", "TransactionIndex"] $ \tblname -> do logfun $ "Deleting from table " <> fromUtf8 tblname - Pact.exec_ db $ "DELETE FROM " <> tbl tblname + throwOnDbError $ exec_ db $ "DELETE FROM " <> tbl tblname -- | Create all the indexes for the checkpointer tables. createCheckpointerIndexes :: (Logger logger) => Database -> logger -> IO () @@ -553,27 +551,27 @@ createCheckpointerIndexes db logger = do let logfun = logFunctionText logger LL.Info logfun "Creating BlockHistory index" - inTx db $ Pact.exec_ db - "CREATE UNIQUE INDEX IF NOT EXISTS BlockHistory_blockheight_unique_ix ON BlockHistory (blockheight)" + inTx db $ throwOnDbError $ exec_ db + "CREATE UNIQUE INDEX IF NOT EXISTS BlockHistory_blockheight_unique_ix ON BlockHistory2 (blockheight)" logfun "Creating VersionedTableCreation index" - inTx db $ Pact.exec_ db + inTx db $ throwOnDbError $ exec_ db "CREATE UNIQUE INDEX IF NOT EXISTS VersionedTableCreation_createBlockheight_tablename_unique_ix ON VersionedTableCreation (createBlockheight, tablename)" logfun "Creating VersionedTableMutation index" - inTx db $ Pact.exec_ db + inTx db $ throwOnDbError $ exec_ db "CREATE UNIQUE INDEX IF NOT EXISTS VersionedTableMutation_blockheight_tablename_unique_ix ON VersionedTableMutation (blockheight, tablename)" logfun "Creating TransactionIndex indexes" - inTx db $ Pact.exec_ db + inTx db $ throwOnDbError $ exec_ db "CREATE UNIQUE INDEX IF NOT EXISTS TransactionIndex_txhash_unique_ix ON TransactionIndex (txhash)" - inTx db $ Pact.exec_ db + inTx db $ throwOnDbError $ exec_ db "CREATE INDEX IF NOT EXISTS TransactionIndex_blockheight_ix ON TransactionIndex (blockheight)" -- | Create a single user table createUserTable :: Database -> Utf8 -> IO () createUserTable db tblname = do - Pact.exec_ db $ mconcat + throwOnDbError $ exec_ db $ mconcat [ "CREATE TABLE IF NOT EXISTS ", tbl tblname, " " , "(rowid INTEGER PRIMARY KEY AUTOINCREMENT" , ", rowkey TEXT" -- This should be NOT NULL; we need to make a follow-up PR to chainweb-node to update this here and the checkpointer schema @@ -584,33 +582,33 @@ createUserTable db tblname = do -- We have to delete from the table because of the way the test harnesses work. -- Ideally in the future this can be removed. - Pact.exec_ db $ "DELETE FROM " <> tbl tblname + throwOnDbError $ exec_ db $ "DELETE FROM " <> tbl tblname -- | Create the indexes for a single user table createUserTableIndex :: Database -> Utf8 -> IO () createUserTableIndex db tblname = do inTx db $ do - Pact.exec_ db $ mconcat + throwOnDbError $ exec_ db $ mconcat [ "CREATE UNIQUE INDEX IF NOT EXISTS ", tbl (tblname <> "_rowkey_txid_unique_ix"), " ON " , tbl tblname, " (rowkey, txid)" ] - Pact.exec_ db $ mconcat + throwOnDbError $ exec_ db $ mconcat [ "CREATE INDEX IF NOT EXISTS ", tbl (tblname <> "_txid_ix"), " ON " , tbl tblname, " (txid DESC)" ] --- | Returns the active @(blockheight, hash, endingtxid)@ from BlockHistory +-- | Returns the active @(blockheight, hash, endingtxid)@ from BlockHistory2 getBlockHistoryRowAt :: (Logger logger) => logger -> Database -> BlockHeight -> IO [SType] getBlockHistoryRowAt logger db target = do - r <- Pact.qry db "SELECT blockheight, hash, endingtxid FROM BlockHistory WHERE blockheight = ?1" [SInt (int target)] [RInt, RBlob, RInt] + r <- throwOnDbError $ qry db "SELECT blockheight, hash, payloadhash, endingtxid FROM BlockHistory2 WHERE blockheight = ?1" [SInt (int target)] [RInt, RBlob, RBlob, RInt] case r of - [row@[SInt bh, SBlob _hash, SInt _endingTxId]] -> do + [row@[SInt bh, SBlob _hash, SBlob _phash, SInt _endingTxId]] -> do unless (target == int bh) $ do - exitLog logger "BlockHeight mismatch in BlockHistory query. This is a bug in the compaction tool. Please report it on the issue tracker or discord." + exitLog logger "BlockHeight mismatch in BlockHistory2 query. This is a bug in the compaction tool. Please report it on the issue tracker or discord." pure row _ -> do exitLog logger "getBlockHistoryRowAt query: invalid query" @@ -622,7 +620,7 @@ getVersionedTableMutationRowsAt :: (Logger logger) -> BlockHeight -> IO [[SType]] getVersionedTableMutationRowsAt logger db target = do - r <- Pact.qry db "SELECT tablename, blockheight FROM VersionedTableMutation WHERE blockheight = ?1" [SInt (int target)] [RText, RInt] + r <- throwOnDbError $ qry db "SELECT tablename, blockheight FROM VersionedTableMutation WHERE blockheight = ?1" [SInt (int target)] [RText, RInt] forM r $ \case row@[SText _, SInt bh] -> do unless (target == int bh) $ do @@ -702,8 +700,8 @@ throwSqlError ioe = do inTx :: Database -> IO a -> IO a inTx db io = do bracket_ - (Pact.exec_ db "BEGIN;") - (Pact.exec_ db "COMMIT;") + (throwOnDbError $ exec_ db "BEGIN;") + (throwOnDbError $ exec_ db "COMMIT;") io pactDir :: FilePath -> FilePath @@ -714,27 +712,27 @@ rocksDir db = db "0/rocksDb" -- | Copy over all CutHashes, all BlockHeaders, and only some Payloads. doCompactRocksDb :: (Logger logger) + => HasVersion => logger - -> ChainwebVersion -- ^ cw version -> [ChainId] -- ^ ChainIds -> BlockHeight -- ^ minBlockHeight for payload copying -> RocksDb -- ^ source db, should be opened read-only -> RocksDb -- ^ target db -> IO () -doCompactRocksDb logger cwVersion cids minBlockHeight srcDb targetDb = do - let logfun = logFunctionText logger +doCompactRocksDb logger cids minBlockHeight srcDb targetDb = do + let log = logFunctionText logger -- Copy over entirety of CutHashes table let srcCutHashes = cutHashesTable srcDb let targetCutHashes = cutHashesTable targetDb - logfun LL.Info "Copying over CutHashes table" + log LL.Info "Copying over CutHashes table" withTableIterator (unCasify srcCutHashes) $ \srcIt -> do let go = do iterEntry srcIt >>= \case Nothing -> do pure () Just (Entry k v) -> do - logfun LL.Debug $ "Copying over Cut " <> cutIdToText (k ^. _3) + log LL.Debug $ "Copying over Cut " <> cutIdToText (k ^. _3) tableInsert targetCutHashes k v iterNext srcIt go @@ -744,15 +742,13 @@ doCompactRocksDb logger cwVersion cids minBlockHeight srcDb targetDb = do let srcPayloads = newPayloadDb srcDb let targetPayloads = newPayloadDb targetDb - -- The target payload db has to be initialised. - logfun LL.Info "Initializing payload db" - initializePayloadDb cwVersion targetPayloads - - srcWbhdb <- initWebBlockHeaderDb srcDb cwVersion - targetWbhdb <- initWebBlockHeaderDb targetDb cwVersion + -- The target payload db has to be initialised. TODO PP: does it? + log LL.Info "Initializing payload db" + srcWbhdb <- initWebBlockHeaderDb srcDb + targetWbhdb <- initWebBlockHeaderDb targetDb forM_ cids $ \cid -> do let log' = logFunctionText (addChainIdLabel cid logger) - log' LL.Info $ "Starting chain " <> chainIdToText cid + log' LL.Info $ "Starting chain " <> toText cid srcBlockHeaderDb <- getWebBlockHeaderDb srcWbhdb cid targetBlockHeaderDb <- getWebBlockHeaderDb targetWbhdb cid @@ -775,7 +771,9 @@ doCompactRocksDb logger cwVersion cids minBlockHeight srcDb targetDb = do -- Note, this behaviour may be dangerous in case of changes on the minimum block history. -- -- TODO = Option to prune headers history to the minimum should be enabled by flag. - case minimumBlockHeaderHistory cwVersion (latestHeader ^. blockForkNumber) (latestHeader ^. blockHeight) of + case minimumBlockHeaderHistory + (latestHeader ^. blockForkNumber) + (latestHeader ^. blockHeight) of -- Go to the earliest possible entry. We migrate all BlockHeaders, for now. -- They are needed for SPV. -- diff --git a/src/Chainweb/Pact/Backend/DbCache.hs b/src/Chainweb/Pact/Backend/DbCache.hs index 0a6461ccbb..a466473074 100644 --- a/src/Chainweb/Pact/Backend/DbCache.hs +++ b/src/Chainweb/Pact/Backend/DbCache.hs @@ -17,6 +17,7 @@ -- module Chainweb.Pact.Backend.DbCache ( DbCacheLimitBytes(..) +, defaultModuleCacheLimit , DbCache , checkDbCache , emptyDbCache @@ -58,7 +59,7 @@ import Pact.Types.Persistence -- internal modules -import Chainweb.Utils (ix') +import Chainweb.Utils (ix', mebi) -- -------------------------------------------------------------------------- -- @@ -67,6 +68,9 @@ import Chainweb.Utils (ix') newtype DbCacheLimitBytes = DbCacheLimitBytes Natural deriving (Show, Read, Eq, Ord, ToJSON, FromJSON) +defaultModuleCacheLimit :: DbCacheLimitBytes +defaultModuleCacheLimit = DbCacheLimitBytes (60 * mebi) + -- -------------------------------------------------------------------------- -- -- CacheAddress diff --git a/src/Chainweb/Pact/Backend/PactState.hs b/src/Chainweb/Pact/Backend/PactState.hs index 256819a82f..4a3e2b560c 100644 --- a/src/Chainweb/Pact/Backend/PactState.hs +++ b/src/Chainweb/Pact/Backend/PactState.hs @@ -55,12 +55,11 @@ module Chainweb.Pact.Backend.PactState import Chainweb.BlockHeight (BlockHeight(..)) import Chainweb.Logger (Logger, addLabel) -import Chainweb.Pact.Backend.Utils (fromUtf8, withSqliteDb) -import Chainweb.Utils (T2(..), int) -import Chainweb.Version (ChainId, ChainwebVersion, chainIdToText) +import Chainweb.Utils (T2(..), int, HasTextRepresentation (toText)) +import Chainweb.Version import Chainweb.Version.Utils (chainIdsAt) import Control.Exception (bracket) -import Control.Monad (forM, forM_, when) +import Control.Monad (forM, when) import Control.Monad.Except (ExceptT(..), runExceptT, throwError) import Control.Monad.IO.Class (MonadIO(liftIO)) import Control.Monad.Trans.Class (lift) @@ -85,30 +84,30 @@ import Database.SQLite3.Direct qualified as Direct import System.Directory (doesFileExist) import System.FilePath (()) -import Pact.Types.SQLite (SType(..), RType(..)) -import Pact.Types.SQLite qualified as Pact import Streaming.Prelude (Stream, Of) import Streaming.Prelude qualified as S import Chainweb.Pact.Backend.Types +import Chainweb.Pact.Backend.Utils hiding (tbl) +import Control.Monad.Trans.Resource excludedTables :: [Utf8] excludedTables = checkpointerTables ++ compactionTables where - checkpointerTables = ["BlockHistory", "VersionedTableCreation", "VersionedTableMutation", "TransactionIndex"] + checkpointerTables = ["BlockHistory2", "VersionedTableCreation", "VersionedTableMutation", "TransactionIndex"] compactionTables = ["CompactGrandHash", "CompactActiveRow"] -- | Get the latest blockheight on chain. getLatestBlockHeight :: Database -> IO BlockHeight getLatestBlockHeight db = do - let qryText = "SELECT MAX(blockheight) FROM BlockHistory" - Pact.qry db qryText [] [RInt] >>= \case + let qryText = "SELECT MAX(blockheight) FROM BlockHistory2" + throwOnDbError $ qry db qryText [] [RInt] >>= \case [[SInt bh]] -> pure (BlockHeight (int bh)) _ -> error "getLatestBlockHeight: expected int" getEarliestBlockHeight :: Database -> IO BlockHeight getEarliestBlockHeight db = do - let qryText = "SELECT MIN(blockheight) FROM BlockHistory" - Pact.qry db qryText [] [RInt] >>= \case + let qryText = "SELECT MIN(blockheight) FROM BlockHistory2" + throwOnDbError $ qry db qryText [] [RInt] >>= \case [[SInt bh]] -> pure (BlockHeight (int bh)) _ -> error "getEarliestBlockHeight: expected int" @@ -117,13 +116,13 @@ getEarliestBlockHeight db = do -- Throws an exception if it doesn't. ensureBlockHeightExists :: Database -> BlockHeight -> IO () ensureBlockHeightExists db bh = do - r <- Pact.qry db "SELECT blockheight FROM BlockHistory WHERE blockheight = ?1" [SInt (fromIntegral bh)] [RInt] + r <- throwOnDbError $ qry db "SELECT blockheight FROM BlockHistory2 WHERE blockheight = ?1" [SInt (fromIntegral bh)] [RInt] case r of [[SInt rBH]] -> do when (fromIntegral bh /= rBH) $ do error "ensureBlockHeightExists: malformed query" _ -> do - error $ "ensureBlockHeightExists: empty BlockHistory: height=" ++ show bh + error $ "ensureBlockHeightExists: empty BlockHistory2: height=" ++ show bh getLatestCommonBlockHeight :: (Logger logger) => logger @@ -131,8 +130,9 @@ getLatestCommonBlockHeight :: (Logger logger) -> [ChainId] -> IO BlockHeight getLatestCommonBlockHeight logger path cids = do - fmap minimum $ forM cids $ \cid -> withChainDb cid logger path $ \_ sqlEnv -> do - getLatestBlockHeight sqlEnv + fmap minimum $ forM cids $ \cid -> runResourceT $ do + sqlEnv <- withChainDb cid logger path + liftIO $ getLatestBlockHeight sqlEnv getEarliestCommonBlockHeight :: (Logger logger) => logger @@ -140,8 +140,9 @@ getEarliestCommonBlockHeight :: (Logger logger) -> [ChainId] -> IO BlockHeight getEarliestCommonBlockHeight logger path cids = do - fmap maximum $ forM cids $ \cid -> withChainDb cid logger path $ \_ sqlEnv -> do - getEarliestBlockHeight sqlEnv + fmap maximum $ forM cids $ \cid -> runResourceT $ do + sqlEnv <- withChainDb cid logger path + liftIO $ getEarliestBlockHeight sqlEnv -- | Wrapper around 'withSqliteDb' that adds the chainId label to the logger -- and sets resetDb to False. @@ -149,12 +150,11 @@ withChainDb :: (Logger logger) => ChainId -> logger -> FilePath - -> (logger -> SQLiteEnv -> IO x) - -> IO x -withChainDb cid logger' path f = do + -> ResourceT IO SQLiteEnv +withChainDb cid logger' path = do let logger = addChainIdLabel cid logger' let resetDb = False - withSqliteDb cid logger path resetDb (f logger) + withSqliteDb cid logger path resetDb -- | Get all Pact table names in the database. getPactTableNames :: Database -> Stream (Of Utf8) IO () @@ -171,7 +171,7 @@ getPactTableNames db = S.each =<< liftIO (do \ type = 'table' \ \AND \ \ name NOT LIKE 'sqlite_%'" - Pact.qry db qryText [] [RText]) + throwOnDbError $ qry db qryText [] [RText]) -- | Get all of the rows for each table. The tables will be appear sorted -- lexicographically by table name. @@ -184,7 +184,7 @@ getPactTables db = do & S.mapM (\tbl -> do let qryText = "SELECT rowkey, rowdata, txid FROM " <> fmtTable tbl - userRows <- liftIO $ Pact.qry db qryText [] [RText, RBlob, RInt] + userRows <- throwOnDbError $ qry db qryText [] [RText, RBlob, RInt] shapedRows <- forM userRows $ \case [SText (Utf8 rowKey), SBlob rowData, SInt txId] -> do pure $ PactRow {..} @@ -227,16 +227,8 @@ qryStream :: () -> IO x qryStream db qryText args returnTypes k = do bracket (SQL.prepareUtf8 db qryText) Direct.finalize $ \stmt -> do - bindParams stmt args + throwOnDbError $ bindParams stmt args k (stepStatement stmt returnTypes) - where - bindParams :: Direct.Statement -> [SType] -> IO () - bindParams s as = forM_ (List.zip [1..] as) $ \(argIndex, arg) -> do - case arg of - SInt a -> Direct.bindInt64 s argIndex a - SDouble a -> Direct.bindDouble s argIndex a - SText a -> Direct.bindText s argIndex a - SBlob a -> Direct.bindBlob s argIndex a -- | Get the latest Pact state (in a ready-to-diff form). getLatestPactStateDiffable :: Database -> Stream (Of TableDiffable) IO () @@ -258,8 +250,8 @@ getEndingTxId :: () -> BlockHeight -> IO Int64 getEndingTxId db bh = do - r <- liftIO $ Pact.qry db - "SELECT endingtxid FROM BlockHistory WHERE blockheight=?" + r <- throwOnDbError $ qry db + "SELECT endingtxid FROM BlockHistory2 WHERE blockheight=?" [SInt (int bh)] [RInt] case r of @@ -296,7 +288,7 @@ getLatestPactTableNamesAt :: () getLatestPactTableNamesAt db bh = do tablesCreatedAfter <- liftIO $ do let qryText = "SELECT tablename FROM VersionedTableCreation WHERE createBlockheight > ?1" - rows <- Pact.qry db qryText [SInt (int bh)] [RText] + rows <- throwOnDbError $ qry db qryText [SInt (int bh)] [RText] forM rows $ \case [SText tbl] -> pure tbl _ -> error "getLatestPactStateAt.tablesCreatedAfter: expected text" @@ -404,23 +396,13 @@ data PactRowContents = PactRowContents -- contains the pact db for the given ChainId. doesPactDbExist :: ChainId -> FilePath -> IO Bool doesPactDbExist cid dbDir = do - doesFileExist (chainDbFileName cid dbDir) - --- | Given a pact database directory, return the SQLite --- path chainweb uses for the given ChainId. -chainDbFileName :: ChainId -> FilePath -> FilePath -chainDbFileName cid dbDir = dbDir mconcat - [ "pact-v1-chain-" - , Text.unpack (chainIdToText cid) - , ".sqlite" - ] - + doesFileExist (dbDir chainDbFileName cid) addChainIdLabel :: (Logger logger) => ChainId -> logger -> logger -addChainIdLabel cid = addLabel ("chainId", chainIdToText cid) +addChainIdLabel cid = addLabel ("chainId", toText cid) -allChains :: ChainwebVersion -> [ChainId] -allChains v = List.sort $ F.toList $ chainIdsAt v (BlockHeight maxBound) +allChains :: HasVersion => [ChainId] +allChains = List.sort $ F.toList $ chainIdsAt (BlockHeight maxBound) diff --git a/src/Chainweb/Pact/Backend/PactState/Diff.hs b/src/Chainweb/Pact/Backend/PactState/Diff.hs index 5dd52e29fc..a64e3a72b1 100644 --- a/src/Chainweb/Pact/Backend/PactState/Diff.hs +++ b/src/Chainweb/Pact/Backend/PactState/Diff.hs @@ -28,12 +28,13 @@ import Chainweb.BlockHeight (BlockHeight) import Chainweb.Logger (logFunctionText, logFunctionJson) import Chainweb.Pact.Backend.Compaction qualified as C import Chainweb.Pact.Backend.PactState (TableDiffable(..), getLatestPactStateAtDiffable, doesPactDbExist, withChainDb, allChains) -import Chainweb.Utils (fromText, toText) -import Chainweb.Version (ChainwebVersion(..), ChainId, chainIdToText) +import Chainweb.Utils (fromTextM, toText) +import Chainweb.Version (ChainwebVersion(..), withVersion, ChainId) import Chainweb.Version.Mainnet (mainnet) -import Chainweb.Version.Registry (lookupVersionByName) +import Chainweb.Version.Registry (findKnownVersion) import Control.Monad (forM_, when, void) import Control.Monad.IO.Class (MonadIO(liftIO)) +import Control.Monad.Trans.Resource (runResourceT) import Data.Aeson ((.=)) import Data.Aeson qualified as Aeson import Data.ByteString (ByteString) @@ -73,55 +74,57 @@ instance Monoid IsDifferent where main :: IO () main = do cfg <- execParser opts - - when (cfg.firstDbDir == cfg.secondDbDir) $ do - Text.putStrLn "Source and target Pact database directories cannot be the same." - exitFailure - - let cids = allChains cfg.chainwebVersion - - isDifferentRef <- newIORef @(Map ChainId IsDifferent) M.empty - - forM_ cids $ \cid -> do - C.withPerChainFileLogger cfg.logDir cid Info $ \logger -> do - let logText = logFunctionText logger - - sqliteFileExists1 <- doesPactDbExist cid cfg.firstDbDir - sqliteFileExists2 <- doesPactDbExist cid cfg.secondDbDir - - if | not sqliteFileExists1 -> do - logText Warn $ "[SQLite for chain in " <> Text.pack cfg.firstDbDir <> " doesn't exist. Skipping]" - | not sqliteFileExists2 -> do - logText Warn $ "[SQLite for chain in " <> Text.pack cfg.secondDbDir <> " doesn't exist. Skipping]" - | otherwise -> do - withChainDb cid logger cfg.firstDbDir $ \_ db1 -> do - withChainDb cid logger cfg.secondDbDir $ \_ db2 -> do - logText Info "[Starting diff]" - let getPactState db = getLatestPactStateAtDiffable db cfg.target - let diff :: Stream (Of (Text, Stream (Of RowKeyDiffExists) IO ())) IO () - diff = diffLatestPactState (getPactState db1) (getPactState db2) - isDifferent <- S.foldMap_ id $ flip S.mapM diff $ \(tblName, tblDiff) -> do - logText Info $ "[Starting table " <> tblName <> "]" - d <- S.foldMap_ id $ flip S.mapM tblDiff $ \d -> do - logFunctionJson logger Warn $ rowKeyDiffExistsToObject d - pure Difference - logText Info $ "[Finished table " <> tblName <> "]" - pure d - - logText Info $ case isDifferent of - Difference -> "[Non-empty diff]" - NoDifference -> "[Empty diff]" - logText Info $ "[Finished chain " <> chainIdToText cid <> "]" - - atomicModifyIORef' isDifferentRef $ \m -> (M.insert cid isDifferent m, ()) - - isDifferent <- readIORef isDifferentRef - case M.foldMapWithKey (\_ d -> d) isDifferent of - Difference -> do - Text.putStrLn "Diff complete. Differences found." + withVersion cfg.chainwebVersion $ do + when (cfg.firstDbDir == cfg.secondDbDir) $ do + Text.putStrLn "Source and target Pact database directories cannot be the same." exitFailure - NoDifference -> do - Text.putStrLn "Diff complete. No differences found." + + let cids = allChains + + isDifferentRef <- newIORef @(Map ChainId IsDifferent) M.empty + + forM_ cids $ \cid -> do + C.withPerChainFileLogger cfg.logDir cid Info $ \logger -> do + let logText = logFunctionText logger + + sqliteFileExists1 <- doesPactDbExist cid cfg.firstDbDir + sqliteFileExists2 <- doesPactDbExist cid cfg.secondDbDir + + if + | not sqliteFileExists1 -> do + logText Warn $ "[SQLite for chain in " <> Text.pack cfg.firstDbDir <> " doesn't exist. Skipping]" + | not sqliteFileExists2 -> do + logText Warn $ "[SQLite for chain in " <> Text.pack cfg.secondDbDir <> " doesn't exist. Skipping]" + | otherwise -> runResourceT $ do + db1 <- withChainDb cid logger cfg.firstDbDir + db2 <- withChainDb cid logger cfg.secondDbDir + liftIO $ do + logText Info "[Starting diff]" + let getPactState db = getLatestPactStateAtDiffable db cfg.target + let diff :: Stream (Of (Text, Stream (Of RowKeyDiffExists) IO ())) IO () + diff = diffLatestPactState (getPactState db1) (getPactState db2) + isDifferent <- S.foldMap_ id $ flip S.mapM diff $ \(tblName, tblDiff) -> do + logText Info $ "[Starting table " <> tblName <> "]" + d <- S.foldMap_ id $ flip S.mapM tblDiff $ \d -> do + logFunctionJson logger Warn $ rowKeyDiffExistsToObject d + pure Difference + logText Info $ "[Finished table " <> tblName <> "]" + pure d + + logText Info $ case isDifferent of + Difference -> "[Non-empty diff]" + NoDifference -> "[Empty diff]" + logText Info $ "[Finished chain " <> toText cid <> "]" + + atomicModifyIORef' isDifferentRef $ \m -> (M.insert cid isDifferent m, ()) + + isDifferent <- readIORef isDifferentRef + case M.foldMapWithKey (\_ d -> d) isDifferent of + Difference -> do + Text.putStrLn "Diff complete. Differences found." + exitFailure + NoDifference -> do + Text.putStrLn "Diff complete. No differences found." where opts :: ParserInfo PactDiffConfig opts = info (parser <**> helper) @@ -136,7 +139,7 @@ main = do <*> strOption (long "log-dir" <> help "Directory where logs will be placed" <> value ".") parseChainwebVersion :: Text -> ChainwebVersion - parseChainwebVersion = lookupVersionByName . fromMaybe (error "ChainwebVersion parse failed") . fromText + parseChainwebVersion = fromMaybe (error "ChainwebVersion parse failed") . (>>= findKnownVersion) . fromTextM -- | We don't include the entire rowdata in the diff, only the rowkey. -- This is just a space-saving measure. diff --git a/src/Chainweb/Pact/Backend/PactState/GrandHash/Calc.hs b/src/Chainweb/Pact/Backend/PactState/GrandHash/Calc.hs index f78163d741..3240e5a98e 100644 --- a/src/Chainweb/Pact/Backend/PactState/GrandHash/Calc.hs +++ b/src/Chainweb/Pact/Backend/PactState/GrandHash/Calc.hs @@ -24,7 +24,7 @@ module Chainweb.Pact.Backend.PactState.GrandHash.Calc where import Chainweb.BlockHeight (BlockHeight(..)) -import Chainweb.ChainId (ChainId, chainIdToText) +import Chainweb.ChainId (ChainId) import Chainweb.Logger (Logger, logFunctionText) import Chainweb.Pact.Backend.Compaction qualified as C import Chainweb.Pact.Backend.PactState (allChains) @@ -34,8 +34,8 @@ import Chainweb.Pact.Backend.PactState.GrandHash.Algorithm (ChainGrandHash(..)) import Chainweb.Pact.Backend.PactState.GrandHash.Utils (resolveLatestCutHeaders, resolveCutHeadersAtHeights, computeGrandHashesAt, withConnections, hex, rocksParser, cwvParser) import Chainweb.Pact.Backend.Types import Chainweb.Storage.Table.RocksDB (RocksDb, withReadOnlyRocksDb, modernDefaultOptions) -import Chainweb.Utils (sshow) -import Chainweb.Version (ChainwebVersion(..), ChainwebVersionName(..)) +import Chainweb.Utils (sshow, toText) +import Chainweb.Version (ChainwebVersion(..), HasVersion, ChainwebVersionName(..), withVersion) import Chainweb.Version.Development (devnet) import Chainweb.Version.Mainnet (mainnet) import Chainweb.Version.RecapDevelopment (recapDevnet) @@ -73,8 +73,8 @@ data BlockHeightTargets -- | Calculate the snapshots at each BlockHeight target. pactCalc :: (Logger logger) + => HasVersion => logger - -> ChainwebVersion -> HashMap ChainId SQLiteEnv -- ^ pact database dir -> RocksDb @@ -82,26 +82,26 @@ pactCalc :: (Logger logger) -> BlockHeightTargets -- ^ target for calculation -> IO [(BlockHeight, HashMap ChainId Snapshot)] -pactCalc logger v pactConns rocksDb targets = do +pactCalc logger pactConns rocksDb targets = do logFunctionText logger Debug "Starting pact-calc" chainTargets <- case targets of LatestAll -> do - List.singleton <$> resolveLatestCutHeaders logger v pactConns rocksDb + List.singleton <$> resolveLatestCutHeaders logger pactConns rocksDb TargetAll ts -> do - resolveCutHeadersAtHeights logger v pactConns rocksDb (Set.toDescList ts) + resolveCutHeadersAtHeights logger pactConns rocksDb (Set.toDescList ts) Every n -> do -- Get the latest cut headers - (latestBlockHeight, _cutHeaders) <- resolveLatestCutHeaders logger v pactConns rocksDb + (latestBlockHeight, _cutHeaders) <- resolveLatestCutHeaders logger pactConns rocksDb -- Then make sure we don't exceed them. It's okay if we attempt to access -- history that doesn't exist, the code is resilient to that, it will just -- emit warnings. let ts = List.sortOn Down $ List.takeWhile (< latestBlockHeight) $ List.map (* n) [0 .. ] -- Now it's just the same as the 'TargetAll' case. - resolveCutHeadersAtHeights logger v pactConns rocksDb ts + resolveCutHeadersAtHeights logger pactConns rocksDb ts pooledForConcurrently chainTargets $ \(b, cutHeader) -> do - fmap (b,) $ computeGrandHashesAt pactConns cutHeader + (b,) <$> computeGrandHashesAt pactConns cutHeader data PactCalcConfig = PactCalcConfig { pactDir :: FilePath @@ -120,46 +120,47 @@ data PactCalcConfig = PactCalcConfig pactCalcMain :: IO () pactCalcMain = do cfg <- O.execParser opts - C.withDefaultLogger Debug $ \logger -> do - withConnections logger cfg.pactDir (allChains cfg.chainwebVersion) $ \pactConns -> do - withReadOnlyRocksDb cfg.rocksDir modernDefaultOptions $ \rocksDb -> do - chainHashes <- pactCalc logger cfg.chainwebVersion pactConns rocksDb cfg.target - when cfg.writeModule $ do - when (cfg.chainwebVersion == mainnet) $ do - let snapshotToDiffable = Map.fromList . List.map (\(b, hm) -> (b, Map.fromList (HM.toList hm))) - let currentSnapshot = snapshotToDiffable MainnetSnapshot.grands - let newSnapshot = snapshotToDiffable chainHashes + withVersion cfg.chainwebVersion $ do + C.withDefaultLogger Debug $ \logger -> do + withConnections logger cfg.pactDir allChains $ \pactConns -> do + withReadOnlyRocksDb cfg.rocksDir modernDefaultOptions $ \rocksDb -> do + chainHashes <- pactCalc logger pactConns rocksDb cfg.target + when cfg.writeModule $ do + when (cfg.chainwebVersion == mainnet) $ do + let snapshotToDiffable = Map.fromList . List.map (\(b, hm) -> (b, Map.fromList (HM.toList hm))) + let currentSnapshot = snapshotToDiffable MainnetSnapshot.grands + let newSnapshot = snapshotToDiffable chainHashes - forM_ (Map.toList (P.diff currentSnapshot newSnapshot)) $ \(height, d) -> do - case d of - -- We only care about pre-existing blockheights with differences. - -- - -- - For 'Same', there is definitely no cause for concern. - -- - For 'Old', that probably means that we are just using a new offset (see 'Every'). - -- - For 'New', that means that we are adding a new BlockHeight(s). - -- - -- - But for 'Delta', we need to check if any of the hashes have - -- changed. If they have, that is very bad. - P.Delta cur new -> do - forM_ (Map.toList (P.diff cur new)) $ \(cid, sd) -> do - case sd of - -- Here, similarly, we only care about changed - -- pre-existing values. - P.Delta _ _ -> do - let msg = Text.concat - [ "Hash mismatch when attempting to regenerate snapshot: " - , "blockheight = ", sshow height, "; " - , "chainId = ", chainIdToText cid, "; " - ] - logFunctionText logger Error msg - _ -> do - pure () - _ -> do - pure () + forM_ (Map.toList (P.diff currentSnapshot newSnapshot)) $ \(height, d) -> do + case d of + -- We only care about pre-existing blockheights with differences. + -- + -- - For 'Same', there is definitely no cause for concern. + -- - For 'Old', that probably means that we are just using a new offset (see 'Every'). + -- - For 'New', that means that we are adding a new BlockHeight(s). + -- + -- - But for 'Delta', we need to check if any of the hashes have + -- changed. If they have, that is very bad. + P.Delta cur new -> do + forM_ (Map.toList (P.diff cur new)) $ \(cid, sd) -> do + case sd of + -- Here, similarly, we only care about changed + -- pre-existing values. + P.Delta _ _ -> do + let msg = Text.concat + [ "Hash mismatch when attempting to regenerate snapshot: " + , "blockheight = ", sshow height, "; " + , "chainId = ", toText cid, "; " + ] + logFunctionText logger Error msg + _ -> do + pure () + _ -> do + pure () - let modulePath = "src/Chainweb/Pact/Backend/PactState/EmbeddedSnapshot/" <> versionModuleName cfg.chainwebVersion <> ".hs" - writeFile modulePath (chainHashesToModule cfg.chainwebVersion chainHashes) - BLC8.putStrLn $ grandsToJson chainHashes + let modulePath = "src/Chainweb/Pact/Backend/PactState/EmbeddedSnapshot/" <> versionModuleName cfg.chainwebVersion <> ".hs" + writeFile modulePath (chainHashesToModule cfg.chainwebVersion chainHashes) + BLC8.putStrLn $ grandsToJson chainHashes where opts :: ParserInfo PactCalcConfig opts = O.info (parser <**> O.helper) (O.fullDesc <> O.progDesc helpText) @@ -214,7 +215,7 @@ grandsToJson chainHashes = [ "hash" J..= hex (getChainGrandHash hash) , "header" J..= J.encodeWithAeson header ] - in (chainIdToText cid, o) + in (toText cid, o) in (key J..= val) -- | Output a Haskell module with the embedded hashes. This module is produced @@ -286,7 +287,7 @@ chainHashesToModule v input = prefix let jsonDecode j = "unsafeDecodeBlockHeader " ++ j fromHex b = "unsafeBase16Decode " ++ b - sCid = Text.unpack (chainIdToText cid) + sCid = Text.unpack (toText cid) sHash = inQuotes $ Text.unpack (hex (getChainGrandHash hash)) sHeader = embedQuotes $ Text.unpack (J.encodeText (J.encodeWithAeson header)) in diff --git a/src/Chainweb/Pact/Backend/PactState/GrandHash/Import.hs b/src/Chainweb/Pact/Backend/PactState/GrandHash/Import.hs index dd6d81e23e..74ba98c209 100644 --- a/src/Chainweb/Pact/Backend/PactState/GrandHash/Import.hs +++ b/src/Chainweb/Pact/Backend/PactState/GrandHash/Import.hs @@ -52,9 +52,10 @@ module Chainweb.Pact.Backend.PactState.GrandHash.Import ) where -import Chainweb.BlockHeader (ParentHeader(..), blockHash) +import Control.Applicative (optional) +import Chainweb.BlockHeader (blockHash, rankedBlockHash) import Chainweb.BlockHeight (BlockHeight(..)) -import Chainweb.ChainId (ChainId, chainIdToText) +import Chainweb.ChainId (ChainId) import Chainweb.Logger (Logger, logFunctionText) import Chainweb.Pact.Backend.Compaction qualified as C import Chainweb.Pact.Backend.PactState (addChainIdLabel, allChains) @@ -62,11 +63,11 @@ import Chainweb.Pact.Backend.PactState.EmbeddedSnapshot (Snapshot(..)) import Chainweb.Pact.Backend.PactState.EmbeddedSnapshot.Mainnet qualified as MainnetSnapshots import Chainweb.Pact.Backend.PactState.GrandHash.Utils (resolveLatestCutHeaders, resolveCutHeadersAtHeight, computeGrandHashesAt, exitLog, withConnections, chainwebDbFilePath, rocksParser, cwvParser) import Chainweb.Pact.Backend.Types -import Chainweb.Pact.Types +import Chainweb.Pact.Backend.Utils qualified as PactDb +import Chainweb.Parent import Chainweb.Storage.Table.RocksDB (RocksDb, withReadOnlyRocksDb, modernDefaultOptions) -import Chainweb.Utils (sshow) -import Chainweb.Version (ChainwebVersion(..)) -import Control.Applicative (optional) +import Chainweb.Utils (sshow, HasTextRepresentation (toText)) +import Chainweb.Version (ChainwebVersion(..), HasVersion, withVersion) import Control.Lens ((^?!), ix, view) import Control.Monad (forM_, when) import Data.HashMap.Strict (HashMap) @@ -83,15 +84,15 @@ import Patience.Map qualified as P import System.Directory (copyFile, createDirectoryIfMissing) import System.Environment (setEnv) import System.LogLevel (LogLevel(..)) -import qualified Chainweb.Pact.PactService.Checkpointer.Internal as Checkpointer.Internal -- | Verifies that the hashes and headers match @grands@. -- -- Returns the latest (highest) blockheight along with the snapshot -- thereat. -pactVerify :: (Logger logger) +pactVerify + :: (Logger logger) + => HasVersion => logger - -> ChainwebVersion -> HashMap ChainId SQLiteEnv -- ^ pact connections -> RocksDb @@ -99,11 +100,11 @@ pactVerify :: (Logger logger) -> [(BlockHeight, HashMap ChainId Snapshot)] -- ^ grands -> IO (BlockHeight, HashMap ChainId Snapshot) -pactVerify logger v pactConns rocksDb grands = do +pactVerify logger pactConns rocksDb grands = do logFunctionText logger Debug "Starting pact-verify" -- Get the highest common blockheight across all chains. - latestBlockHeight <- fst <$> resolveLatestCutHeaders logger v pactConns rocksDb + latestBlockHeight <- fst <$> resolveLatestCutHeaders logger pactConns rocksDb snapshot@(snapshotBlockHeight, expectedChainHashes) <- do -- Find the first element of 'grands' such that @@ -116,7 +117,7 @@ pactVerify logger v pactConns rocksDb grands = do pure s chainHashes <- do - chainTargets <- resolveCutHeadersAtHeight logger v pactConns rocksDb snapshotBlockHeight + chainTargets <- resolveCutHeadersAtHeight logger pactConns rocksDb snapshotBlockHeight computeGrandHashesAt pactConns chainTargets let deltas = Map.filter (not . P.isSame) @@ -131,7 +132,7 @@ pactVerify logger v pactConns rocksDb grands = do P.Delta (Snapshot eHash eHeader) (Snapshot hash header) -> do when (header /= eHeader) $ do logFunctionText logger' Error $ Text.unlines - [ "Chain " <> chainIdToText cid + [ "Chain " <> toText cid , "Block Header mismatch" , " Expected: " <> sshow (view blockHash eHeader) , " Actual: " <> sshow (view blockHash header) @@ -139,7 +140,7 @@ pactVerify logger v pactConns rocksDb grands = do when (hash /= eHash) $ do logFunctionText logger' Error $ Text.unlines - [ "Chain " <> chainIdToText cid + [ "Chain " <> toText cid , "Grand Hash mismatch" , " Expected: " <> sshow eHash , " Actual: " <> sshow hash @@ -151,8 +152,8 @@ pactVerify logger v pactConns rocksDb grands = do pure snapshot pactDropPostVerified :: (Logger logger) + => HasVersion => logger - -> ChainwebVersion -> FilePath -- ^ source pact dir -> FilePath @@ -162,7 +163,7 @@ pactDropPostVerified :: (Logger logger) -> HashMap ChainId Snapshot -- ^ Grand Hashes & BlockHeaders at this blockheight -> IO () -pactDropPostVerified logger v srcDir tgtDir snapshotBlockHeight snapshotChainHashes = do +pactDropPostVerified logger srcDir tgtDir snapshotBlockHeight snapshotChainHashes = do logFunctionText logger Info $ "Creating " <> Text.pack tgtDir createDirectoryIfMissing True tgtDir @@ -186,8 +187,7 @@ pactDropPostVerified logger v srcDir tgtDir snapshotBlockHeight snapshotChainHas let logger' = addChainIdLabel cid logger logFunctionText logger' Info $ "Dropping anything post verified state (BlockHeight " <> sshow snapshotBlockHeight <> ")" - Checkpointer.Internal.withCheckpointerResources logger defaultModuleCacheLimit sqliteEnv DoNotPersistIntraBlockWrites v cid $ \cp -> do - Checkpointer.Internal.rewindTo cp (Just $ ParentHeader $ blockHeader $ snapshotChainHashes ^?! ix cid) + PactDb.rewindDbTo cid sqliteEnv $ Parent $ view rankedBlockHash $ blockHeader $ snapshotChainHashes ^?! ix cid data PactImportConfig = PactImportConfig { sourcePactDir :: FilePath @@ -200,22 +200,23 @@ pactImportMain :: IO () pactImportMain = do cfg <- O.execParser opts - let chains = allChains cfg.chainwebVersion + withVersion cfg.chainwebVersion $ do + let chains = allChains - C.withDefaultLogger Info $ \logger -> do - withConnections logger cfg.sourcePactDir chains $ \srcConns -> do - withReadOnlyRocksDb cfg.rocksDir modernDefaultOptions $ \rocksDb -> do - (snapshotBlockHeight, snapshotChainHashes) <- pactVerify logger cfg.chainwebVersion srcConns rocksDb MainnetSnapshots.grands + C.withDefaultLogger Info $ \logger -> do + withConnections logger cfg.sourcePactDir chains $ \srcConns -> do + withReadOnlyRocksDb cfg.rocksDir modernDefaultOptions $ \rocksDb -> do + (snapshotBlockHeight, snapshotChainHashes) <- pactVerify logger srcConns rocksDb MainnetSnapshots.grands - -- Set this before pactDropPostVerified, in case there's a failure, so - -- it's still recoverable. - -- - -- pact-import doesn't use this environment variable; it's for - -- debugging and/or consumption by other tools. - setEnv "SNAPSHOT_BLOCKHEIGHT" (show snapshotBlockHeight) + -- Set this before pactDropPostVerified, in case there's a failure, so + -- it's still recoverable. + -- + -- pact-import doesn't use this environment variable; it's for + -- debugging and/or consumption by other tools. + setEnv "SNAPSHOT_BLOCKHEIGHT" (show snapshotBlockHeight) - forM_ cfg.targetPactDir $ \targetDir -> do - pactDropPostVerified logger cfg.chainwebVersion cfg.sourcePactDir targetDir snapshotBlockHeight snapshotChainHashes + forM_ cfg.targetPactDir $ \targetDir -> do + pactDropPostVerified logger cfg.sourcePactDir targetDir snapshotBlockHeight snapshotChainHashes where opts :: ParserInfo PactImportConfig opts = O.info (parser <**> O.helper) (O.fullDesc <> O.progDesc helpText) diff --git a/src/Chainweb/Pact/Backend/PactState/GrandHash/Utils.hs b/src/Chainweb/Pact/Backend/PactState/GrandHash/Utils.hs index a0188d4f37..3d459082aa 100644 --- a/src/Chainweb/Pact/Backend/PactState/GrandHash/Utils.hs +++ b/src/Chainweb/Pact/Backend/PactState/GrandHash/Utils.hs @@ -27,8 +27,8 @@ module Chainweb.Pact.Backend.PactState.GrandHash.Utils import Chainweb.BlockHeader (BlockHeader, blockHeight) import Chainweb.BlockHeight (BlockHeight(..)) -import Chainweb.ChainId (ChainId, chainIdToText) -import Chainweb.CutDB (cutHashesTable, readHighestCutHeaders') +import Chainweb.ChainId (ChainId) +import Chainweb.CutDB (cutHashesTable, readHighestCutHeaders) import Chainweb.Logger (Logger, logFunctionText) import Chainweb.Pact.Backend.PactState (getLatestPactStateAt, getLatestBlockHeight, addChainIdLabel) import Chainweb.Pact.Backend.PactState.EmbeddedSnapshot (Snapshot(..)) @@ -37,10 +37,10 @@ import Chainweb.Pact.Backend.Types import Chainweb.Pact.Backend.Utils (startSqliteDb, stopSqliteDb) import Chainweb.Storage.Table.RocksDB (RocksDb) import Chainweb.TreeDB (seekAncestor) -import Chainweb.Utils (fromText, toText, sshow) -import Chainweb.Version (ChainwebVersion(..)) +import Chainweb.Utils (fromTextM, toText, sshow) +import Chainweb.Version (ChainwebVersion(..), HasVersion(..)) import Chainweb.Version.Mainnet (mainnet) -import Chainweb.Version.Registry (lookupVersionByName) +import Chainweb.Version.Registry import Chainweb.WebBlockHeaderDB (WebBlockHeaderDb, getWebBlockHeaderDb, initWebBlockHeaderDb) import Control.Exception (bracket) import Control.Lens ((^?!), ix, view) @@ -66,6 +66,7 @@ import UnliftIO.Async (pooledForConcurrently, pooledForConcurrently_) -- and calling 'seekAncestor' to find the 'BlockHeader's associated with the -- specified blockheight at each chain (this is the cut header). limitCut :: (Logger logger) + => HasVersion => logger -> WebBlockHeaderDb -> HashMap ChainId BlockHeader -- ^ latest cut headers @@ -101,13 +102,13 @@ limitCut logger wbhdb latestCutHeaders pactConns bHeight = do -- -- Also returns a 'WebBlockHeaderDb' for convenience to callers. getLatestCutHeaders :: () - => ChainwebVersion - -> RocksDb + => HasVersion + => RocksDb -> IO (WebBlockHeaderDb, HashMap ChainId BlockHeader) -getLatestCutHeaders v rocksDb = do - wbhdb <- initWebBlockHeaderDb rocksDb v +getLatestCutHeaders rocksDb = do + wbhdb <- initWebBlockHeaderDb rocksDb let cutHashes = cutHashesTable rocksDb - latestCutHeaders <- readHighestCutHeaders' v (\_ _ -> pure ()) wbhdb cutHashes + latestCutHeaders <- readHighestCutHeaders (\_ _ -> pure ()) wbhdb cutHashes pure (wbhdb, latestCutHeaders) -- | Take the latest cut headers, and find the minimum 'BlockHeight' across @@ -115,13 +116,13 @@ getLatestCutHeaders v rocksDb = do -- amongst all chains. Then return the cut headers associated with that -- latest common 'BlockHeight'. resolveLatestCutHeaders :: (Logger logger) + => HasVersion => logger - -> ChainwebVersion -> HashMap ChainId SQLiteEnv -> RocksDb -> IO (BlockHeight, HashMap ChainId BlockHeader) -resolveLatestCutHeaders logger v pactConns rocksDb = do - (wbhdb, latestCutHeaders) <- getLatestCutHeaders v rocksDb +resolveLatestCutHeaders logger pactConns rocksDb = do + (wbhdb, latestCutHeaders) <- getLatestCutHeaders rocksDb let latestCommonBlockHeight = minimum $ fmap (view blockHeight) latestCutHeaders headers <- limitCut logger wbhdb latestCutHeaders pactConns latestCommonBlockHeight pure (latestCommonBlockHeight, headers) @@ -129,14 +130,14 @@ resolveLatestCutHeaders logger v pactConns rocksDb = do -- | Take the latest cut headers, and return the cut headers associated with -- the specified 'BlockHeight'. resolveCutHeadersAtHeight :: (Logger logger) + => HasVersion => logger - -> ChainwebVersion -> HashMap ChainId SQLiteEnv -> RocksDb -> BlockHeight -> IO (HashMap ChainId BlockHeader) -resolveCutHeadersAtHeight logger v pactConns rocksDb target = do - (wbhdb, latestCutHeaders) <- getLatestCutHeaders v rocksDb +resolveCutHeadersAtHeight logger pactConns rocksDb target = do + (wbhdb, latestCutHeaders) <- getLatestCutHeaders rocksDb limitCut logger wbhdb latestCutHeaders pactConns target -- | Take the latest cut headers, and, for each specified 'BlockHeight', @@ -144,14 +145,14 @@ resolveCutHeadersAtHeight logger v pactConns rocksDb target = do -- -- The list returned pairs the input 'BlockHeight's with the found headers. resolveCutHeadersAtHeights :: (Logger logger) + => HasVersion => logger - -> ChainwebVersion -> HashMap ChainId SQLiteEnv -> RocksDb -> [BlockHeight] -- ^ targets -> IO [(BlockHeight, HashMap ChainId BlockHeader)] -resolveCutHeadersAtHeights logger v pactConns rocksDb targets = do - (wbhdb, latestCutHeaders) <- getLatestCutHeaders v rocksDb +resolveCutHeadersAtHeights logger pactConns rocksDb targets = do + (wbhdb, latestCutHeaders) <- getLatestCutHeaders rocksDb forM targets $ \target -> do fmap (target, ) $ limitCut logger wbhdb latestCutHeaders pactConns target @@ -175,13 +176,13 @@ checkPactDbsExist :: FilePath -> [ChainId] -> IO () checkPactDbsExist dbDir cids = pooledForConcurrently_ cids $ \cid -> do e <- doesFileExist (chainwebDbFilePath cid dbDir) when (not e) $ do - error $ "Pact database doesn't exist for expected chain id " <> Text.unpack (chainIdToText cid) + error $ "Pact database doesn't exist for expected chain id " <> Text.unpack (toText cid) chainwebDbFilePath :: ChainId -> FilePath -> FilePath chainwebDbFilePath cid dbDir = let fileName = mconcat [ "pact-v1-chain-" - , Text.unpack (chainIdToText cid) + , Text.unpack (toText cid) , ".sqlite" ] in dbDir fileName @@ -219,8 +220,8 @@ hex :: ByteString -> Text hex = Text.decodeUtf8 . Base16.encode cwvParser :: O.Parser ChainwebVersion -cwvParser = fmap (lookupVersionByName . fromMaybe (error "ChainwebVersion parse failed") . fromText) - $ O.strOption +cwvParser = fromMaybe (error "ChainwebVersion parse failed") . (>>= findKnownVersion) . fromTextM + <$> O.strOption (O.long "graph-version" <> O.short 'v' <> O.metavar "CHAINWEB_VERSION" diff --git a/src/Chainweb/Pact/Backend/Types.hs b/src/Chainweb/Pact/Backend/Types.hs index 82f31354d3..04b6838a0b 100644 --- a/src/Chainweb/Pact/Backend/Types.hs +++ b/src/Chainweb/Pact/Backend/Types.hs @@ -18,64 +18,81 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedRecordDot #-} {-# LANGUAGE TypeFamilyDependencies #-} module Chainweb.Pact.Backend.Types - ( Checkpointer(..) - , SQLiteEnv - , IntraBlockPersistence(..) + ( SQLiteEnv , BlockHandle(..) , blockHandleTxId , blockHandlePending - , emptyPact4BlockHandle - , emptyPact5BlockHandle , SQLitePendingData(..) + , emptyBlockHandle , emptySQLitePendingData , pendingWrites , pendingSuccessfulTxs , pendingTableCreation - , pendingTxLogMap , SQLiteRowDelta(..) , Historical(..) + , throwIfNoHistory , _Historical , _NoHistory - , PactDbFor - , PendingWrites + , ChainwebPactDb(..) + , HeaderOracle(..) ) where +import Control.Exception.Safe (MonadThrow) import Control.Lens -import Chainweb.Pact.Backend.DbCache import Chainweb.Version import Database.SQLite3.Direct (Database) -import Control.Concurrent.MVar import Data.ByteString (ByteString) import Data.Text (Text) -import Data.DList (DList) -import Data.Map (Map) import Data.HashSet (HashSet) -import Data.HashMap.Strict (HashMap) -import Data.List.NonEmpty (NonEmpty) import Control.DeepSeq (NFData) import GHC.Generics +import GHC.Stack + +import Chainweb.BlockHash +import Pact.Core.Command.Types hiding (ChainId) +import qualified Pact.Core.Persistence as Pact +import qualified Pact.Core.Builtin as Pact +import qualified Pact.Core.Evaluate as Pact +import Data.Vector (Vector) +import Data.HashMap.Strict (HashMap) +import qualified Pact.Core.SPV as Pact +import Chainweb.BlockHeight import qualified Chainweb.Pact.Backend.InMemDb as InMemDb +import Chainweb.Parent +import Chainweb.Utils +import Chainweb.BlockPayloadHash +import Control.Monad.State.Strict + +data HeaderOracle = HeaderOracle + -- this hash must always have a child + { consult :: !(Parent BlockHash -> IO Bool) + , chain :: !ChainId + } -import qualified Pact.Types.Persistence as Pact4 -import qualified Pact.Types.Names as Pact4 - --- | Whether we write rows to the database that were already overwritten --- in the same block. -data IntraBlockPersistence = PersistIntraBlockWrites | DoNotPersistIntraBlockWrites - deriving (Eq, Ord, Show) - -data Checkpointer logger - = Checkpointer - { cpLogger :: logger - , cpCwVersion :: ChainwebVersion - , cpChainId :: ChainId - , cpSql :: SQLiteEnv - , cpIntraBlockPersistence :: IntraBlockPersistence - , cpModuleCacheVar :: MVar (DbCache Pact4.PersistModuleData) +instance HasChainId HeaderOracle where + _chainId oracle = oracle.chain + +-- | The Pact database as it's provided by the checkpointer. +data ChainwebPactDb = ChainwebPactDb + { doChainwebPactDbTransaction + :: forall a + . Maybe RequestKey + -> (Pact.PactDb Pact.CoreBuiltin Pact.Info -> Pact.SPVSupport -> IO a) + -> StateT BlockHandle IO a + -- ^ Give this function a BlockHandle representing the state of a pending + -- block and it will pass you a PactDb which contains the Pact state as of + -- that point in the block. After you're done, it passes you back a + -- BlockHandle representing the state of the block extended with any writes + -- you made to the PactDb. + -- Note also that this function handles registering + -- transactions as completed, if you pass it a RequestKey. + , lookupPactTransactions :: Vector RequestKey -> IO (HashMap RequestKey (T3 BlockHeight BlockPayloadHash BlockHash)) + -- ^ Used to implement transaction polling. } type SQLiteEnv = Database @@ -87,7 +104,7 @@ type SQLiteEnv = Database -- data SQLiteRowDelta = SQLiteRowDelta { _deltaTableName :: !Text - , _deltaTxId :: {-# UNPACK #-} !Pact4.TxId + , _deltaTxId :: {-# UNPACK #-} !Pact.TxId , _deltaRowKey :: !ByteString , _deltaData :: !ByteString } deriving (Show, Generic, Eq) @@ -99,10 +116,6 @@ instance Ord SQLiteRowDelta where bb = (_deltaTableName b, _deltaRowKey b, _deltaTxId b) {-# INLINE compare #-} --- | A map from table name to a list of 'TxLog' entries. This is maintained in --- 'BlockState' and is cleared upon pact transaction commit. -type TxLogMap = Map Pact4.TableName (DList Pact4.TxLogJson) - -- | Between a @restore..save@ bracket, we also need to record which tables -- were created during this block (so the necessary @CREATE TABLE@ statements -- can be performed upon block save). @@ -111,55 +124,28 @@ type SQLitePendingTableCreations = HashSet Text -- | Pact transaction hashes resolved during this block. type SQLitePendingSuccessfulTxs = HashSet ByteString --- | Pending writes to the pact db during a block, to be recorded in 'BlockState'. --- Structured as a map from table name to a map from rowkey to inserted row delta. -type SQLitePendingWrites = HashMap Text (HashMap ByteString (NonEmpty SQLiteRowDelta)) - --- Note [TxLogs in SQLitePendingData] --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ --- We should really not store TxLogs in SQLitePendingData, --- because this data structure is specifically for things that --- can exist both for the whole block and for specific transactions, --- and txlogs only exist on the transaction level. --- We don't do this in Pact 5 at all. - -- | A collection of pending mutations to the pact db. We maintain two of -- these; one for the block as a whole, and one for any pending pact -- transaction. Upon pact transaction commit, the two 'SQLitePendingData' -- values are merged together. -data SQLitePendingData w = SQLitePendingData +data SQLitePendingData = SQLitePendingData { _pendingTableCreation :: !SQLitePendingTableCreations - , _pendingWrites :: !w - -- See Note [TxLogs in SQLitePendingData] - , _pendingTxLogMap :: !TxLogMap + , _pendingWrites :: !InMemDb.Store , _pendingSuccessfulTxs :: !SQLitePendingSuccessfulTxs } deriving (Eq, Show) -makeLenses ''SQLitePendingData - -type family PendingWrites (pv :: PactVersion) = w | w -> pv where - PendingWrites Pact4 = SQLitePendingWrites - PendingWrites Pact5 = InMemDb.Store +emptySQLitePendingData :: SQLitePendingData +emptySQLitePendingData = SQLitePendingData mempty InMemDb.empty mempty -emptySQLitePendingData :: w -> SQLitePendingData w -emptySQLitePendingData w = SQLitePendingData mempty w mempty mempty - -data BlockHandle (pv :: PactVersion) = BlockHandle - { _blockHandleTxId :: !Pact4.TxId - , _blockHandlePending :: !(SQLitePendingData (PendingWrites pv)) +data BlockHandle = BlockHandle + { _blockHandleTxId :: !Pact.TxId + , _blockHandlePending :: !SQLitePendingData } -deriving instance Eq (BlockHandle Pact4) -deriving instance Eq (BlockHandle Pact5) -deriving instance Show (BlockHandle Pact4) -deriving instance Show (BlockHandle Pact5) -makeLenses ''BlockHandle - -emptyPact4BlockHandle :: Pact4.TxId -> BlockHandle Pact4 -emptyPact4BlockHandle txid = BlockHandle txid (emptySQLitePendingData mempty) + deriving (Eq, Show) -emptyPact5BlockHandle :: Pact4.TxId -> BlockHandle Pact5 -emptyPact5BlockHandle txid = BlockHandle txid (emptySQLitePendingData InMemDb.empty) +emptyBlockHandle :: Pact.TxId -> BlockHandle +emptyBlockHandle txid = BlockHandle txid emptySQLitePendingData -- | The result of a historical lookup which might fail to even find the -- header the history is being queried for. @@ -169,6 +155,10 @@ data Historical a deriving stock (Eq, Foldable, Functor, Generic, Traversable, Show) deriving anyclass NFData -makePrisms ''Historical +throwIfNoHistory :: (HasCallStack, MonadThrow m) => Historical a -> m a +throwIfNoHistory NoHistory = error "missing history" +throwIfNoHistory (Historical a) = return a -type family PactDbFor logger (pv :: PactVersion) +makePrisms ''Historical +makeLenses ''BlockHandle +makeLenses ''SQLitePendingData diff --git a/src/Chainweb/Pact/Backend/Utils.hs b/src/Chainweb/Pact/Backend/Utils.hs index 16f0c214f5..5c0231d65b 100644 --- a/src/Chainweb/Pact/Backend/Utils.hs +++ b/src/Chainweb/Pact/Backend/Utils.hs @@ -7,6 +7,7 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE GADTs #-} +{-# LANGUAGE BlockArguments #-} {-# OPTIONS_GHC -fno-warn-orphans #-} @@ -14,6 +15,8 @@ {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE DataKinds #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE ImportQualifiedPost #-} -- | -- Module: Chainweb.Pact.ChainwebPactDb @@ -35,46 +38,59 @@ module Chainweb.Pact.Backend.Utils , rewindDbToBlock , rewindDbToGenesis , getEndTxId - , getEndTxId' - -- * Savepoints - , withSavepoint - , beginSavepoint - , commitSavepoint - , rollbackSavepoint - , abortSavepoint - , SavepointName(..) + -- * Transactions + , withTransaction + , setConsensusState + , getConsensusState + , getPayloadsAfter + , getLatestBlock + , getEarliestBlock + , lookupBlockWithHeight + , lookupBlockHash + , lookupRankedBlockHash -- * SQLite conversions and assertions , toUtf8 , fromUtf8 , asStringUtf8 - , convSavepointName - , expectSingleRowCol - , expectSingle -- * SQLite runners , withSqliteDb + , withReadSqlitePool , startSqliteDb , stopSqliteDb , withSQLiteConnection , openSQLiteConnection , closeSQLiteConnection - , withTempSQLiteConnection - , withInMemSQLiteConnection - -- * SQLite Pragmas + -- * SQLite , chainwebPragmas + , LocatedSQ3Error(..) + , execMulti + , exec + , exec' + , exec_ + , Pragma(..) + , runPragmas + , qry + , qry_ + , bindParams + , SType(..) + , RType(..) + , throwOnDbError + , locateSQ3Error ) where -import Control.Exception (SomeAsyncException, evaluate) -import Control.Lens +import Control.Exception.Safe import Control.Monad -import Control.Monad.Catch import Control.Monad.State.Strict +import Control.Monad.Trans.Resource (ResourceT, allocate) import Data.Bits import Data.Foldable +import Data.Maybe import Data.String -import qualified Data.Text as T -import qualified Data.Text.Encoding as T -import qualified Database.SQLite3.Direct as SQ3 +import Data.Pool qualified as Pool +import Data.Text qualified as T +import Data.Text.Encoding qualified as T +import Database.SQLite3.Direct qualified as SQ3 import Prelude hiding (log) @@ -84,7 +100,6 @@ import System.LogLevel -- pact -import qualified Pact.Types.Persistence as Pact4 import qualified Pact.Types.SQLite as Pact4 import Pact.Types.Util (AsString(..)) @@ -93,14 +108,15 @@ import Pact.Types.Util (AsString(..)) import Chainweb.Logger import Chainweb.Pact.Backend.SQLite.DirectV2 +import Chainweb.PayloadProvider -import Chainweb.Pact.Types import Chainweb.Version import Chainweb.Utils import Chainweb.BlockHash +import Chainweb.BlockHeader import Chainweb.BlockHeight import Database.SQLite3.Direct hiding (open2) -import GHC.Stack (HasCallStack) +import GHC.Stack import qualified Data.ByteString.Short as SB import qualified Data.Vector as V import qualified Data.HashMap.Strict as HashMap @@ -109,9 +125,17 @@ import qualified Data.ByteString.Char8 as B8 import qualified Data.ByteString as BS import Chainweb.Pact.Backend.Types import Data.HashSet (HashSet) -import Chainweb.BlockHeader import qualified Data.HashSet as HashSet import Data.Text (Text) +import qualified Pact.Core.Persistence as Pact +import Control.Monad.Catch (ExitCase(..)) +import Control.Monad.Except +import Data.Int +import Control.Lens +import qualified Pact.JSON.Encode as J +import Data.Aeson (FromJSON) +import Chainweb.Ranked +import Chainweb.Parent -- -------------------------------------------------------------------------- -- -- SQ3.Utf8 Encodings @@ -132,92 +156,29 @@ asStringUtf8 = toUtf8 . asString -- -------------------------------------------------------------------------- -- -- -withSavepoint - :: SQLiteEnv - -> SavepointName - -> IO a - -> IO a -withSavepoint db name action = mask $ \resetMask -> do - beginSavepoint db name - go resetMask `catches` handlers - where - go resetMask = do - r <- resetMask action `onException` abortSavepoint db name - liftIO $ commitSavepoint db name - liftIO $ evaluate r - throwErr s = internalError $ "withSavepoint (" <> toText name <> "): " <> s - handlers = [ Handler $ \(e :: PactException) -> throwErr (sshow e) - , Handler $ \(e :: SomeAsyncException) -> throwM e - , Handler $ \(e :: SomeException) -> throwErr ("non-pact exception: " <> sshow e) - ] - -beginSavepoint :: SQLiteEnv -> SavepointName -> IO () -beginSavepoint db name = - Pact4.exec_ db $ "SAVEPOINT [" <> convSavepointName name <> "];" - -commitSavepoint :: SQLiteEnv -> SavepointName -> IO () -commitSavepoint db name = - Pact4.exec_ db $ "RELEASE SAVEPOINT [" <> convSavepointName name <> "];" - -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. for details about --- savepoints. --- -rollbackSavepoint :: SQLiteEnv -> SavepointName -> IO () -rollbackSavepoint db name = - Pact4.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 :: SQLiteEnv -> SavepointName -> IO () -abortSavepoint db name = do - rollbackSavepoint db name - commitSavepoint db name - -data SavepointName = BatchSavepoint | DbTransaction | PreBlock - deriving (Eq, Ord, Enum, Bounded) - -instance Show SavepointName where - show = T.unpack . toText - -instance HasTextRepresentation SavepointName where - toText BatchSavepoint = "batch" - toText DbTransaction = "db-transaction" - toText PreBlock = "preblock" - {-# INLINE toText #-} - - fromText "batch" = pure BatchSavepoint - fromText "db-transaction" = pure DbTransaction - fromText "preblock" = pure PreBlock - fromText t = throwM $ TextFormatException - $ "failed to decode SavepointName " <> t - <> ". Valid names are " <> T.intercalate ", " (toText @SavepointName <$> [minBound .. maxBound]) - {-# INLINE fromText #-} - -expectSingleRowCol :: Show a => String -> [[a]] -> IO a -expectSingleRowCol _ [[s]] = return s -expectSingleRowCol s v = - internalError $ - "expectSingleRowCol: " - <> asString s <> - " expected single row and column result, got: " - <> asString (show v) - -expectSingle :: Show a => String -> [a] -> IO a -expectSingle _ [s] = return s -expectSingle desc v = - internalError $ - "Expected single-" <> asString (show desc) <> " result, got: " <> - asString (show v) +withTransaction + :: (HasCallStack, MonadMask m, MonadIO m) + => SQLiteEnv + -> m a + -> m a +withTransaction db action = fmap fst $ generalBracket + (liftIO $ beginTransaction db) + (\_ -> liftIO . \case + ExitCaseSuccess {} -> commitTransaction db + _ -> rollbackTransaction db + ) $ \_ -> action + +beginTransaction :: HasCallStack => SQLiteEnv -> IO () +beginTransaction db = + throwOnDbError $ exec_ db $ "BEGIN TRANSACTION;" + +commitTransaction :: HasCallStack => SQLiteEnv -> IO () +commitTransaction db = + throwOnDbError $ exec_ db $ "COMMIT TRANSACTION;" + +rollbackTransaction :: HasCallStack => SQLiteEnv -> IO () +rollbackTransaction db = + throwOnDbError $ exec_ db $ "ROLLBACK TRANSACTION;" chainwebPragmas :: [Pact4.Pragma] chainwebPragmas = @@ -243,12 +204,21 @@ withSqliteDb -> logger -> FilePath -> Bool - -> (SQLiteEnv -> IO a) - -> IO a -withSqliteDb cid logger dbDir resetDb = bracket + -> ResourceT IO SQLiteEnv +withSqliteDb cid logger dbDir resetDb = snd <$> allocate (startSqliteDb cid logger dbDir resetDb) stopSqliteDb +withReadSqlitePool :: ChainId -> FilePath -> ResourceT IO (Pool.Pool SQLiteEnv) +withReadSqlitePool cid pactDbDir = snd <$> allocate + (Pool.newPool $ Pool.defaultPoolConfig + (openSQLiteConnection (pactDbDir chainDbFileName cid) [sqlite_open_readonly, sqlite_open_fullmutex] chainwebPragmas) + stopSqliteDb + 30 -- seconds to keep them around unused + 2 -- connections at most + & Pool.setNumStripes (Just 2) -- two stripes, one connection per stripe + ) (Pool.destroyAllResources) + startSqliteDb :: Logger logger => ChainId @@ -260,7 +230,7 @@ startSqliteDb cid logger dbDir doResetDb = do when doResetDb resetDb createDirectoryIfMissing True dbDir logFunctionText logger Debug $ "opening sqlitedb named " <> T.pack sqliteFile - openSQLiteConnection sqliteFile chainwebPragmas + openSQLiteConnection sqliteFile [sqlite_open_readwrite , sqlite_open_create , sqlite_open_fullmutex] chainwebPragmas where resetDb = removeDirectoryRecursive dbDir sqliteFile = dbDir chainDbFileName cid @@ -268,23 +238,23 @@ startSqliteDb cid logger dbDir doResetDb = do chainDbFileName :: ChainId -> FilePath chainDbFileName cid = fold [ "pact-v1-chain-" - , T.unpack (chainIdToText cid) + , T.unpack (toText cid) , ".sqlite" ] stopSqliteDb :: SQLiteEnv -> IO () stopSqliteDb = closeSQLiteConnection -withSQLiteConnection :: String -> [Pact4.Pragma] -> (SQLiteEnv -> IO c) -> IO c +withSQLiteConnection :: String -> [Pact4.Pragma] -> ResourceT IO SQLiteEnv withSQLiteConnection file ps = - bracket (openSQLiteConnection file ps) closeSQLiteConnection + snd <$> allocate (openSQLiteConnection file [sqlite_open_readwrite , sqlite_open_create , sqlite_open_fullmutex] ps) closeSQLiteConnection -openSQLiteConnection :: String -> [Pact4.Pragma] -> IO SQLiteEnv -openSQLiteConnection file ps = open2 file >>= \case +openSQLiteConnection :: String -> [SQLiteFlag] -> [Pact4.Pragma] -> IO SQLiteEnv +openSQLiteConnection file flags ps = open2 file flags >>= \case Left (err, msg) -> - internalError $ + error $ "withSQLiteConnection: Can't open db with " - <> asString (show err) <> ": " <> asString (show msg) + <> show err <> ": " <> show msg Right r -> do Pact4.runPragmas r ps return r @@ -292,27 +262,10 @@ openSQLiteConnection file ps = open2 file >>= \case closeSQLiteConnection :: SQLiteEnv -> IO () closeSQLiteConnection c = void $ close_v2 c --- passing the empty string as filename causes sqlite to use a temporary file --- that is deleted when the connection is closed. In practice, unless the database becomes --- very large, the database will reside memory and no data will be written to disk. --- --- Cf. https://www.sqlite.org/inmemorydb.html --- -withTempSQLiteConnection :: [Pact4.Pragma] -> (SQLiteEnv -> IO c) -> IO c -withTempSQLiteConnection = withSQLiteConnection "" - --- Using the special file name @:memory:@ causes sqlite to create a temporary in-memory --- database. --- --- Cf. https://www.sqlite.org/inmemorydb.html --- -withInMemSQLiteConnection :: [Pact4.Pragma] -> (SQLiteEnv -> IO c) -> IO c -withInMemSQLiteConnection = withSQLiteConnection ":memory:" - -open2 :: String -> IO (Either (SQ3.Error, SQ3.Utf8) SQ3.Database) -open2 file = open_v2 +open2 :: String -> [SQLiteFlag] -> IO (Either (SQ3.Error, SQ3.Utf8) SQ3.Database) +open2 file flags = open_v2 (fromString file) - (collapseFlags [sqlite_open_readwrite , sqlite_open_create , sqlite_open_fullmutex]) + (collapseFlags flags) Nothing -- Nothing corresponds to the nullPtr collapseFlags :: [SQLiteFlag] -> SQLiteFlag @@ -320,179 +273,395 @@ collapseFlags xs = if Prelude.null xs then error "collapseFlags: You must pass a non-empty list" else Prelude.foldr1 (.|.) xs -sqlite_open_readwrite, sqlite_open_create, sqlite_open_fullmutex :: SQLiteFlag +sqlite_open_readwrite, sqlite_open_readonly, sqlite_open_create, sqlite_open_fullmutex :: SQLiteFlag +sqlite_open_readonly = 0x00000001 sqlite_open_readwrite = 0x00000002 sqlite_open_create = 0x00000004 sqlite_open_fullmutex = 0x00010000 tbl :: HasCallStack => Utf8 -> Utf8 tbl t@(Utf8 b) - | B8.elem ']' b = error $ "Chainweb.Pact4.Backend.ChainwebPactDb: Code invariant violation. Illegal SQL table name " <> sshow b <> ". Please report this as a bug." + | B8.elem ']' b = error $ "Chainweb.Pact.Backend.ChainwebPactDb: Code invariant violation. Illegal SQL table name " <> sshow b <> ". Please report this as a bug." | otherwise = "[" <> t <> "]" -doLookupSuccessful :: Database -> BlockHeight -> V.Vector SB.ShortByteString -> IO (HashMap.HashMap SB.ShortByteString (T2 BlockHeight BlockHash)) -doLookupSuccessful db curHeight hashes = do +doLookupSuccessful :: Database -> BlockHeight -> V.Vector SB.ShortByteString -> IO (HashMap.HashMap SB.ShortByteString (T3 BlockHeight BlockPayloadHash BlockHash)) +doLookupSuccessful db curHeight hashes = throwOnDbError $ do fmap buildResultMap $ do -- swizzle results of query into a HashMap let hss = V.toList hashes params = BS.intercalate "," (map (const "?") hss) qtext = Utf8 $ BS.intercalate " " - [ "SELECT blockheight, hash, txhash" + [ "SELECT blockheight, payloadhash, hash, txhash" , "FROM TransactionIndex" - , "INNER JOIN BlockHistory USING (blockheight)" + , "INNER JOIN BlockHistory2 USING (blockheight)" , "WHERE txhash IN (" <> params <> ")" <> " AND blockheight < ?;" ] qvals -- match query params above. first, hashes - = map (\h -> Pact4.SBlob $ SB.fromShort h) hss + = map (\h -> SBlob $ SB.fromShort h) hss -- then, the block height; we don't want to see txs from the -- current block in the db, because they'd show up in pending data - ++ [Pact4.SInt $ fromIntegral curHeight] + ++ [SInt $ fromIntegral curHeight] - Pact4.qry db qtext qvals [Pact4.RInt, Pact4.RBlob, Pact4.RBlob] >>= mapM go + qry db qtext qvals [RInt, RBlob, RBlob, RBlob] >>= mapM go where -- NOTE: it's useful to keep the types of 'go' and 'buildResultMap' in sync -- for readability but also to ensure the compiler and reader infer the -- right result types from the db query. - buildResultMap :: [T3 SB.ShortByteString BlockHeight BlockHash] -> HashMap.HashMap SB.ShortByteString (T2 BlockHeight BlockHash) + buildResultMap :: [T4 SB.ShortByteString BlockHeight BlockPayloadHash BlockHash] -> HashMap.HashMap SB.ShortByteString (T3 BlockHeight BlockPayloadHash BlockHash) buildResultMap xs = HashMap.fromList $ - map (\(T3 txhash blockheight blockhash) -> (txhash, T2 blockheight blockhash)) xs + map (\(T4 txhash blockheight payloadhash blockhash) -> (txhash, T3 blockheight payloadhash blockhash)) xs - go :: [Pact4.SType] -> IO (T3 SB.ShortByteString BlockHeight BlockHash) - go (Pact4.SInt blockheight:Pact4.SBlob blockhash:Pact4.SBlob txhash:_) = do + go :: [SType] -> ExceptT LocatedSQ3Error IO (T4 SB.ShortByteString BlockHeight BlockPayloadHash BlockHash) + go (SInt blockheight:SBlob payloadhash:SBlob blockhash:SBlob txhash:_) = do !blockhash' <- either fail return $ runGetEitherS decodeBlockHash blockhash + !payloadhash' <- either fail return $ runGetEitherS decodeBlockPayloadHash payloadhash let !txhash' = SB.toShort txhash - return $! T3 txhash' (fromIntegral blockheight) blockhash' + return $! T4 txhash' (fromIntegral blockheight) payloadhash' blockhash' go _ = fail "impossible" -getEndTxId :: Text -> SQLiteEnv -> Maybe ParentHeader -> IO (Historical Pact4.TxId) -getEndTxId msg sql pc = case pc of - Nothing -> return (Historical 0) - Just (ParentHeader ph) -> getEndTxId' msg sql (view blockHeight ph) (view blockHash ph) - -getEndTxId' :: Text -> SQLiteEnv -> BlockHeight -> BlockHash -> IO (Historical Pact4.TxId) -getEndTxId' msg sql bh bhsh = do - r <- Pact4.qry sql - "SELECT endingtxid FROM BlockHistory WHERE blockheight = ? and hash = ?;" - [ Pact4.SInt $ fromIntegral bh - , Pact4.SBlob $ runPutS (encodeBlockHash bhsh) +getEndTxId :: (HasVersion, HasCallStack) => ChainId -> SQLiteEnv -> Parent RankedBlockHash -> IO (Historical Pact.TxId) +getEndTxId cid sql pc + | isGenesisBlockHeader' cid (_rankedBlockHashHash <$> pc) = + return (Historical (Pact.TxId 0)) + | otherwise = + getEndTxId' sql pc + +getEndTxId' :: HasCallStack => SQLiteEnv -> Parent RankedBlockHash -> IO (Historical Pact.TxId) +getEndTxId' sql (Parent rbh) = throwOnDbError $ do + r <- qry sql + "SELECT endingtxid FROM BlockHistory2 WHERE blockheight = ? and hash = ?;" + [ SInt $ fromIntegral $ _rankedBlockHashHeight rbh + , SBlob $ runPutS (encodeBlockHash $ _rankedBlockHashHash rbh) ] - [Pact4.RInt] + [RInt] case r of - [[Pact4.SInt tid]] -> return $ Historical (Pact4.TxId (fromIntegral tid)) + [[SInt tid]] -> return $ Historical (Pact.TxId (fromIntegral tid)) [] -> return NoHistory - _ -> internalError $ msg <> ".getEndTxId: expected single-row int result, got " <> sshow r - + _ -> error $ "getEndTxId: expected single-row int result, got " <> sshow r -- | Delete any state from the database newer than the input parent header. -- Returns the ending txid of the input parent header. rewindDbTo - :: SQLiteEnv - -> Maybe ParentHeader - -> IO Pact4.TxId -rewindDbTo db Nothing = do - rewindDbToGenesis db - return 0 -rewindDbTo db mh@(Just (ParentHeader ph)) = do - !historicalEndingTxId <- getEndTxId "rewindDbToBlock" db mh + :: HasCallStack + => HasVersion + => ChainId + -> SQLiteEnv + -> Parent RankedBlockHash + -> IO Pact.TxId +rewindDbTo cid db pc + | isGenesisBlockHeader' cid (_rankedBlockHashHash <$> pc) = do + rewindDbToGenesis db + return (Pact.TxId 0) + | otherwise = do + !historicalEndingTxId <- getEndTxId cid db pc endingTxId <- case historicalEndingTxId of NoHistory -> - throwM - $ BlockHeaderLookupFailure + error $ "rewindDbTo.getEndTxId: not in db: " - <> sshow ph + <> sshow pc Historical endingTxId -> return endingTxId - rewindDbToBlock db (view blockHeight ph) endingTxId + rewindDbToBlock db (rank (pc ^. _Parent)) endingTxId return endingTxId -- rewind before genesis, delete all user tables and all rows in all tables rewindDbToGenesis - :: SQLiteEnv + :: HasCallStack + => SQLiteEnv -> IO () -rewindDbToGenesis db = do - Pact4.exec_ db "DELETE FROM BlockHistory;" - Pact4.exec_ db "DELETE FROM [SYS:KeySets];" - Pact4.exec_ db "DELETE FROM [SYS:Modules];" - Pact4.exec_ db "DELETE FROM [SYS:Namespaces];" - Pact4.exec_ db "DELETE FROM [SYS:Pacts];" - Pact4.exec_ db "DELETE FROM [SYS:ModuleSources];" - tblNames <- Pact4.qry_ db "SELECT tablename FROM VersionedTableCreation;" [Pact4.RText] +rewindDbToGenesis db = throwOnDbError $ do + exec_ db "DELETE FROM BlockHistory2;" + exec_ db "DELETE FROM [SYS:KeySets];" + exec_ db "DELETE FROM [SYS:Modules];" + exec_ db "DELETE FROM [SYS:Namespaces];" + exec_ db "DELETE FROM [SYS:Pacts];" + exec_ db "DELETE FROM [SYS:ModuleSources];" + tblNames <- liftIO $ Pact4.qry_ db "SELECT tablename FROM VersionedTableCreation;" [Pact4.RText] forM_ tblNames $ \t -> case t of - [Pact4.SText tn] -> Pact4.exec_ db ("DROP TABLE [" <> tn <> "];") - _ -> internalError "Something went wrong when resetting tables." - Pact4.exec_ db "DELETE FROM VersionedTableCreation;" - Pact4.exec_ db "DELETE FROM VersionedTableMutation;" - Pact4.exec_ db "DELETE FROM TransactionIndex;" + [Pact4.SText tn] -> exec_ db ("DROP TABLE [" <> tn <> "];") + _ -> error "Something went wrong when resetting tables." + exec_ db "DELETE FROM VersionedTableCreation;" + exec_ db "DELETE FROM VersionedTableMutation;" + exec_ db "DELETE FROM TransactionIndex;" -- | Rewind the database to a particular block, given the end tx id of that -- block. rewindDbToBlock :: Database -> BlockHeight - -> Pact4.TxId + -> Pact.TxId -> IO () -rewindDbToBlock db bh endingTxId = do +rewindDbToBlock db bh endingTxId = throwOnDbError $ do tableMaintenanceRowsVersionedSystemTables droppedtbls <- dropTablesAtRewind vacuumTablesAtRewind droppedtbls deleteHistory clearTxIndex where - dropTablesAtRewind :: IO (HashSet BS.ByteString) + dropTablesAtRewind :: ExceptT LocatedSQ3Error IO (HashSet BS.ByteString) dropTablesAtRewind = do - toDropTblNames <- Pact4.qry db findTablesToDropStmt - [Pact4.SInt (fromIntegral bh)] [Pact4.RText] + toDropTblNames <- qry db findTablesToDropStmt + [SInt (fromIntegral bh)] [RText] tbls <- fmap HashSet.fromList . forM toDropTblNames $ \case - [Pact4.SText tblname@(Utf8 tn)] -> do - Pact4.exec_ db $ "DROP TABLE IF EXISTS " <> tbl tblname + [SText tblname@(Utf8 tn)] -> do + exec_ db $ "DROP TABLE IF EXISTS " <> tbl tblname return tn - _ -> internalError rewindmsg - Pact4.exec' db + _ -> error rewindmsg + exec' db "DELETE FROM VersionedTableCreation WHERE createBlockheight > ?" - [Pact4.SInt (fromIntegral bh)] + [SInt (fromIntegral bh)] return tbls findTablesToDropStmt = "SELECT tablename FROM VersionedTableCreation WHERE createBlockheight > ?;" rewindmsg = "rewindBlock: dropTablesAtRewind: Couldn't resolve the name of the table to drop." - deleteHistory :: IO () + deleteHistory :: ExceptT LocatedSQ3Error IO () deleteHistory = - Pact4.exec' db "DELETE FROM BlockHistory WHERE blockheight > ?" - [Pact4.SInt (fromIntegral bh)] + exec' db "DELETE FROM BlockHistory2 WHERE blockheight > ?" + [SInt (fromIntegral bh)] - vacuumTablesAtRewind :: HashSet BS.ByteString -> IO () + vacuumTablesAtRewind :: HashSet BS.ByteString -> ExceptT LocatedSQ3Error IO () vacuumTablesAtRewind droppedtbls = do let processMutatedTables ms = fmap HashSet.fromList . forM ms $ \case - [Pact4.SText (Utf8 tn)] -> return tn - _ -> internalError "rewindBlock: vacuumTablesAtRewind: Couldn't resolve the name \ - \of the table to possibly vacuum." - mutatedTables <- Pact4.qry db + [SText (Utf8 tn)] -> return tn + _ -> error + "rewindBlock: vacuumTablesAtRewind: Couldn't resolve the name \ + \of the table to possibly vacuum." + mutatedTables <- qry db "SELECT DISTINCT tablename FROM VersionedTableMutation WHERE blockheight > ?;" - [Pact4.SInt (fromIntegral bh)] - [Pact4.RText] + [SInt (fromIntegral bh)] + [RText] >>= processMutatedTables let toVacuumTblNames = HashSet.difference mutatedTables droppedtbls forM_ toVacuumTblNames $ \tblname -> - Pact4.exec' db ("DELETE FROM " <> tbl (Utf8 tblname) <> " WHERE txid >= ?") - [Pact4.SInt $! fromIntegral endingTxId] - Pact4.exec' db "DELETE FROM VersionedTableMutation WHERE blockheight > ?;" - [Pact4.SInt (fromIntegral bh)] + exec' db ("DELETE FROM " <> tbl (Utf8 tblname) <> " WHERE txid >= ?") + [SInt $! fromIntegral $ Pact._txId endingTxId] + exec' db "DELETE FROM VersionedTableMutation WHERE blockheight > ?;" + [SInt (fromIntegral bh)] - tableMaintenanceRowsVersionedSystemTables :: IO () + tableMaintenanceRowsVersionedSystemTables :: ExceptT LocatedSQ3Error IO () tableMaintenanceRowsVersionedSystemTables = do - Pact4.exec' db "DELETE FROM [SYS:KeySets] WHERE txid >= ?" tx - Pact4.exec' db "DELETE FROM [SYS:Modules] WHERE txid >= ?" tx - Pact4.exec' db "DELETE FROM [SYS:Namespaces] WHERE txid >= ?" tx - Pact4.exec' db "DELETE FROM [SYS:Pacts] WHERE txid >= ?" tx - Pact4.exec' db "DELETE FROM [SYS:ModuleSources] WHERE txid >= ?" tx + exec' db "DELETE FROM [SYS:KeySets] WHERE txid >= ?" tx + exec' db "DELETE FROM [SYS:Modules] WHERE txid >= ?" tx + exec' db "DELETE FROM [SYS:Namespaces] WHERE txid >= ?" tx + exec' db "DELETE FROM [SYS:Pacts] WHERE txid >= ?" tx + exec' db "DELETE FROM [SYS:ModuleSources] WHERE txid >= ?" tx where - tx = [Pact4.SInt $! fromIntegral endingTxId] + tx = [SInt $! fromIntegral $ Pact._txId endingTxId] -- | Delete all future transactions from the index - clearTxIndex :: IO () + clearTxIndex :: ExceptT LocatedSQ3Error IO () clearTxIndex = - Pact4.exec' db "DELETE FROM TransactionIndex WHERE blockheight > ?;" - [ Pact4.SInt (fromIntegral bh) ] + exec' db "DELETE FROM TransactionIndex WHERE blockheight > ?;" + [ SInt (fromIntegral bh) ] + +-- | Set the consensus state. Note that the "latest" parameter is ignored; the +-- latest block is always the highest block in the BlockHistory table. +setConsensusState :: SQ3.Database -> ConsensusState -> ExceptT LocatedSQ3Error IO () +setConsensusState db cs = 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) + where + toRow safety SyncState {..} = + [ SInt $ fromIntegral @BlockHeight @Int64 _syncStateHeight + , SBlob $ runPutS (encodeBlockHash _syncStateBlockHash) + , SBlob $ runPutS (encodeBlockPayloadHash _syncStateBlockPayloadHash) + , SText safety + ] + +-- | Retrieve the latest "consensus state" including latest, safe, and final blocks. +getConsensusState :: SQ3.Database -> ExceptT LocatedSQ3Error IO ConsensusState +getConsensusState db = do + latestBlock <- fromMaybe (error "before genesis") <$> getLatestBlock db + qry db "SELECT blockheight, hash, payloadhash, safety FROM ConsensusState ORDER BY safety ASC;" + [] [RInt, RBlob, RBlob, RText] >>= \case + [final, safe] -> return $ ConsensusState + { _consensusStateFinal = readRow "final" final + , _consensusStateSafe = readRow "safe" safe + , _consensusStateLatest = latestBlock + } + inv -> error $ "invalid contents of the ConsensusState table: " <> sshow inv + where + readRow expectedType [SInt height, SBlob hash, SBlob payloadHash, SText type'] + | expectedType == type' = SyncState + { _syncStateHeight = fromIntegral @Int64 @BlockHeight height + , _syncStateBlockHash = either error id $ runGetEitherS decodeBlockHash hash + , _syncStateBlockPayloadHash = either error id $ runGetEitherS decodeBlockPayloadHash payloadHash + } + | otherwise = error $ "wrong type; expected " <> sshow expectedType <> " but got " <> sshow type' + readRow expectedType invalidRow + = error $ "invalid row: expected " <> sshow expectedType <> " but got row " <> sshow invalidRow + +getPayloadsAfter :: HasCallStack => SQLiteEnv -> Parent BlockHeight -> ExceptT LocatedSQ3Error IO [Ranked BlockPayloadHash] +getPayloadsAfter db parentHeight = do + qry db "SELECT blockheight, payloadhash FROM BlockHistory2 WHERE blockheight > ?" + [SInt (fromIntegral @BlockHeight @Int64 (unwrapParent parentHeight))] + [RInt, RBlob] >>= traverse + \case + [SInt bh, SBlob bhash] -> + return $! Ranked (fromIntegral @Int64 @BlockHeight bh) $ either error id $ runGetEitherS decodeBlockPayloadHash bhash + _ -> error "incorrect column type" + +-- | Get the checkpointer's idea of the earliest block. The block height +-- is the height of the block of the block hash. +getEarliestBlock :: HasCallStack => SQLiteEnv -> ExceptT LocatedSQ3Error IO (Maybe RankedBlockHash) +getEarliestBlock db = do + r <- qry db qtext [] [RInt, RBlob] >>= mapM go + case r of + [] -> return Nothing + (!o:_) -> return (Just o) + where + qtext = "SELECT blockheight, hash FROM BlockHistory2 ORDER BY blockheight ASC LIMIT 1" + + go [SInt hgt, SBlob blob] = + let hash = either error id $ runGetEitherS decodeBlockHash blob + in return (RankedBlockHash (fromIntegral hgt) hash) + go _ = fail "Chainweb.Pact.Backend.RelationalCheckpointer.doGetEarliest: impossible. This is a bug in chainweb-node." + +-- | Get the checkpointer's idea of the latest block. +getLatestBlock :: HasCallStack => SQLiteEnv -> ExceptT LocatedSQ3Error IO (Maybe SyncState) +getLatestBlock db = do + r <- qry db qtext [] [RInt, RBlob, RBlob] >>= mapM go + case r of + [] -> return Nothing + (!o:_) -> return (Just o) + where + qtext = "SELECT blockheight, hash, payloadhash FROM BlockHistory2 ORDER BY blockheight DESC LIMIT 1" + + go [SInt hgt, SBlob blob, SBlob pBlob] = + let hash = either error id $ runGetEitherS decodeBlockHash blob + in let pHash = either error id $ runGetEitherS decodeBlockPayloadHash pBlob + in return $ SyncState + { _syncStateBlockHash = hash + , _syncStateBlockPayloadHash = pHash + , _syncStateHeight = int hgt + } + go r = fail $ + "Chainweb.Pact.Backend.ChainwebPactDb.getLatestBlock: impossible. This is a bug in chainweb-node. Details: " + <> sshow r + +lookupBlockWithHeight :: HasCallStack => SQ3.Database -> BlockHeight -> ExceptT LocatedSQ3Error IO (Maybe (Ranked BlockHash)) +lookupBlockWithHeight db bheight = do + qry db qtext [SInt $ fromIntegral bheight] [RBlob] >>= \case + [[SBlob hash]] -> return $! Just $! + Ranked bheight (either error id $ runGetEitherS decodeBlockHash hash) + [] -> return Nothing + res -> error $ "Invalid result, " <> sshow res + where + qtext = "SELECT hash FROM BlockHistory2 WHERE blockheight = ?;" + +lookupBlockHash :: HasCallStack => SQ3.Database -> BlockHash -> ExceptT LocatedSQ3Error IO (Maybe BlockHeight) +lookupBlockHash db hash = do + qry db qtext [SBlob (runPutS (encodeBlockHash hash))] [RInt] >>= \case + [[SInt n]] -> return $! Just $! int n + [] -> return $ Nothing + res -> error $ "Invalid result, " <> sshow res + where + qtext = "SELECT blockheight FROM BlockHistory2 WHERE hash = ?;" + +lookupRankedBlockHash :: HasCallStack => SQ3.Database -> RankedBlockHash -> IO Bool +lookupRankedBlockHash db rankedBHash = throwOnDbError $ do + qry db qtext + [ SInt $ fromIntegral (_rankedBlockHashHeight rankedBHash) + , SBlob $ runPutS $ encodeBlockHash $ _rankedBlockHashHash rankedBHash + ] [RInt] >>= \case + [[SInt n]] -> return $! n == 1 + res -> error $ "Invalid result, " <> sshow res + where + qtext = "SELECT COUNT(*) FROM BlockHistory2 WHERE blockheight = ? AND hash = ?;" + +data LocatedSQ3Error = LocatedSQ3Error !CallStack !SQ3.Error +instance Show LocatedSQ3Error where + show (LocatedSQ3Error cs e) = + sshow e <> "\n\n" <> + prettyCallStack cs + +throwOnDbError :: (HasCallStack, MonadThrow m) => ExceptT LocatedSQ3Error m a -> m a +throwOnDbError act = runExceptT act >>= either (error . sshow) return + +locateSQ3Error :: (HasCallStack, Functor m) => m (Either SQ3.Error a) -> ExceptT LocatedSQ3Error m a +locateSQ3Error = ExceptT . fmap (_Left %~ LocatedSQ3Error callStack) + +-- | Statement input types +data SType = SInt Int64 | SDouble Double | SText SQ3.Utf8 | SBlob BS.ByteString deriving (Eq,Show) +-- | Result types +data RType = RInt | RDouble | RText | RBlob deriving (Eq,Show) + +bindParams :: HasCallStack => SQ3.Statement -> [SType] -> ExceptT LocatedSQ3Error IO () +bindParams stmt as = + forM_ (zip as [1..]) $ \(a,i) -> locateSQ3Error $ + case a of + SInt n -> SQ3.bindInt64 stmt i n + SDouble n -> SQ3.bindDouble stmt i n + SText n -> SQ3.bindText stmt i n + SBlob n -> SQ3.bindBlob stmt i n + +prepStmt :: HasCallStack => SQ3.Database -> SQ3.Utf8 -> ExceptT LocatedSQ3Error IO SQ3.Statement +prepStmt c q = do + r <- locateSQ3Error $ SQ3.prepare c q + case r of + Nothing -> error "No SQL statements in prepared statement" + Just s -> return s + +execMulti :: HasCallStack => Traversable t => SQ3.Database -> SQ3.Utf8 -> t [SType] -> ExceptT LocatedSQ3Error IO () +execMulti db q rows = bracket (prepStmt db q) (liftIO . SQ3.finalize) $ \stmt -> do + forM_ rows $ \row -> do + locateSQ3Error $ SQ3.reset stmt + liftIO $ SQ3.clearBindings stmt + bindParams stmt row + locateSQ3Error $ SQ3.step stmt + +-- | Prepare/execute query with params +qry :: HasCallStack => SQ3.Database -> SQ3.Utf8 -> [SType] -> [RType] -> ExceptT LocatedSQ3Error IO [[SType]] +qry e q as rts = bracket (prepStmt e q) (locateSQ3Error . SQ3.finalize) $ \stmt -> do + bindParams stmt as + reverse <$> stepStmt stmt rts + +-- | Prepare/execute query with no params +qry_ :: HasCallStack => SQ3.Database -> SQ3.Utf8 -> [RType] -> ExceptT LocatedSQ3Error IO [[SType]] +qry_ e q rts = bracket (prepStmt e q) (locateSQ3Error . finalize) $ \stmt -> + reverse <$> stepStmt stmt rts + +stepStmt :: HasCallStack => SQ3.Statement -> [RType] -> ExceptT LocatedSQ3Error IO [[SType]] +stepStmt stmt rts = do + let acc rs SQ3.Done = return rs + acc rs SQ3.Row = do + as <- lift $ forM (zip rts [0..]) $ \(rt,ci) -> + case rt of + RInt -> SInt <$> SQ3.columnInt64 stmt ci + RDouble -> SDouble <$> SQ3.columnDouble stmt ci + RText -> SText <$> SQ3.columnText stmt ci + RBlob -> SBlob <$> SQ3.columnBlob stmt ci + sr <- locateSQ3Error $ SQ3.step stmt + acc (as:rs) sr + sr <- locateSQ3Error $ SQ3.step stmt + acc [] sr + +-- | Prepare/exec statement with no params +exec_ :: HasCallStack => SQ3.Database -> SQ3.Utf8 -> ExceptT LocatedSQ3Error IO () +exec_ e q = locateSQ3Error $ over _Left fst <$> SQ3.exec e q + +-- | Prepare/exec statement with params +exec' :: HasCallStack => SQ3.Database -> SQ3.Utf8 -> [SType] -> ExceptT LocatedSQ3Error IO () +exec' e q as = bracket (prepStmt e q) (locateSQ3Error . SQ3.finalize) $ \stmt -> do + bindParams stmt as + void $ locateSQ3Error (SQ3.step stmt) + +newtype Pragma = Pragma String + deriving (Eq,Show) + deriving newtype (FromJSON, IsString) + +instance J.Encode Pragma where + build (Pragma s) = J.string s + +runPragmas :: Database -> [Pragma] -> IO () +runPragmas c = throwOnDbError . mapM_ (\(Pragma s) -> exec_ c (fromString ("PRAGMA " ++ s))) diff --git a/src/Chainweb/Block.hs b/src/Chainweb/Pact/Block.hs similarity index 85% rename from src/Chainweb/Block.hs rename to src/Chainweb/Pact/Block.hs index 2d1e1be8f9..b43f1b6524 100644 --- a/src/Chainweb/Block.hs +++ b/src/Chainweb/Pact/Block.hs @@ -1,11 +1,11 @@ -- | A type for "blocks" including their header and payload and outputs. -- This is only for REST APIs; we do not use the outputs otherwise. -module Chainweb.Block +module Chainweb.Pact.Block (Block(..)) where import Chainweb.BlockHeader -import Chainweb.Payload +import Chainweb.Pact.Payload data Block = Block { _blockHeader :: !BlockHeader diff --git a/src/Chainweb/Pact5/InitialGasModel.hs b/src/Chainweb/Pact/InitialGasModel.hs similarity index 98% rename from src/Chainweb/Pact5/InitialGasModel.hs rename to src/Chainweb/Pact/InitialGasModel.hs index 6027a0b581..ea4c051170 100644 --- a/src/Chainweb/Pact5/InitialGasModel.hs +++ b/src/Chainweb/Pact/InitialGasModel.hs @@ -2,7 +2,7 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE BangPatterns #-} -module Chainweb.Pact5.InitialGasModel +module Chainweb.Pact.InitialGasModel ( InitialGasModel(..) , pre31GasModel , post31GasModel diff --git a/src/Chainweb/Mempool/CurrentTxs.hs b/src/Chainweb/Pact/Mempool/CurrentTxs.hs similarity index 96% rename from src/Chainweb/Mempool/CurrentTxs.hs rename to src/Chainweb/Pact/Mempool/CurrentTxs.hs index a5e1a0c43f..ca1838b42e 100644 --- a/src/Chainweb/Mempool/CurrentTxs.hs +++ b/src/Chainweb/Pact/Mempool/CurrentTxs.hs @@ -4,7 +4,7 @@ {-# LANGUAGE ScopedTypeVariables #-} -- | --- Module: Chainweb.Mempool.CurrentTxs +-- Module: Chainweb.Pact.Mempool.CurrentTxs -- Copyright: Copyright © 2020 Kadena LLC. -- License: MIT -- Maintainer: Lars Kuhtz @@ -24,7 +24,7 @@ -- pact service during new block validation once it has been included in another -- block. -- -module Chainweb.Mempool.CurrentTxs +module Chainweb.Pact.Mempool.CurrentTxs ( CurrentTxs(..) , newCurrentTxs , currentTxsSize @@ -49,8 +49,8 @@ import System.Random -- internal imports --- import Chainweb.Mempool.InMemTypes -import Chainweb.Mempool.Mempool +-- import Chainweb.Pact.Mempool.InMemTypes +import Chainweb.Pact.Mempool.Mempool import Chainweb.Time import Chainweb.Utils diff --git a/src/Chainweb/Mempool/InMem.hs b/src/Chainweb/Pact/Mempool/InMem.hs similarity index 92% rename from src/Chainweb/Mempool/InMem.hs rename to src/Chainweb/Pact/Mempool/InMem.hs index 39c0bc86ca..d3f65692ab 100644 --- a/src/Chainweb/Mempool/InMem.hs +++ b/src/Chainweb/Pact/Mempool/InMem.hs @@ -14,7 +14,7 @@ {-# LANGUAGE TypeFamilies #-} -- | A mock in-memory mempool backend that does not persist to disk. -module Chainweb.Mempool.InMem +module Chainweb.Pact.Mempool.InMem ( -- * Initialization functions startInMemoryMempoolTest @@ -27,32 +27,32 @@ module Chainweb.Mempool.InMem , txTTLCheck ) where +------------------------------------------------------------------------------ #if MIN_VERSION_base(4,20,0) import Data.Foldable (foldlM) #else import Data.Foldable (foldl', foldlM) #endif -import Chainweb.BlockHash -import Chainweb.BlockHeight import Chainweb.Logger -import Chainweb.Mempool.CurrentTxs -import Chainweb.Mempool.InMemTypes -import Chainweb.Mempool.Mempool -import Chainweb.Pact4.Validations (defaultMaxTTL, defaultMaxCoinDecimalPlaces) +import Chainweb.Pact.Mempool.CurrentTxs +import Chainweb.Pact.Mempool.InMemTypes +import Chainweb.Pact.Mempool.Mempool +import Chainweb.Pact.Validations (defaultMaxTTLSeconds) +import Chainweb.Pact4.Validations (defaultMaxCoinDecimalPlaces) +import Chainweb.PayloadProvider (EvaluationCtx) +import Chainweb.Scheduler (Scheduler, scheduleEvery) import Chainweb.Time import Chainweb.Utils -import Chainweb.Version (ChainwebVersion) import Control.Applicative ((<|>)) -import Control.Concurrent.Async import Control.Concurrent.MVar import Control.DeepSeq -import Control.Error.Util (hush) -import Control.Exception (evaluate, mask_, throw) +import Control.Exception (evaluate, mask_) import Control.Lens import Control.Monad import Control.Monad.IO.Class (liftIO) import Control.Monad.Except (runExceptT, throwError) +import Control.Monad.Trans.Resource import Data.ByteString (ByteString) import Data.ByteString qualified as BS import Data.ByteString.Short qualified as SB @@ -72,12 +72,12 @@ import Data.Vector (Vector) import Data.Vector qualified as V import Data.Vector.Algorithms.Tim qualified as TimSort import Numeric.AffineSpace -import Pact.Parse -import Pact.Types.ChainMeta qualified as P +import Pact.Core.Gas import Prelude hiding (init, lookup, pred) import System.LogLevel import System.Random + ------------------------------------------------------------------------------ compareOnGasPrice :: TransactionConfig t -> t -> t -> Ordering compareOnGasPrice txcfg a b = compare aa bb @@ -95,8 +95,8 @@ makeInMemPool cfg = mask_ $ do dataLock <- newInMemMempoolData >>= newMVar return $! InMemoryMempool cfg dataLock nonce ------------------------------------------------------------------------------- +------------------------------------------------------------------------------ newInMemMempoolData :: IO (InMemoryMempoolData t) newInMemMempoolData = InMemoryMempoolData <$!> newIORef mempty @@ -104,6 +104,7 @@ newInMemMempoolData = <*> newIORef mempty <*> newIORef newCurrentTxs + ------------------------------------------------------------------------------ toMempoolBackend :: forall t logger @@ -156,28 +157,17 @@ startInMemoryMempoolTest cfg = do withInMemoryMempool :: Logger logger => NFData t - => logger + => Scheduler + -> logger -> InMemConfig t - -> ChainwebVersion - -> (MempoolBackend t -> IO a) - -> IO a -withInMemoryMempool l cfg _v f = do - let action inMem = do - r <- race (monitor inMem) $ do - back <- toMempoolBackend l inMem - f $! back - case r of - Left () -> throw $ InternalInvariantViolation "mempool monitor exited unexpectedly" - Right result -> return result - action =<< makeInMemPool cfg - where - monitor m = do - let lf = logFunction l - logFunctionText l Debug "Initialized Mempool Monitor" - runForeverThrottled lf "Chainweb.Mempool.InMem.withInMemoryMempool.monitor" 10 (10 * mega) $ do - stats <- getMempoolStats m - logFunctionJson l Info stats - approximateThreadDelay 60_000_000 {- 1 minute -} + -> ResourceT IO (MempoolBackend t) +withInMemoryMempool sched l cfg = do + inMem <- liftIO $ makeInMemPool cfg + liftIO $ logFunctionText l Debug "Initialized Mempool Monitor" + liftIO $ scheduleEvery sched "Chainweb.Pact.Mempool.InMem.withInMemoryMempool.monitor" 60_000_000 $ do + stats <- getMempoolStats inMem + logFunctionJson l Info stats + liftIO $ toMempoolBackend l inMem ------------------------------------------------------------------------------ memberInMem :: MVar (InMemoryMempoolData t) @@ -266,8 +256,7 @@ addToBadListInMem lock txs = withMVarMasked lock $ \mdata -> do let !pnd' = foldl' (flip HashMap.delete) pnd txs -- we don't have the expiry time here, so just use maxTTL now <- getCurrentTimeIntegral - let P.TTLSeconds (ParsedInteger mt) = defaultMaxTTL - let !endTime = add (secondsToTimeSpan $ fromIntegral mt) now + let !endTime = add (secondsToTimeSpan $ fromIntegral defaultMaxTTLSeconds) now let !bad' = foldl' (\h tx -> HashMap.insert tx endTime h) bad txs writeIORef (_inmemPending mdata) pnd' writeIORef (_inmemBadMap mdata) bad' @@ -348,7 +337,7 @@ insertCheckVerboseInMem logger cfg lock txs now <- getCurrentTimeIntegral badmap <- withMVarMasked lock $ readIORef . _inmemBadMap curTxIdx <- withMVarMasked lock $ readIORef . _inmemCurrentTxs - + withHashesAndPositions :: (HashMap TransactionHash (Int, InsertError), HashMap TransactionHash (Int, t)) <- do pos <- flip V.imapM txs $ \i tx -> do let !h = hasher tx @@ -444,15 +433,10 @@ validateOne cfg badmap curTxIdx now t h = -- prop_tx_gas_rounding gasPriceRoundingCheck :: Either InsertError () gasPriceRoundingCheck = - ebool_ (InsertErrorOther msg) (f (txGasPrice txcfg t)) + ebool_ (InsertErrorBadGasPrice gp) f where - f (GasPrice (ParsedDecimal d)) = decimalPlaces d <= defaultMaxCoinDecimalPlaces - msg = T.unwords - [ "This transaction's gas price:" - , sshow (txGasPrice txcfg t) - , "is not correctly rounded." - , "It should be rounded to at most 12 decimal places." - ] + gp@(GasPrice d) = txGasPrice txcfg t + f = decimalPlaces d <= defaultMaxCoinDecimalPlaces -- prop_tx_ttl_arrival ttlCheck :: Either InsertError () @@ -510,6 +494,7 @@ insertCheckInMem' logger cfg lock txs now <- getCurrentTimeIntegral badmap <- withMVarMasked lock $ readIORef . _inmemBadMap curTxIdx <- withMVarMasked lock $ readIORef . _inmemCurrentTxs + let hush = either (const Nothing) Just withHashes :: Vector (T2 TransactionHash t) <- do flip V.mapMaybeM txs $ \tx -> do @@ -576,11 +561,10 @@ getBlockInMem -> MVar (InMemoryMempoolData t) -> BlockFill -> MempoolPreBlockCheck t to - -> BlockHeight - -> BlockHash + -> EvaluationCtx () -> IO (Vector to) -getBlockInMem logg cfg lock (BlockFill gasLimit txHashes _) txValidate bheight phash = do - logFunctionText logg Debug $ "getBlockInMem: " <> sshow (gasLimit,bheight,phash) +getBlockInMem logg cfg lock (BlockFill gasLimit txHashes _) txValidate evalCtx = do + -- logFunctionText logg Debug $ "getBlockInMem: " <> sshow (gasLimit,evalCtx) withMVar lock $ \mdata -> do now <- getCurrentTimeIntegral @@ -643,7 +627,7 @@ getBlockInMem logg cfg lock (BlockFill gasLimit txHashes _) txValidate bheight p err s = error $ mconcat [ "Error decoding tx (\"" , s - , "\"): tx was: " + , "\"): did you disable checks and insert an invalid transaction? tx was: " , T.unpack (T.decodeUtf8 tx) ] getSize = txGasLimit txcfg @@ -659,7 +643,7 @@ getBlockInMem logg cfg lock (BlockFill gasLimit txHashes _) txValidate bheight p BadMap) validateBatch !psq0 !badmap q = do let txs = V.map (snd . snd) q - oks1 <- txValidate bheight phash txs + oks1 <- txValidate evalCtx txs let oks2 = V.map sizeOK txs let !oks = V.zipWith (\ok1 ok2 -> ok1 <* ok2) oks1 oks2 let (bad1, good) = @@ -698,27 +682,27 @@ getBlockInMem logg cfg lock (BlockFill gasLimit txHashes _) txValidate bheight p -> [(TransactionHash, (SB.ShortByteString, t))] -> Int -> [(TransactionHash, (SB.ShortByteString, t))] - getBatch !pendingTxs !sz !soFar !inARow + getBatch !pendingTxs !(GasLimit (Gas sz)) !soFar !inARow -- we'll keep looking for transactions until we hit maxInARow that are -- too large | V.null pendingTxs = soFar - | inARow >= maxInARow || sz <= 0 = soFar + | inARow >= maxInARow || sz == 0 = soFar | otherwise = do let (T2 (h, pe) !pendingTxs') = unconsV pendingTxs let !txbytes = _inmemPeBytes pe let !tx = decodeTx txbytes - let !txSz = getSize tx + let !(GasLimit (Gas txSz)) = getSize tx if txSz <= sz - then getBatch pendingTxs' (sz - txSz) ((h,(txbytes, tx)):soFar) 0 - else getBatch pendingTxs' sz soFar (inARow + 1) + then getBatch pendingTxs' (GasLimit (Gas (sz - txSz))) ((h,(txbytes, tx)):soFar) 0 + else getBatch pendingTxs' (GasLimit (Gas sz)) soFar (inARow + 1) go :: PendingMap -> BadMap -> GasLimit -> [[(TransactionHash, (SB.ShortByteString, t, to))]] -> IO (T3 PendingMap BadMap (Vector (TransactionHash, (SB.ShortByteString, t, to)))) - go !psq !badmap !remainingGas !soFar = do - nb <- nextBatch psq remainingGas + go !psq !badmap !(GasLimit remainingGas) !soFar = do + nb <- nextBatch psq (GasLimit remainingGas) if null nb then do logFunctionText logg Debug "getBlockInMem: Batch empty" @@ -726,8 +710,11 @@ getBlockInMem logg cfg lock (BlockFill gasLimit txHashes _) txValidate bheight p else do logFunctionText logg Debug "validating batch..." T3 good psq' badmap' <- validateBatch psq badmap $! V.fromList nb - let !newGas = foldl' (\s (_, (_, t, _)) -> s + getSize t) 0 good - go psq' badmap' (remainingGas - newGas) (good : soFar) + let !newGas = foldl' + (\s (_, (_, t, _)) -> s - view (_GasLimit . to _gas) (getSize t)) + (_gas remainingGas) + good + go psq' badmap' (GasLimit $ Gas newGas) (good : soFar) ------------------------------------------------------------------------------ diff --git a/src/Chainweb/Pact/Mempool/InMem/ValidatingConfig.hs b/src/Chainweb/Pact/Mempool/InMem/ValidatingConfig.hs new file mode 100644 index 0000000000..57f8563d32 --- /dev/null +++ b/src/Chainweb/Pact/Mempool/InMem/ValidatingConfig.hs @@ -0,0 +1,90 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE OverloadedStrings #-} + +-- | +-- Module: Chainweb.Pact.Mempool.InMem.ValidatingConfig +-- Copyright: Copyright © 2025 Kadena LLC. +-- License: MIT +-- Maintainer: Lars Kuhtz +-- Stability: experimental +-- +module Chainweb.Pact.Mempool.InMem.ValidatingConfig +( validatingMempoolConfig +) where + +import Control.Lens +import Chainweb.ChainId +import Chainweb.Pact.Mempool.InMemTypes +import Chainweb.Pact.Mempool.Mempool +import Chainweb.Pact.Transaction qualified as Pact +import Chainweb.Pact.Validations +import Chainweb.Utils +import Chainweb.Version +import Data.These +import Data.Vector qualified as V +import qualified Pact.Core.Command.Types as Pact + +validatingMempoolConfig + :: HasVersion + => ChainId + -> GasLimit + -> GasPrice + -> (V.Vector Pact.Transaction -> IO (V.Vector (Maybe InsertError))) + -> InMemConfig Pact.Transaction +validatingMempoolConfig cid gl gp preInsertCheck = InMemConfig + { _inmemTxCfg = pactTransactionConfig + , _inmemTxBlockSizeLimit = gl + , _inmemTxMinGasPrice = gp + , _inmemMaxRecentItems = maxRecentLog + , _inmemPreInsertPureChecks = preInsertSingle + , _inmemPreInsertBatchChecks = preInsertBatch + , _inmemCurrentTxsSize = currentTxsSize + } + where + maxRecentLog = 2048 + + currentTxsSize = 1024 * 1024 -- ~16MB per mempool + -- 1M items is is sufficient for supporing about 12 TPS per chain, which + -- is about 360 tx per block. Larger TPS values would result in false + -- negatives in the set. + + -- | Validation: Is this TX associated with the correct `ChainId`? + -- + preInsertSingle :: Pact.Transaction -> Either InsertError Pact.Transaction + preInsertSingle tx = do + let !pay = view Pact.payloadObj . Pact._cmdPayload $ tx + pcid = Pact._pmChainId $ Pact._pMeta pay + sigs = Pact._cmdSigs tx + ver = Pact._pNetworkId pay + if | not $ assertChainId cid pcid -> Left InsertErrorMetadataMismatch + | not $ assertSigSize sigs -> Left InsertErrorTooManySigs + | not $ assertNetworkId ver -> Left InsertErrorMetadataMismatch + | otherwise -> Right tx + + -- | Validation: All checks that should occur before a TX is inserted into + -- the mempool. A rejection at this stage means that something is + -- fundamentally wrong/illegal with the TX, and that it should be rejected + -- completely and not gossiped to other peers. + -- + -- We expect this to be called in two places: once when a new Pact + -- Transaction is submitted via the @send@ endpoint, and once when a new TX + -- is gossiped to us from a peer's mempool. + -- + preInsertBatch + :: V.Vector (T2 TransactionHash Pact.Transaction) + -> IO (V.Vector (Either (T2 TransactionHash InsertError) + (T2 TransactionHash Pact.Transaction))) + preInsertBatch txs + | V.null txs = return V.empty + | otherwise = do + rs <- preInsertCheck (V.map ssnd txs) + pure $ alignWithV f rs txs + where + f (These r (T2 h t)) = case r of + Just e -> Left (T2 h e) + Nothing -> Right (T2 h t) + f (That _) = alignmentError + f (This _) = alignmentError + alignmentError = error "internal error: mismatch between input and output length of pre-insert check" diff --git a/src/Chainweb/Mempool/InMemTypes.hs b/src/Chainweb/Pact/Mempool/InMemTypes.hs similarity index 92% rename from src/Chainweb/Mempool/InMemTypes.hs rename to src/Chainweb/Pact/Mempool/InMemTypes.hs index e95fb936e8..bd6e9a9b7b 100644 --- a/src/Chainweb/Mempool/InMemTypes.hs +++ b/src/Chainweb/Pact/Mempool/InMemTypes.hs @@ -9,7 +9,7 @@ {-# LANGUAGE TypeFamilies #-} -- | An in-memory mempool backend that does not persist to disk. -module Chainweb.Mempool.InMemTypes +module Chainweb.Pact.Mempool.InMemTypes ( InMemConfig(..) , InMemoryMempool(..) , InMemoryMempoolData(..) @@ -39,8 +39,8 @@ import Numeric.Natural -- internal imports -import Chainweb.Mempool.CurrentTxs -import Chainweb.Mempool.Mempool +import Chainweb.Pact.Mempool.CurrentTxs +import Chainweb.Pact.Mempool.Mempool import Chainweb.Time (Micros(..), Time(..)) import Chainweb.Utils (T2) @@ -59,6 +59,11 @@ type PendingMap = HashMap TransactionHash PendingEntry ------------------------------------------------------------------------------ -- | Configuration for in-memory mempool. +-- +-- TODO: The type contains parameters that should be configurable as well as +-- parameters that are determined by the chainweb version or the chainweb +-- protocol. These should be separated in to two different types. +-- data InMemConfig t = InMemConfig { _inmemTxCfg :: {-# UNPACK #-} !(TransactionConfig t) , _inmemTxBlockSizeLimit :: !GasLimit diff --git a/src/Chainweb/Mempool/Mempool.hs b/src/Chainweb/Pact/Mempool/Mempool.hs similarity index 91% rename from src/Chainweb/Mempool/Mempool.hs rename to src/Chainweb/Pact/Mempool/Mempool.hs index a6f8ce4319..54f8602abf 100644 --- a/src/Chainweb/Mempool/Mempool.hs +++ b/src/Chainweb/Pact/Mempool/Mempool.hs @@ -12,6 +12,7 @@ {-# LANGUAGE TemplateHaskell #-} {-# OPTIONS_GHC -fno-warn-orphans #-} +{-# LANGUAGE ImportQualifiedPost #-} ------------------------------------------------------------------------------ -- | Mempool @@ -54,7 +55,7 @@ -- -- The mempool API is defined as a record-of-functions in 'MempoolBackend'. -module Chainweb.Mempool.Mempool +module Chainweb.Pact.Mempool.Mempool ( MempoolBackend(..) , MempoolPreBlockCheck , TransactionConfig(..) @@ -74,7 +75,7 @@ module Chainweb.Mempool.Mempool , bfTxHashes , bfCount - , pact4TransactionConfig + , pactTransactionConfig , mockCodec , mockEncode , mockBlockGasLimit @@ -86,8 +87,7 @@ module Chainweb.Mempool.Mempool , syncMempools' , GasLimit(..) , GasPrice(..) - , pact4RequestKeyToTransactionHash - , pact5RequestKeyToTransactionHash + , pactRequestKeyToTransactionHash ) where ------------------------------------------------------------------------------ @@ -121,7 +121,7 @@ import Data.Vector (Vector) import qualified Data.Vector as V import Data.Word (Word64) -import GHC.Generics +import GHC.Generics hiding (to) import Prelude hiding (log) @@ -130,23 +130,24 @@ import System.LogLevel -- internal modules import qualified Pact.JSON.Encode as J -import Pact.Parse (ParsedDecimal(..), ParsedInteger(..)) -import Pact.Types.ChainMeta (TTLSeconds(..), TxCreationTime(..)) -import Pact.Types.Command -import Pact.Types.Gas (GasLimit(..), GasPrice(..)) -import qualified Pact.Types.Hash as Pact4 + +import Pact.Core.Command.Types qualified as Pact +import Pact.Core.Hash qualified as Pact +import Pact.Core.Gas +import Pact.Core.ChainData +import Pact.Core.ChainData qualified as Pact + +import Data.LogMessage (LogFunctionText) import Chainweb.BlockHash import Chainweb.BlockHeight import Chainweb.Time (Micros(..), Time(..), TimeSpan(..)) -import qualified Chainweb.Time as Time -import qualified Chainweb.Pact4.Transaction as Pact4 +import Chainweb.Time qualified as Time +import Chainweb.Pact.Transaction qualified as Pact import Chainweb.Utils import Chainweb.Utils.Serialization -import Data.LogMessage (LogFunctionText) -import qualified Pact.Types.Command as Pact4 -import qualified Pact.Core.Command.Types as Pact5 -import qualified Pact.Core.Hash as Pact5 + +import Chainweb.PayloadProvider (EvaluationCtx(..)) ------------------------------------------------------------------------------ data LookupResult t = Missing @@ -187,7 +188,7 @@ instance Traversable LookupResult where Pending x -> Pending <$> f x ------------------------------------------------------------------------------ -type MempoolPreBlockCheck ti to = BlockHeight -> BlockHash -> Vector ti -> IO (Vector (Either InsertError to)) +type MempoolPreBlockCheck ti to = EvaluationCtx () -> Vector ti -> IO (Vector (Either InsertError to)) ------------------------------------------------------------------------------ -- | Mempool operates over a transaction type @t@. Mempool needs several @@ -236,9 +237,10 @@ data InsertError | InsertErrorTransactionsDisabled | InsertErrorBuyGas Text | InsertErrorCompilationFailed Text - | InsertErrorOther Text + | InsertErrorBadGasPrice GasPrice | InsertErrorInvalidHash | InsertErrorInvalidSigs Text + | InsertErrorTooManySigs | InsertErrorTimedOut | InsertErrorPactParseError Text | InsertErrorWrongChain Text Text @@ -255,14 +257,20 @@ instance Show InsertError where InsertErrorBadlisted -> "Transaction is badlisted because it previously failed to validate." InsertErrorMetadataMismatch -> "Transaction metadata (chain id, chainweb version) conflicts with this endpoint" InsertErrorTransactionsDisabled -> "Transactions are disabled until 2019 Dec 5" - InsertErrorBuyGas msg -> "Attempt to buy gas failed with: " <> T.unpack msg + InsertErrorBuyGas msg -> T.unpack msg InsertErrorCompilationFailed msg -> "Transaction compilation failed: " <> T.unpack msg - InsertErrorOther m -> "insert error: " <> T.unpack m InsertErrorInvalidHash -> "Invalid transaction hash" InsertErrorInvalidSigs msg -> "Invalid transaction sigs: " <> T.unpack msg InsertErrorTimedOut -> "Transaction validation timed out" InsertErrorPactParseError msg -> "Pact parse error: " <> T.unpack msg InsertErrorWrongChain expected actual -> "Wrong chain, expected: " <> T.unpack expected <> ", actual: " <> T.unpack actual + InsertErrorBadGasPrice (GasPrice d) -> concat + [ "This transaction's gas price (" + , sshow d + , ") is not correctly rounded. " + , "It should be rounded to at most 12 decimal places." + ] + InsertErrorTooManySigs -> "Too many signatures" InsertErrorDefPactComplete i -> "This transaction is attempting to complete an already-completed defpact ID: " <> T.unpack i @@ -318,7 +326,7 @@ data MempoolBackend t = MempoolBackend { -- for mining. -- , mempoolGetBlock - :: forall to. BlockFill -> MempoolPreBlockCheck t to -> BlockHeight -> BlockHash -> IO (Vector to) + :: forall to. BlockFill -> MempoolPreBlockCheck t to -> EvaluationCtx () -> IO (Vector to) -- | Discard any expired transactions. , mempoolPrune :: IO () @@ -338,7 +346,7 @@ data MempoolBackend t = MempoolBackend { } noopMempoolPreBlockCheck :: MempoolPreBlockCheck t t -noopMempoolPreBlockCheck _ _ v = return $! V.map Right v +noopMempoolPreBlockCheck _ v = return $! V.map Right v noopMempool :: IO (MempoolBackend t) noopMempool = do @@ -362,8 +370,8 @@ noopMempool = do noopCodec = Codec (const "") (const $ Left "unimplemented") noopHasher = const $ chainwebTestHasher "noopMempool" noopHashMeta = chainwebTestHashMeta - noopGasPrice = const 0 - noopSize = const 1 + noopGasPrice = const (GasPrice 0) + noopSize = const (GasLimit $ Gas 1) noopMeta = const $ TransactionMetadata Time.minTime Time.maxTime txcfg = TransactionConfig noopCodec noopHasher noopHashMeta noopGasPrice noopSize noopMeta @@ -376,31 +384,29 @@ noopMempool = do noopMV = const $ return () noopAddToBadList = const $ return () noopCheckBadList v = return $ V.replicate (V.length v) False - noopGetBlock _ _ _ _ = return V.empty + noopGetBlock _ _ _ = return V.empty noopGetPending = const $ const $ return (0,0) noopClear = return () ------------------------------------------------------------------------------ -pact4TransactionConfig - :: TransactionConfig Pact4.UnparsedTransaction -pact4TransactionConfig = TransactionConfig - { txCodec = Pact4.rawCommandCodec +pactTransactionConfig + :: TransactionConfig Pact.Transaction +pactTransactionConfig = TransactionConfig + { txCodec = Pact.commandCodec , txHasher = commandHash , txHashMeta = chainwebTestHashMeta - , txGasPrice = getGasPrice - , txGasLimit = getGasLimit + , txGasPrice = view (Pact.cmdPayload . Pact.payloadObj . Pact.pMeta . Pact.pmGasPrice) + , txGasLimit = view (Pact.cmdPayload . Pact.payloadObj . Pact.pMeta . Pact.pmGasLimit) , txMetadata = txmeta } where - getGasPrice = view Pact4.cmdGasPrice . fmap Pact4.payloadObj - getGasLimit = view Pact4.cmdGasLimit . fmap Pact4.payloadObj - getTimeToLive = view Pact4.cmdTimeToLive . fmap Pact4.payloadObj - getCreationTime = view Pact4.cmdCreationTime . fmap Pact4.payloadObj - commandHash c = let (Pact4.Hash !h) = Pact4.toUntypedHash $ _cmdHash c + getTimeToLive = view (Pact.cmdPayload . Pact.payloadObj . Pact.pMeta . Pact.pmTTL) + getCreationTime = view (Pact.cmdPayload . Pact.payloadObj . Pact.pMeta . Pact.pmCreationTime) + commandHash c = let Pact.Hash h = Pact._cmdHash c in TransactionHash h txmeta t = TransactionMetadata @@ -622,11 +628,8 @@ instance HasTextRepresentation TransactionHash where {-# INLINE toText #-} {-# INLINE fromText #-} -pact4RequestKeyToTransactionHash :: Pact4.RequestKey -> TransactionHash -pact4RequestKeyToTransactionHash = TransactionHash . Pact4.unHash . Pact4.unRequestKey - -pact5RequestKeyToTransactionHash :: Pact5.RequestKey -> TransactionHash -pact5RequestKeyToTransactionHash = TransactionHash . Pact5.unHash . Pact5.unRequestKey +pactRequestKeyToTransactionHash :: Pact.RequestKey -> TransactionHash +pactRequestKeyToTransactionHash = TransactionHash . Pact.unHash . Pact.unRequestKey ------------------------------------------------------------------------------ -- @@ -721,8 +724,8 @@ data MockTx = MockTx { instance J.Encode MockTx where build o = J.object [ "mockNonce" J..= J.Aeson (mockNonce o) - , "mockGasPrice" J..= mockGasPrice o - , "mockGasLimit" J..= mockGasLimit o + , "mockGasPrice" J..= J.string (show (view _GasPrice (mockGasPrice o))) + , "mockGasLimit" J..= J.number (fromIntegral $ view (_GasLimit . to _gas) (mockGasLimit o)) , "mockMeta" J..= mockMeta o ] {-# INLINE build #-} @@ -735,13 +738,13 @@ instance ToJSON MockTx where instance FromJSON MockTx where parseJSON = withObject "MockTx" $ \o -> MockTx <$> o .: "mockNonce" - <*> o .: "mockGasPrice" - <*> o .: "mockGasLimit" + <*> fmap (GasPrice . read @Decimal) (o .: "mockGasPrice") + <*> fmap (GasLimit . Gas . fromIntegral @Int @SatWord) (o .: "mockGasLimit") <*> o .: "mockMeta" {-# INLINE parseJSON #-} mockBlockGasLimit :: GasLimit -mockBlockGasLimit = 100_000_000 +mockBlockGasLimit = GasLimit $ Gas 100_000_000 -- | A codec for transactions when sending them over the wire. mockCodec :: Codec MockTx @@ -749,7 +752,7 @@ mockCodec = Codec mockEncode mockDecode mockEncode :: MockTx -> ByteString -mockEncode (MockTx nonce (GasPrice (ParsedDecimal price)) limit meta) = +mockEncode (MockTx nonce (GasPrice price) (GasLimit (Gas limit)) meta) = B64.encode $ runPutS $ do putWord64le $ fromIntegral nonce @@ -796,8 +799,8 @@ mockDecode s = do s' <- B64.decode s runGetEitherS (MockTx <$> getI64 <*> getPrice <*> getGL <*> getMeta) s' where - getPrice = GasPrice . ParsedDecimal <$> getDecimal - getGL = GasLimit . ParsedInteger . fromIntegral <$> getWord64le + getPrice = GasPrice <$> getDecimal + getGL = GasLimit . Gas . fromIntegral <$> getWord64le getI64 = fromIntegral <$> getWord64le getMeta = TransactionMetadata <$> Time.decodeTime <*> Time.decodeTime diff --git a/src/Chainweb/Mempool/P2pConfig.hs b/src/Chainweb/Pact/Mempool/P2pConfig.hs similarity index 78% rename from src/Chainweb/Mempool/P2pConfig.hs rename to src/Chainweb/Pact/Mempool/P2pConfig.hs index b4e24fd893..474fbe206c 100644 --- a/src/Chainweb/Mempool/P2pConfig.hs +++ b/src/Chainweb/Pact/Mempool/P2pConfig.hs @@ -4,9 +4,10 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} -- | --- Module: Chainweb.Mempool.P2pConfig +-- Module: Chainweb.Pact.Mempool.P2pConfig -- Copyright: Copyright © 2018 - 2020 Kadena LLC. -- License: MIT -- Maintainer: Lars Kuhtz @@ -14,7 +15,7 @@ -- -- P2p Configuration for the Mempool. -- -module Chainweb.Mempool.P2pConfig +module Chainweb.Pact.Mempool.P2pConfig ( MempoolP2pConfig(..) , mempoolP2pConfigMaxSessionCount , mempoolP2pConfigSessionTimeout @@ -35,6 +36,7 @@ import Numeric.Natural import Chainweb.Time import Chainweb.Utils +import Chainweb.ChainId data MempoolP2pConfig = MempoolP2pConfig { _mempoolP2pConfigMaxSessionCount :: !Natural @@ -73,14 +75,14 @@ instance FromJSON MempoolP2pConfig where <*> o .: "sessionTimeout" <*> o .: "pollInterval" -pMempoolP2pConfig :: MParser MempoolP2pConfig -pMempoolP2pConfig = id +pMempoolP2pConfig :: ChainId -> MParser MempoolP2pConfig +pMempoolP2pConfig cid = id <$< mempoolP2pConfigMaxSessionCount .:: option auto - % long "mempool-p2p-max-session-count" - <> help "maximum number of sessions that are active at any time" + % prefixLongCid cid "mempool-p2p-max-session-count" + <> helpCid cid "maximum number of sessions that are active at any time" <*< mempoolP2pConfigSessionTimeout .:: textOption - % long "mempool-p2p-session-timeout" - <> help "timeout for sessions in seconds" + % prefixLongCid cid "mempool-p2p-session-timeout" + <> helpCid cid "timeout for sessions in seconds" <*< mempoolP2pConfigPollInterval .:: textOption - % long "mempool-p2p-poll-interval" - <> help "poll interval for synchronizing mempools in seconds" + % prefixLongCid cid "mempool-p2p-poll-interval" + <> helpCid cid "poll interval for synchronizing mempools in seconds" diff --git a/src/Chainweb/Mempool/RestAPI.hs b/src/Chainweb/Pact/Mempool/RestAPI.hs similarity index 95% rename from src/Chainweb/Mempool/RestAPI.hs rename to src/Chainweb/Pact/Mempool/RestAPI.hs index 2caf1fc569..bd57843150 100644 --- a/src/Chainweb/Mempool/RestAPI.hs +++ b/src/Chainweb/Pact/Mempool/RestAPI.hs @@ -13,7 +13,7 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} -module Chainweb.Mempool.RestAPI +module Chainweb.Pact.Mempool.RestAPI ( Mempool_(..) , SomeMempool(..) , someMempoolVal @@ -43,7 +43,7 @@ import Servant ------------------------------------------------------------------------------ import Chainweb.ChainId -import Chainweb.Mempool.Mempool +import Chainweb.Pact.Mempool.Mempool import Chainweb.RestAPI.Utils import Chainweb.Version @@ -57,9 +57,9 @@ data SomeMempool t = forall v c . (KnownChainwebVersionSymbol v, KnownChainIdSymbol c) => SomeMempool (Mempool_ v c t) -someMempoolVal :: ChainwebVersion -> ChainId -> MempoolBackend t -> SomeMempool t -someMempoolVal v cid m = - case someChainwebVersionVal v of +someMempoolVal :: HasVersion => ChainId -> MempoolBackend t -> SomeMempool t +someMempoolVal cid m = + case someChainwebVersionVal of (SomeChainwebVersionT (Proxy :: Proxy vt)) -> case someChainIdVal cid of (SomeChainIdT (Proxy :: Proxy cidt)) -> SomeMempool (Mempool_ @vt @cidt m) @@ -148,4 +148,3 @@ mempoolGetPendingApi :: forall (v :: ChainwebVersionT) (c :: ChainIdT) . Proxy (MempoolGetPendingApi v c) mempoolGetPendingApi = Proxy - diff --git a/src/Chainweb/Mempool/RestAPI/Client.hs b/src/Chainweb/Pact/Mempool/RestAPI/Client.hs similarity index 83% rename from src/Chainweb/Mempool/RestAPI/Client.hs rename to src/Chainweb/Pact/Mempool/RestAPI/Client.hs index 0d9db652d6..c9ad28ea0b 100644 --- a/src/Chainweb/Mempool/RestAPI/Client.hs +++ b/src/Chainweb/Pact/Mempool/RestAPI/Client.hs @@ -10,7 +10,7 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} -module Chainweb.Mempool.RestAPI.Client +module Chainweb.Pact.Mempool.RestAPI.Client ( insertClient , getPendingClient , memberClient @@ -36,8 +36,8 @@ import Servant.Client ------------------------------------------------------------------------------ import Chainweb.ChainId -import Chainweb.Mempool.Mempool -import Chainweb.Mempool.RestAPI +import Chainweb.Pact.Mempool.Mempool +import Chainweb.Pact.Mempool.RestAPI import Chainweb.Utils import Chainweb.Version @@ -46,12 +46,12 @@ import Chainweb.Version -- TODO: all of these operations need timeout support. toMempool :: (Show t, NFData t) - => ChainwebVersion - -> ChainId + => HasVersion + => ChainId -> TransactionConfig t -> ClientEnv -> MempoolBackend t -toMempool version chain txcfg env = +toMempool chain txcfg env = MempoolBackend { mempoolTxConfig = txcfg , mempoolMember = member @@ -63,7 +63,7 @@ toMempool version chain txcfg env = , mempoolMarkValidated = const unsupported , mempoolAddToBadList = const unsupported , mempoolCheckBadList = const unsupported - , mempoolGetBlock = \_ _ _ _ -> unsupported + , mempoolGetBlock = \_ _ _ -> unsupported , mempoolGetPendingTransactions = getPending , mempoolPrune = unsupported , mempoolClear = clear @@ -71,12 +71,12 @@ toMempool version chain txcfg env = where go m = runClientM m env >>= either throwIO return - member v = V.fromList <$> go (memberClient version chain (V.toList v)) - lookup v = V.fromList <$> go (lookupClient txcfg version chain (V.toList v)) - insert _ v = void $ go (insertClient txcfg version chain (V.toList v)) + member v = V.fromList <$> go (memberClient chain (V.toList v)) + lookup v = V.fromList <$> go (lookupClient txcfg chain (V.toList v)) + insert _ v = void $ go (insertClient txcfg chain (V.toList v)) getPending hw cb = do - runClientM (getPendingClient version chain hw) env >>= \case + runClientM (getPendingClient chain hw) env >>= \case Left e -> throwIO e Right ptxs -> do void $ cb (V.fromList $ _pendingTransationsHashes ptxs) @@ -94,14 +94,14 @@ insertClient_ insertClient_ = client (mempoolInsertApi @v @c) insertClient - :: TransactionConfig t - -> ChainwebVersion + :: HasVersion + => TransactionConfig t -> ChainId -> [t] -> ClientM NoContent -insertClient txcfg v c k0 = runIdentity $ do +insertClient txcfg c k0 = runIdentity $ do let k = map (T.decodeUtf8 . codecEncode (txCodec txcfg)) k0 - SomeChainwebVersionT (_ :: Proxy v) <- return $ someChainwebVersionVal v + SomeChainwebVersionT (_ :: Proxy v) <- return $ someChainwebVersionVal SomeChainIdT (_ :: Proxy c) <- return $ someChainIdVal c return $ insertClient_ @v @c k @@ -115,12 +115,12 @@ memberClient_ memberClient_ = client (mempoolMemberApi @v @c) memberClient - :: ChainwebVersion - -> ChainId + :: HasVersion + => ChainId -> [TransactionHash] -> ClientM [Bool] -memberClient v c txs = runIdentity $ do - SomeChainwebVersionT (_ :: Proxy v) <- return $ someChainwebVersionVal v +memberClient c txs = runIdentity $ do + SomeChainwebVersionT (_ :: Proxy v) <- return $ someChainwebVersionVal SomeChainIdT (_ :: Proxy c) <- return $ someChainIdVal c return $ memberClient_ @v @c txs @@ -134,13 +134,13 @@ lookupClient_ lookupClient_ = client (mempoolLookupApi @v @c) lookupClient - :: TransactionConfig t - -> ChainwebVersion + :: HasVersion + => TransactionConfig t -> ChainId -> [TransactionHash] -> ClientM [LookupResult t] -lookupClient txcfg v c txs = do - SomeChainwebVersionT (_ :: Proxy v) <- return $ someChainwebVersionVal v +lookupClient txcfg c txs = do + SomeChainwebVersionT (_ :: Proxy v) <- return $ someChainwebVersionVal SomeChainIdT (_ :: Proxy c) <- return $ someChainIdVal c cs <- lookupClient_ @v @c txs mapM (traverse go) cs @@ -161,13 +161,13 @@ getPendingClient_ getPendingClient_ = client (mempoolGetPendingApi @v @c) getPendingClient - :: ChainwebVersion - -> ChainId + :: HasVersion + => ChainId -> Maybe (ServerNonce, MempoolTxId) -> ClientM PendingTransactions -getPendingClient v c hw = runIdentity $ do +getPendingClient c hw = runIdentity $ do let nonce = fst <$> hw let tx = snd <$> hw - SomeChainwebVersionT (_ :: Proxy v) <- return $ someChainwebVersionVal v + SomeChainwebVersionT (_ :: Proxy v) <- return $ someChainwebVersionVal SomeChainIdT (_ :: Proxy c) <- return $ someChainIdVal c return $ getPendingClient_ @v @c nonce tx diff --git a/src/Chainweb/Mempool/RestAPI/Server.hs b/src/Chainweb/Pact/Mempool/RestAPI/Server.hs similarity index 85% rename from src/Chainweb/Mempool/RestAPI/Server.hs rename to src/Chainweb/Pact/Mempool/RestAPI/Server.hs index c4a950cfc6..5189e6dde1 100644 --- a/src/Chainweb/Mempool/RestAPI/Server.hs +++ b/src/Chainweb/Pact/Mempool/RestAPI/Server.hs @@ -5,7 +5,7 @@ {-# LANGUAGE TypeApplications #-} {-# LANGUAGE OverloadedStrings #-} -module Chainweb.Mempool.RestAPI.Server +module Chainweb.Pact.Mempool.RestAPI.Server ( mempoolServer , someMempoolServer , someMempoolServers @@ -13,6 +13,7 @@ module Chainweb.Mempool.RestAPI.Server ------------------------------------------------------------------------------ import Control.DeepSeq (NFData) +import Control.Lens import Control.Monad.Catch hiding (Handler) import Control.Monad.IO.Class import qualified Data.DList as D @@ -24,8 +25,8 @@ import Servant ------------------------------------------------------------------------------ import Chainweb.ChainId -import Chainweb.Mempool.Mempool -import Chainweb.Mempool.RestAPI +import Chainweb.Pact.Mempool.Mempool +import Chainweb.Pact.Mempool.RestAPI import Chainweb.RestAPI.Orphans () import Chainweb.RestAPI.Utils import Chainweb.Utils @@ -110,22 +111,22 @@ handleErrs = flip catchAllSynchronous $ \e -> someMempoolServer :: (Show t) - => ChainwebVersion - -> SomeMempool t + => HasVersion + => SomeMempool t -> SomeServer -someMempoolServer ver (SomeMempool (mempool :: Mempool_ v c t)) - = SomeServer (Proxy @(MempoolApi v c)) (mempoolServer ver mempool) - +someMempoolServer (SomeMempool (mempool :: Mempool_ v c t)) + = SomeServer (Proxy @(MempoolApi v c)) (mempoolServer mempool) someMempoolServers :: (Show t) - => ChainwebVersion -> [(ChainId, MempoolBackend t)] -> SomeServer -someMempoolServers v = mconcat - . fmap (someMempoolServer v . uncurry (someMempoolVal v)) - - -mempoolServer :: Show t => ChainwebVersion -> Mempool_ v c t -> Server (MempoolApi v c) -mempoolServer _v (Mempool_ mempool) = + => HasVersion + => ChainMap (MempoolBackend t) -> SomeServer +someMempoolServers = mconcat + . fmap (someMempoolServer . uncurry someMempoolVal) + . itoList + +mempoolServer :: HasVersion => Show t => Mempool_ v c t -> Server (MempoolApi v c) +mempoolServer (Mempool_ mempool) = insertHandler mempool :<|> memberHandler mempool :<|> lookupHandler mempool diff --git a/src/Chainweb/Pact5/NoCoinbase.hs b/src/Chainweb/Pact/NoCoinbase.hs similarity index 90% rename from src/Chainweb/Pact5/NoCoinbase.hs rename to src/Chainweb/Pact/NoCoinbase.hs index 62e47813f1..185c1ce380 100644 --- a/src/Chainweb/Pact5/NoCoinbase.hs +++ b/src/Chainweb/Pact/NoCoinbase.hs @@ -2,7 +2,7 @@ {-# LANGUAGE ScopedTypeVariables #-} -- | --- Module: Chainweb.Pact5.NoCoinbase +-- Module: Chainweb.Pact.NoCoinbase -- Copyright: Copyright © 2020 Kadena LLC. -- License: MIT -- Maintainer: Lars Kuhtz @@ -10,7 +10,7 @@ -- -- A noop coin base for genesis transactions and testing purposes. -- -module Chainweb.Pact5.NoCoinbase +module Chainweb.Pact.NoCoinbase ( noCoinbase ) where diff --git a/src/Chainweb/Pact/PactService.hs b/src/Chainweb/Pact/PactService.hs index 85ec113f9f..b7db47711e 100644 --- a/src/Chainweb/Pact/PactService.hs +++ b/src/Chainweb/Pact/PactService.hs @@ -1,19 +1,21 @@ {-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE ImportQualifiedPost #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE NumericUnderscores #-} +{-# LANGUAGE OverloadedRecordDot #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} -{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeAbstractions #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ViewPatterns #-} -{-# LANGUAGE DataKinds #-} -- | -- Module: Chainweb.Pact.PactService @@ -26,1190 +28,855 @@ -- module Chainweb.Pact.PactService ( initialPayloadState - , execNewBlock - , execContinueBlock - , execValidateBlock - , execTransactions + , syncToFork + -- , execTransactions , execLocal , execLookupPactTxs , execPreInsertCheckReq - , execBlockTxHistory - , execHistoricalLookup , execReadOnlyReplay - , execSyncToBlock - , runPactService , withPactService , execNewGenesisBlock + , makeEmptyBlock + , getPayloadsForConsensusPayloads ) where -import Control.Concurrent hiding (throwTo) import Control.Concurrent.Async -import Control.Concurrent.STM -import Control.Exception (AsyncException(ThreadKilled)) -import Control.Exception.Safe -import Control.Lens hiding ((:>)) -import Control.Monad -import Control.Monad.Reader -import Control.Monad.State.Strict - -import Data.Either -import Data.Foldable (toList) -import Data.IORef -import qualified Data.HashMap.Strict as HM -import Data.LogMessage -import Data.Maybe -import Data.Monoid -import Data.Text (Text) -import qualified Data.Text as Text -import Data.Vector (Vector) -import qualified Data.Vector as V -import qualified Data.UUID as UUID -import qualified Data.UUID.V4 as UUID - -import System.IO -import System.LogLevel - -import Prelude hiding (lookup) - -import qualified Streaming as Stream -import qualified Streaming.Prelude as Stream - -import qualified Pact.Gas as Pact4 -import Pact.Interpreter(PactDbEnv(..)) -import qualified Pact.JSON.Encode as J -import qualified Pact.Types.Command as Pact4 -import qualified Pact.Types.Hash as Pact4 -import qualified Pact.Types.Runtime as Pact4 hiding (catchesPactError) -import qualified Pact.Types.Pretty as Pact4 - -import qualified Pact.Core.Builtin as Pact5 -import qualified Pact.Core.Persistence as Pact5 -import qualified Pact.Core.Gas as Pact5 -import qualified Pact.Core.Info as Pact5 -import qualified Pact.Core.Command.Types as Pact5 -import qualified Pact.Core.Command.RPC as Pact5 -import qualified Pact.Core.Hash as Pact5 - -import qualified Chainweb.Pact4.TransactionExec as Pact4 -import qualified Chainweb.Pact4.Validations as Pact4 - import Chainweb.BlockHash import Chainweb.BlockHeader -import Chainweb.BlockHeaderDB import Chainweb.BlockHeight +import Chainweb.BlockPayloadHash import Chainweb.ChainId +import Chainweb.Core.Brief +import Chainweb.Counter import Chainweb.Logger -import Chainweb.Mempool.Mempool as Mempool import Chainweb.Miner.Pact - -import Chainweb.Pact.PactService.Pact4.ExecBlock -import qualified Chainweb.Pact4.Backend.ChainwebPactDb as Pact4 -import Chainweb.Pact.Service.PactQueue (PactQueue, getNextRequest) +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 (withTransaction) +import Chainweb.Pact.Mempool.Mempool as Mempool +import Chainweb.Pact.NoCoinbase qualified as Pact +import Chainweb.Pact.PactService.Checkpointer qualified as Checkpointer +import Chainweb.Pact.PactService.ExecBlock +import Chainweb.Pact.PactService.ExecBlock qualified as Pact +import Chainweb.Pact.PactService.Pact4.ExecBlock qualified as Pact4 +import Chainweb.Pact.Payload +import Chainweb.Pact.Payload.PayloadStore +import Chainweb.Pact.Payload.RestAPI +import Chainweb.Pact.Payload.RestAPI.Client +import Chainweb.Pact.Transaction qualified as Pact +import Chainweb.Pact.TransactionExec qualified as Pact import Chainweb.Pact.Types -import Chainweb.Pact4.SPV qualified as Pact4 -import Chainweb.Pact5.SPV qualified as Pact5 -import Chainweb.Payload -import Chainweb.Payload.PayloadStore +import Chainweb.Pact.Validations qualified as Pact +import Chainweb.Pact4.Backend.ChainwebPactDb qualified as Pact4 +import Chainweb.Parent +import Chainweb.PayloadProvider +import Chainweb.PayloadProvider.P2P +import Chainweb.Ranked +import Chainweb.Storage.Table +import Chainweb.Storage.Table.Map qualified as MapTable import Chainweb.Time -import qualified Chainweb.Pact4.Transaction as Pact4 -import Chainweb.TreeDB import Chainweb.Utils hiding (check) import Chainweb.Version -import Chainweb.Version.Guards -import Utils.Logging.Trace -import Chainweb.Counter -import Data.Time.Clock -import Text.Printf -import Data.Time.Format.ISO8601 -import qualified Chainweb.Pact.PactService.Pact4.ExecBlock as Pact4 -import qualified Chainweb.Pact4.Types as Pact4 -import qualified Chainweb.Pact5.Backend.ChainwebPactDb as Pact5 -import qualified Data.ByteString.Short as SB +import Chainweb.Version.Guards (pact5) +import Control.Concurrent.MVar (newMVar) +import Control.Concurrent.STM +import Control.Exception.Safe (mask) +import Control.Lens hiding ((:>)) +import Control.Monad +import Control.Monad.Cont (evalContT) +import Control.Monad.Except +import Control.Monad.Reader +import Control.Monad.State.Strict +import Control.Monad.Trans.Resource +import Control.Parallel.Strategies qualified as Strategies +import Data.Align +import Data.ByteString.Short qualified as SB import Data.Coerce (coerce) +import Data.DList qualified as DList +import Data.Either +import Data.Foldable (traverse_) +import Data.HashMap.Strict qualified as HM +import Data.List.NonEmpty qualified as NEL +import Data.List.NonEmpty qualified as NonEmpty +import Data.Maybe +import Data.Monoid +import Data.Pool (Pool) +import Data.Pool qualified as Pool +import Data.Text qualified as Text +import Data.Vector (Vector) +import Data.Vector qualified as V import Data.Void -import qualified Chainweb.Pact5.Types as Pact5 -import qualified Chainweb.Pact.PactService.Pact5.ExecBlock as Pact5 -import qualified Pact.Core.Evaluate as Pact5 -import qualified Pact.Core.Names as Pact5 -import Data.Functor.Product -import qualified Chainweb.Pact5.TransactionExec as Pact5 -import qualified Chainweb.Pact5.Transaction as Pact5 -import Control.Monad.Except -import qualified Chainweb.Pact5.NoCoinbase as Pact5 -import qualified Pact.Parse as Pact4 -import qualified Control.Parallel.Strategies as Strategies -import qualified Chainweb.Pact5.Validations as Pact5 -import qualified Pact.Core.Errors as Pact5 -import Chainweb.Pact.Backend.Types -import qualified Chainweb.Pact.PactService.Checkpointer as Checkpointer -import Chainweb.Pact.PactService.Checkpointer (SomeBlockM(..)) -import Control.Monad.Cont (evalContT) -import qualified Data.List.NonEmpty as NonEmpty - - -runPactService - :: Logger logger - => CanReadablePayloadCas tbl - => ChainwebVersion - -> ChainId - -> logger - -> Maybe (Counter "txFailures") - -> PactQueue - -> MemPoolAccess - -> BlockHeaderDb - -> PayloadDb tbl - -> SQLiteEnv - -> PactServiceConfig - -> IO () -runPactService ver cid chainwebLogger txFailuresCounter reqQ mempoolAccess bhDb pdb sqlenv config = - void $ withPactService ver cid chainwebLogger txFailuresCounter bhDb pdb sqlenv config $ do - initialPayloadState ver cid - serviceRequests mempoolAccess reqQ +import GHC.Stack (HasCallStack) +import Network.HTTP.Client qualified as HTTP +import P2P.TaskQueue (Priority(..)) +import Pact.Core.ChainData qualified as Pact +import Pact.Core.Command.RPC qualified as Pact +import Pact.Core.Command.Types qualified as Pact +import Pact.Core.Errors qualified as Pact +import Pact.Core.Evaluate qualified as Pact +import Pact.Core.Gas qualified as Pact +import Pact.Core.Hash qualified as Pact +import Pact.Core.Info qualified as Pact +import Pact.Core.Persistence qualified as Pact +import Pact.JSON.Encode qualified as J +import Prelude hiding (lookup) +import Servant.Client (ClientM) +import System.LogLevel withPactService - :: (Logger logger, CanReadablePayloadCas tbl) - => ChainwebVersion - -> ChainId + :: (Logger logger, CanPayloadCas tbl) + => HasVersion + => ChainId + -> Maybe HTTP.Manager + -> MemPoolAccess -> logger -> Maybe (Counter "txFailures") - -> BlockHeaderDb -> PayloadDb tbl + -> Pool SQLiteEnv -> SQLiteEnv -> PactServiceConfig - -> PactServiceM logger tbl a - -> IO (T2 a PactServiceState) -withPactService ver cid chainwebLogger txFailuresCounter bhDb pdb sqlenv config act = do - Checkpointer.withCheckpointerResources checkpointerLogger (_pactModuleCacheLimit config) sqlenv (_pactPersistIntraBlockWrites config) ver cid $ \checkpointer -> do - let !rs = readRewards - let !pse = PactServiceEnv - { _psMempoolAccess = Nothing - , _psCheckpointer = checkpointer - , _psPdb = pdb - , _psBlockHeaderDb = bhDb - , _psMinerRewards = rs - , _psReorgLimit = _pactReorgLimit config - , _psPreInsertCheckTimeout = _pactPreInsertCheckTimeout config - , _psOnFatalError = defaultOnFatalError (logFunctionText chainwebLogger) - , _psVersion = ver - , _psAllowReadsInLocal = _pactAllowReadsInLocal config - , _psLogger = pactServiceLogger - , _psGasLogger = gasLogger <$ guard (_pactLogGas config) - , _psBlockGasLimit = _pactNewBlockGasLimit config - , _psEnableLocalTimeout = _pactEnableLocalTimeout config - , _psTxFailuresCounter = txFailuresCounter - , _psTxTimeLimit = _pactTxTimeLimit config - } - !pst = PactServiceState mempty - - runPactServiceM pst pse $ do - when (_pactFullHistoryRequired config) $ do - mEarliestBlock <- Checkpointer.getEarliestBlock - case mEarliestBlock of - Nothing -> do - pure () - Just (earliestBlockHeight, _) -> do - let gHeight = genesisHeight ver cid - when (gHeight /= earliestBlockHeight) $ do - let msg = J.object - [ "details" J..= J.object - [ "earliest-block-height" J..= J.number (fromIntegral earliestBlockHeight) - , "genesis-height" J..= J.number (fromIntegral gHeight) - ] - , "message" J..= J.text "Your node has been configured\ - \ to require the full Pact history; however, the full\ - \ history is not available. Perhaps you have compacted\ - \ your Pact state?" - ] - logError_ chainwebLogger (J.encodeText msg) - throwM FullHistoryRequired - { _earliestBlockHeight = earliestBlockHeight - , _genesisHeight = gHeight - } - -- If the latest header that is stored in the checkpointer was on an - -- orphaned fork, there is no way to recover it in the call of - -- 'initalPayloadState.readContracts'. We therefore rewind to the latest - -- avaliable header in the block header database. - -- - Checkpointer.exitOnRewindLimitExceeded $ initializeLatestBlock (_pactUnlimitedInitialRewind config) - act - where - pactServiceLogger = setComponent "pact" chainwebLogger - checkpointerLogger = addLabel ("sub-component", "checkpointer") pactServiceLogger - gasLogger = addLabel ("transaction", "GasLogs") pactServiceLogger + -> GenesisConfig + -> ResourceT IO (ServiceEnv tbl) +withPactService cid http memPoolAccess chainwebLogger txFailuresCounter pdb readSqlPool readWriteSqlenv config pactGenesis = do + payloadStore <- liftIO $ newPayloadStore + http + (logFunction chainwebLogger) + pdb + (\rph -> payloadClient cid (_ranked rph) (Just $ rank rph)) + batchClient + + (_, miningPayloadVar) <- allocate newEmptyTMVarIO + (\v -> do + refresherThread <- fmap (view _1) <$> atomically (tryReadTMVar v) + traverse_ cancel refresherThread + ) -initializeLatestBlock :: (Logger logger) => CanReadablePayloadCas tbl => Bool -> PactServiceM logger tbl () -initializeLatestBlock unlimitedRewind = Checkpointer.findLatestValidBlockHeader' >>= \case - Nothing -> return () - Just b -> Checkpointer.rewindToIncremental initialRewindLimit (ParentHeader b) + liftIO $ withTransaction readWriteSqlenv $ + ChainwebPactDb.initSchema readWriteSqlenv + candidatePdb <- liftIO MapTable.emptyTable + moduleInitCacheVar <- liftIO $ newMVar mempty + + let !pse = ServiceEnv + { _psChainId = cid + -- TODO: PPgaslog + -- , _psGasLogger = undefined <$ guard (_pactLogGas config) + , _psGasLogger = Nothing + , _psReadSqlPool = readSqlPool + , _psReadWriteSql = readWriteSqlenv + , _psPdb = payloadStore + , _psCandidatePdb = candidatePdb + , _psMempoolAccess = memPoolAccess + , _psPreInsertCheckTimeout = _pactPreInsertCheckTimeout config + , _psAllowReadsInLocal = _pactAllowReadsInLocal config + , _psEnableLocalTimeout = _pactEnableLocalTimeout config + , _psTxFailuresCounter = txFailuresCounter + , _psNewPayloadTxTimeLimit = _pactTxTimeLimit config + , _psMiner = _pactMiner config + , _psNewBlockGasLimit = _pactNewBlockGasLimit config + , _psMiningPayloadVar = miningPayloadVar + , _psGenesisPayload = case pactGenesis of + GeneratingGenesis -> Nothing + GenesisPayload p -> Just p + GenesisNotNeeded -> Nothing + , _psBlockRefreshInterval = _pactBlockRefreshInterval config + , _psModuleInitCacheVar = moduleInitCacheVar + } + + case pactGenesis of + GeneratingGenesis -> return () + _ -> liftIO $ initialPayloadState chainwebLogger pse + return pse where - initialRewindLimit = RewindLimit 1000 <$ guard (not unlimitedRewind) + batchClient :: [RankedBlockPayloadHash] -> ClientM [Maybe PayloadData] + batchClient rhs = do + let body = WithHeights + [ (_rankedBlockPayloadHashHeight r, _rankedBlockPayloadHashHash r) + | r <- rhs + ] + rs <- _payloadDataList <$> payloadBatchClient cid body + let rs' = HM.fromList $ (\pd -> (view payloadDataPayloadHash pd, pd)) <$> rs + return $ (\x -> HM.lookup (_rankedBlockPayloadHashHash x) rs') <$> rhs initialPayloadState :: Logger logger - => CanReadablePayloadCas tbl - => ChainwebVersion - -> ChainId - -> PactServiceM logger tbl () -initialPayloadState v cid - | v ^. versionCheats . disablePact = pure () - | otherwise = initializeCoinContract v cid $ - v ^?! versionGenesis . genesisBlockPayload . atChain cid - -initializeCoinContract - :: forall tbl logger. (CanReadablePayloadCas tbl, Logger logger) - => ChainwebVersion - -> ChainId - -> PayloadWithOutputs - -> PactServiceM logger tbl () -initializeCoinContract v cid pwo = do - latestBlock <- Checkpointer.getLatestBlock >>= \case - Nothing -> return Nothing - Just (_, latestHash) -> do - latestHeader <- ParentHeader - <$!> lookupBlockHeader latestHash "initializeCoinContract.findLatestValidBlockHeader" - return $ Just latestHeader - - case latestBlock of - Nothing -> do - logWarnPact "initializeCoinContract: Checkpointer returned no latest block. Starting from genesis." - validateGenesis - Just currentBlockHeader -> - if currentBlockHeader /= ParentHeader genesisHeader - then - unless (pact5 v cid (view (parentHeader . blockHeight . to succ) currentBlockHeader)) $ do - !mc <- Checkpointer.readFrom (Just currentBlockHeader) - (SomeBlockM $ Pair Pact4.readInitModules (error "pact5")) >>= \case - NoHistory -> throwM $ BlockHeaderLookupFailure - $ "initializeCoinContract: internal error: latest block not found: " <> sshow currentBlockHeader - Historical mc -> return mc - Pact4.updateInitCache mc currentBlockHeader - else do - logWarnPact "initializeCoinContract: Starting from genesis." - validateGenesis - where - validateGenesis = void $! - execValidateBlock mempty genesisHeader (CheckablePayloadWithOutputs pwo) + => HasVersion + => CanPayloadCas tbl + => logger + -> ServiceEnv tbl + -> IO () +initialPayloadState logger serviceEnv + -- TODO PP: no more, once we can disable payload providers + | implicitVersion ^. versionCheats . disablePact = pure () + | otherwise = runGenesisIfNeeded logger serviceEnv + +runGenesisIfNeeded + :: forall tbl logger. (CanPayloadCas tbl, Logger logger) + => HasVersion + => logger + -> ServiceEnv tbl + -> IO () +runGenesisIfNeeded logger serviceEnv = do + withTransaction rwSql $ do + latestBlock <- Checkpointer.getLatestBlock rwSql + when (maybe True (isGenesisBlockHeader' cid . Parent . _syncStateBlockHash) latestBlock) $ do + logFunctionText logger Debug "running genesis" + let genesisBlockHash = genesisBlockHeader cid ^. blockHash + let genesisPayloadHash = genesisBlockPayloadHash cid + let gTime = implicitVersion ^?! versionGenesis . genesisTime . atChain cid + let targetSyncState = genesisConsensusState cid + let genesisRankedBlockHash = RankedBlockHash (genesisHeight cid) genesisBlockHash + let evalCtx = genesisEvaluationCtx serviceEnv + let blockCtx = blockCtxOfEvaluationCtx cid evalCtx + let !genesisPayload = case _psGenesisPayload serviceEnv of + Nothing -> error "genesis needs to be run, but the genesis payload is missing!" + Just p -> p + + maybeErr <- runExceptT + $ Checkpointer.restoreAndSave logger cid rwSql (genesisRankedParentBlockHash cid) + $ NEL.singleton + $ ( + if pact5 cid (genesisHeight cid) + then Checkpointer.Pact5RunnableBlock $ \chainwebPactDb -> do + _ <- Pact.execExistingBlock logger serviceEnv + (BlockEnv blockCtx chainwebPactDb) + (CheckablePayloadWithOutputs genesisPayload) + return ((), (genesisBlockHash, genesisPayloadHash)) + else Checkpointer.Pact4RunnableBlock $ \blockDbEnv -> do + _ <- Pact4.execBlock logger serviceEnv + (Pact4.BlockEnv blockCtx blockDbEnv) + (CheckablePayloadWithOutputs genesisPayload) + return ((), (genesisBlockHash, genesisPayloadHash)) + ) + case maybeErr of + Left err -> error $ "genesis block invalid: " <> sshow err + Right () -> do + addNewPayload + (_payloadStoreTable $ _psPdb serviceEnv) + (genesisHeight cid) + genesisPayload + Checkpointer.setConsensusState rwSql targetSyncState + -- we can't produce pact 4 blocks anymore, so don't make + -- payloads if pact 4 is on + when (pact5 cid (succ $ genesisHeight cid)) $ + forM_ (_psMiner serviceEnv) $ \_ -> do + emptyBlock <- (throwIfNoHistory =<<) $ + Checkpointer.readFrom logger cid + (_psReadWriteSql serviceEnv) + (Parent gTime) + (Parent genesisRankedBlockHash) + Checkpointer.PactRead + { pact5Read = \blockEnv blockHandle -> + makeEmptyBlock logger serviceEnv blockEnv blockHandle + , pact4Read = error "Pact 4 cannot make new blocks" + } + -- we have to kick off payload refreshing here first + startPayloadRefresher logger serviceEnv emptyBlock - genesisHeader :: BlockHeader - genesisHeader = genesisBlockHeader v cid + where + rwSql = _psReadWriteSql serviceEnv + cid = _chainId serviceEnv --- | Lookup a block header. --- --- The block header is expected to be either in the block header database or to --- be the the currently stored '_psParentHeader'. The latter addresses the case --- when a block has already been validate with 'execValidateBlock' but isn't (yet) --- available in the block header database. If that's the case two things can --- happen: --- --- 1. the header becomes available before the next 'execValidateBlock' call, or --- 2. the header gets orphaned and the next 'execValidateBlock' call would cause --- a rewind to an ancestor, which is available in the db. +-- | only for use in generating genesis blocks in tools. -- -lookupBlockHeader :: BlockHash -> Text -> PactServiceM logger tbl BlockHeader -lookupBlockHeader bhash ctx = do - bhdb <- view psBlockHeaderDb - liftIO $! lookupM bhdb bhash `catchAllSynchronous` \e -> - throwM $ BlockHeaderLookupFailure $ - "failed lookup of parent header in " <> ctx <> ": " <> sshow e - --- | Loop forever, serving Pact execution requests and reponses from the queues -serviceRequests - :: forall logger tbl. (Logger logger, CanReadablePayloadCas tbl) - => MemPoolAccess - -> PactQueue - -> PactServiceM logger tbl () -serviceRequests memPoolAccess reqQ = go - where - go :: PactServiceM logger tbl () - go = do - PactServiceEnv{_psLogger} <- ask - logDebugPact "serviceRequests: wait" - SubmittedRequestMsg msg statusRef <- liftIO $ getNextRequest reqQ - requestId <- liftIO $ UUID.toText <$> UUID.nextRandom - let - logFn :: LogFunction - logFn = logFunction $ addLabel ("pact-request-id", requestId) _psLogger - logDebugPact $ "serviceRequests: " <> sshow msg - case msg of - CloseMsg -> - tryOne "execClose" statusRef $ return () - LocalMsg (LocalReq localRequest preflight sigVerify rewindDepth) -> do - trace logFn "Chainweb.Pact.PactService.execLocal" () 0 $ - tryOne "execLocal" statusRef $ - execLocal localRequest preflight sigVerify rewindDepth - go - NewBlockMsg NewBlockReq {..} -> do - trace logFn "Chainweb.Pact.PactService.execNewBlock" - () 1 $ - tryOne "execNewBlock" statusRef $ - execNewBlock memPoolAccess _newBlockMiner _newBlockFill _newBlockParent - go - ContinueBlockMsg (ContinueBlockReq bip) -> do - trace logFn "Chainweb.Pact.PactService.execContinueBlock" - () 1 $ - tryOne "execContinueBlock" statusRef $ - execContinueBlock memPoolAccess bip - go - ValidateBlockMsg ValidateBlockReq {..} -> do - tryOne "execValidateBlock" statusRef $ - fmap fst $ trace' logFn "Chainweb.Pact.PactService.execValidateBlock" - (\_ -> _valBlockHeader) - (\(_, g) -> fromIntegral g) - (execValidateBlock memPoolAccess _valBlockHeader _valCheckablePayload) - go - LookupPactTxsMsg (LookupPactTxsReq confDepth txHashes) -> do - trace logFn "Chainweb.Pact.PactService.execLookupPactTxs" () - (length txHashes) $ - tryOne "execLookupPactTxs" statusRef $ - execLookupPactTxs confDepth txHashes - go - PreInsertCheckMsg (PreInsertCheckReq txs) -> do - trace logFn "Chainweb.Pact.PactService.execPreInsertCheckReq" () - (length txs) $ - tryOne "execPreInsertCheckReq" statusRef $ - execPreInsertCheckReq txs - go - BlockTxHistoryMsg (BlockTxHistoryReq bh d) -> do - trace logFn "Chainweb.Pact.PactService.execBlockTxHistory" bh 1 $ - tryOne "execBlockTxHistory" statusRef $ - execBlockTxHistory bh d - go - HistoricalLookupMsg (HistoricalLookupReq bh d k) -> do - trace logFn "Chainweb.Pact.PactService.execHistoricalLookup" bh 1 $ - tryOne "execHistoricalLookup" statusRef $ - execHistoricalLookup bh d k - go - SyncToBlockMsg SyncToBlockReq {..} -> do - trace logFn "Chainweb.Pact.PactService.execSyncToBlock" _syncToBlockHeader 1 $ - tryOne "syncToBlockBlock" statusRef $ - execSyncToBlock _syncToBlockHeader - go - ReadOnlyReplayMsg ReadOnlyReplayReq {..} -> do - trace logFn "Chainweb.Pact.PactService.execReadOnlyReplay" (_readOnlyReplayLowerBound, _readOnlyReplayUpperBound) 1 $ - tryOne "readOnlyReplayBlock" statusRef $ - execReadOnlyReplay _readOnlyReplayLowerBound _readOnlyReplayUpperBound - go - - tryOne - :: forall a. Text - -> TVar (RequestStatus a) - -> PactServiceM logger tbl a - -> PactServiceM logger tbl () - tryOne which statusRef act = - evalPactOnThread - `catches` - [ Handler $ \(e :: SomeException) -> do - logErrorPact $ mconcat - [ "Received exception running pact service (" - , which - , "): " - , sshow e - ] - liftIO $ throwIO e - ] - where - -- here we start a thread to service the request - evalPactOnThread :: PactServiceM logger tbl () - evalPactOnThread = do - maybeException <- withPactState $ \run -> do - goLock <- newEmptyMVar - finishedLock <- newEmptyMVar - -- fork a thread to service the request - bracket - (mask_ $ forkIOWithUnmask $ \restore -> - -- We wrap this whole block in `tryAsync` because we - -- want to ignore `RequestCancelled` exceptions that - -- occur while we are waiting on `takeMVar goLock`. - -- - -- Otherwise we get logs like `chainweb-node: - -- RequestCancelled`. - -- - -- We don't actually care about whether or not - -- `RequestCancelled` was encountered, so we just `void` - -- it. - void $ tryAsync @_ @RequestCancelled $ flip finally (tryPutMVar finishedLock ()) $ do - -- wait until we've been told to start. - -- we don't want to start if the request was cancelled - -- already - takeMVar goLock - - -- run and report the answer. - restore (tryAny (run act)) >>= \case - Left ex -> atomically $ writeTVar statusRef (RequestFailed ex) - Right r -> atomically $ writeTVar statusRef (RequestDone r) - ) - -- if Pact itself is killed, kill the request thread too. - (\tid -> throwTo tid RequestCancelled >> takeMVar finishedLock) - (\_tid -> do - -- check first if the request has been cancelled before - -- starting work on it - beforeStarting <- atomically $ do - readTVar statusRef >>= \case - RequestInProgress -> internalError "request in progress before starting" - RequestDone _ -> internalError "request finished before starting" - RequestFailed e -> return (Left e) - RequestNotStarted -> do - writeTVar statusRef RequestInProgress - return (Right ()) - case beforeStarting of - -- the request has already been cancelled, don't - -- start work on it. - Left ex -> return (Left ex) - Right () -> do - -- let the request thread start working - putMVar goLock () - -- wait until the request thread has finished - atomically $ readTVar statusRef >>= \case - RequestInProgress -> retry - RequestDone _ -> return (Right ()) - RequestFailed e -> return (Left e) - RequestNotStarted -> internalError "request not started after starting" - ) - case maybeException of - Left (fromException -> Just AsyncCancelled) -> do - logDebugPact "Pact action was cancelled" - Left (fromException -> Just ThreadKilled) -> do - logWarnPact "Pact action thread was killed" - Left (exn :: SomeException) -> do - logErrorPact $ mconcat - [ "Received exception running pact service (" - , which - , "): " - , sshow exn - ] - Right () -> return () - -execNewBlock - :: forall logger tbl. (Logger logger, CanReadablePayloadCas tbl) - => MemPoolAccess - -> Miner - -> NewBlockFill - -> ParentHeader - -> PactServiceM logger tbl (Historical (ForSomePactVersion BlockInProgress)) -execNewBlock mpAccess miner fill newBlockParent = pactLabel "execNewBlock" $ do - let pHeight = view blockHeight $ _parentHeader newBlockParent - let pHash = view blockHash $ _parentHeader newBlockParent - logInfoPact $ "(parent height = " <> sshow pHeight <> ")" - <> " (parent hash = " <> sshow pHash <> ")" - blockGasLimit <- view psBlockGasLimit - v <- view chainwebVersion - cid <- view chainId - Checkpointer.readFrom (Just newBlockParent) $ - -- TODO: after the Pact 5 fork is complete, the Pact 4 case below will - -- be unnecessary; the genesis blocks are already handled by 'execNewGenesisBlock'. - SomeBlockM $ Pair - (do - blockDbEnv <- view psBlockDbEnv - initCache <- initModuleCacheForBlock - coinbaseOutput <- Pact4.runCoinbase - miner - (Pact4.EnforceCoinbaseFailure True) (Pact4.CoinbaseUsePrecompiled True) - initCache - let pactDb = Pact4._cpPactDbEnv blockDbEnv - finalBlockState <- fmap Pact4._benvBlockState - $ liftIO - $ readMVar - $ pdPactDbVar - $ pactDb - let blockInProgress = BlockInProgress - { _blockInProgressModuleCache = Pact4ModuleCache initCache - -- ^ we do not use the module cache populated by coinbase in - -- subsequent transactions - , _blockInProgressHandle = BlockHandle (Pact4._bsTxId finalBlockState) (Pact4._bsPendingBlock finalBlockState) - , _blockInProgressParentHeader = Just newBlockParent - , _blockInProgressRemainingGasLimit = blockGasLimit +execNewGenesisBlock + :: (Logger logger, CanReadablePayloadCas tbl) + => HasCallStack + => HasVersion + => logger + -> ServiceEnv tbl + -> Vector Pact.Transaction + -> IO PayloadWithOutputs +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 + (genesisRankedParentBlockHash cid) + Checkpointer.PactRead + { pact5Read = \blockEnv startHandle -> do + + -- we don't do coinbase for genesis either + let bipStart = BlockInProgress + { _blockInProgressHandle = startHandle + , _blockInProgressNumber = 0 + -- fake gas limit, gas is free for genesis + , _blockInProgressRemainingGasLimit = Pact.GasLimit (Pact.Gas 999_999_999) , _blockInProgressTransactions = Transactions - { _transactionCoinbase = coinbaseOutput + { _transactionCoinbase = absurd <$> Pact.noCoinbase , _transactionPairs = mempty } - , _blockInProgressMiner = miner - , _blockInProgressPactVersion = Pact4T - , _blockInProgressChainwebVersion = v - , _blockInProgressChainId = cid + , _blockInProgressBlockCtx = _psBlockCtx blockEnv } - case fill of - NewBlockFill -> ForPact4 <$> Pact4.continueBlock mpAccess blockInProgress - NewBlockEmpty -> return (ForPact4 blockInProgress) - ) - (do - coinbaseOutput <- Pact5.runCoinbase miner >>= \case - Left coinbaseError -> internalError $ "Error during coinbase: " <> sshow coinbaseError - Right coinbaseOutput -> - -- pretend that coinbase can throw an error, when we know it can't. - -- perhaps we can make the Transactions express this, may not be worth it. - return $ coinbaseOutput & Pact5.crResult . Pact5._PactResultErr %~ absurd - hndl <- use Pact5.pbBlockHandle - let blockInProgress = BlockInProgress - { _blockInProgressModuleCache = Pact5NoModuleCache - , _blockInProgressHandle = hndl - , _blockInProgressParentHeader = Just newBlockParent - , _blockInProgressRemainingGasLimit = blockGasLimit - , _blockInProgressTransactions = Transactions - { _transactionCoinbase = coinbaseOutput - , _transactionPairs = mempty + let fakeMempoolServiceEnv = serviceEnv + & psMempoolAccess .~ mempty + { mpaGetBlock = \bf pbc evalCtx -> do + if _bfCount bf == 0 + then do + maybeInvalidTxs <- pbc evalCtx newTrans + validTxs <- case partitionEithers (V.toList maybeInvalidTxs) of + ([], validTxs) -> return validTxs + (errs, _) -> error $ "Pact 5 genesis commands invalid: " <> sshow errs + V.fromList validTxs `Strategies.usingIO` traverse Strategies.rseq + else do + return V.empty } - , _blockInProgressMiner = miner - , _blockInProgressPactVersion = Pact5T - , _blockInProgressChainwebVersion = v - , _blockInProgressChainId = cid - } - case fill of - NewBlockFill -> ForPact5 <$> Pact5.continueBlock mpAccess blockInProgress - NewBlockEmpty -> return (ForPact5 blockInProgress) - ) - -execContinueBlock - :: forall logger tbl pv. (Logger logger, CanReadablePayloadCas tbl) - => MemPoolAccess - -> BlockInProgress pv - -> PactServiceM logger tbl (Historical (BlockInProgress pv)) -execContinueBlock mpAccess blockInProgress = pactLabel "execNewBlock" $ do - Checkpointer.readFrom newBlockParent $ - case _blockInProgressPactVersion blockInProgress of - -- TODO: after the Pact 5 fork is complete, the Pact 4 case below will - -- be unnecessary; the genesis blocks are already handled by 'execNewGenesisBlock'. - Pact4T -> SomeBlockM $ Pair (Pact4.continueBlock mpAccess blockInProgress) (error "pact5") - Pact5T -> SomeBlockM $ Pair (error "pact4") (Pact5.continueBlock mpAccess blockInProgress) - where - newBlockParent = _blockInProgressParentHeader blockInProgress - --- | only for use in generating genesis blocks in tools. --- -execNewGenesisBlock - :: (Logger logger, CanReadablePayloadCas tbl) - => Miner - -> Vector Pact4.UnparsedTransaction - -> PactServiceM logger tbl PayloadWithOutputs -execNewGenesisBlock miner newTrans = pactLabel "execNewGenesisBlock" $ do - historicalBlock <- Checkpointer.readFrom Nothing $ SomeBlockM $ Pair - (do - logger <- view (psServiceEnv . psLogger) - v <- view chainwebVersion - cid <- view chainId - txs <- liftIO $ traverse (runExceptT . Pact4.checkParse logger v cid (genesisBlockHeight v cid)) newTrans - parsedTxs <- case partitionEithers (V.toList txs) of - ([], validTxs) -> return (V.fromList validTxs) - (errs, _) -> internalError $ "Invalid genesis txs: " <> sshow errs - -- NEW GENESIS COINBASE: Reject bad coinbase, use date rule for precompilation - results <- - Pact4.execTransactions miner parsedTxs - (Pact4.EnforceCoinbaseFailure True) - (Pact4.CoinbaseUsePrecompiled False) Nothing Nothing - >>= throwCommandInvalidError - return $! toPayloadWithOutputs Pact4T miner results - ) - (do - v <- view chainwebVersion - cid <- view chainId - let mempoolAccess = mempty - { mpaGetBlock = \bf pbc bh bhash _bheader -> do - if _bfCount bf == 0 - then do - maybeInvalidTxs <- pbc bh bhash newTrans - validTxs <- case partitionEithers (V.toList maybeInvalidTxs) of - ([], validTxs) -> return validTxs - (errs, _) -> throwM $ Pact5GenesisCommandsInvalid errs - V.fromList validTxs `Strategies.usingIO` traverse Strategies.rseq - else do - return V.empty - } - startHandle <- use Pact5.pbBlockHandle - let bipStart = BlockInProgress - { _blockInProgressHandle = startHandle - , _blockInProgressMiner = miner - , _blockInProgressModuleCache = Pact5NoModuleCache - , _blockInProgressPactVersion = Pact5T - , _blockInProgressParentHeader = Nothing - , _blockInProgressChainwebVersion = v - , _blockInProgressChainId = cid - -- fake gas limit, gas is free for genesis - , _blockInProgressRemainingGasLimit = GasLimit (Pact4.ParsedInteger 999_999_999) - , _blockInProgressTransactions = Transactions - { _transactionCoinbase = absurd <$> Pact5.noCoinbase - , _transactionPairs = mempty - } - } - results <- Pact5.continueBlock mempoolAccess bipStart - return $! finalizeBlock results - ) + & psMiner .~ Just noMiner + + results <- Pact.continueBlock logger fakeMempoolServiceEnv (_psBlockDbEnv blockEnv) bipStart + let !pwo = toPayloadWithOutputs + noMiner + (_blockInProgressTransactions results) + return pwo + , pact4Read = error "cannot make new Pact 4 genesis blocks" + } case historicalBlock of - NoHistory -> internalError "PactService.execNewGenesisBlock: Impossible error, unable to rewind before genesis" + NoHistory -> error "PactService.execNewGenesisBlock: Impossible error, unable to rewind before genesis" Historical block -> return block execReadOnlyReplay :: forall logger tbl . (Logger logger, CanReadablePayloadCas tbl) - => BlockHeader - -> Maybe BlockHeader - -> PactServiceM logger tbl () -execReadOnlyReplay lowerBound maybeUpperBound = pactLabel "execReadOnlyReplay" $ do - ParentHeader cur <- Checkpointer.findLatestValidBlockHeader - logger <- view psLogger - bhdb <- view psBlockHeaderDb - pdb <- view psPdb - v <- view chainwebVersion - cid <- view chainId - -- lower bound must be an ancestor of upper. - upperBound <- case maybeUpperBound of - Just upperBound -> do - liftIO (ancestorOf bhdb (view blockHash lowerBound) (view blockHash upperBound)) >>= - flip unless (internalError "lower bound is not an ancestor of upper bound") - - -- upper bound must be an ancestor of latest header. - liftIO (ancestorOf bhdb (view blockHash upperBound) (view blockHash cur)) >>= - flip unless (internalError "upper bound is not an ancestor of latest header") - - return upperBound - Nothing -> do - liftIO (ancestorOf bhdb (view blockHash lowerBound) (view blockHash cur)) >>= - flip unless (internalError "lower bound is not an ancestor of latest header") - - return cur - liftIO $ logFunctionText logger Info $ "pact db replaying between blocks " - <> sshow (view blockHeight lowerBound, view blockHash lowerBound) <> " and " - <> sshow (view blockHeight upperBound, view blockHash upperBound) - - let genHeight = genesisHeight v cid - -- we don't want to replay the genesis header in here. - let lowerHeight = max (succ genHeight) (view blockHeight lowerBound) - withPactState $ \runPact -> - liftIO $ getBranchIncreasing bhdb upperBound (int lowerHeight) $ \blocks -> do - heightRef <- newIORef lowerHeight - withAsync (heightProgress lowerHeight (view blockHeight upperBound) heightRef (logInfo_ logger)) $ \_ -> do - blocks - & Stream.hoist liftIO - & play bhdb pdb heightRef runPact - where - - play - :: CanReadablePayloadCas tbl - => BlockHeaderDb - -> PayloadDb tbl - -> IORef BlockHeight - -> (forall a. PactServiceM logger tbl a -> IO a) - -> Stream.Stream (Stream.Of BlockHeader) IO r - -> IO r - play bhdb pdb heightRef runPact blocks = do - logger <- runPact $ view psLogger - validationFailedRef <- newIORef False - r <- blocks & Stream.mapM_ (\bh -> do - bhParent <- liftIO $ lookupParentM GenesisParentThrow bhdb bh - let - printValidationError (BlockValidationFailure (BlockValidationFailureMsg m)) = do - writeIORef validationFailedRef True - logFunctionText logger Error m - printValidationError e = throwM e - handleMissingBlock NoHistory = throwM $ BlockHeaderLookupFailure $ - "execReadOnlyReplay: missing block: " <> sshow bh - handleMissingBlock (Historical ()) = return () + => HasVersion + => logger + -> ServiceEnv tbl + -> [EvaluationCtx BlockPayloadHash] + -> IO [BlockInvalidError] +execReadOnlyReplay logger serviceEnv blocks = do + let readSqlPool = view psReadSqlPool serviceEnv + let cid = view chainId serviceEnv + let pdb = view psPdb serviceEnv + blocks + & mapM (\evalCtx -> do payload <- liftIO $ fromJuste <$> - lookupPayloadWithHeight pdb (Just $ view blockHeight bh) (view blockPayloadHash bh) + lookupPayloadWithHeight (_payloadStoreTable pdb) (Just $ _evaluationCtxCurrentHeight evalCtx) (_evaluationCtxPayload evalCtx) let isPayloadEmpty = V.null (_payloadWithOutputsTransactions payload) - let isUpgradeBlock = isJust $ _chainwebVersion bhdb ^? versionUpgrades . atChain (_chainId bhdb) . ix (view blockHeight bh) - liftIO $ writeIORef heightRef (view blockHeight bh) - unless (isPayloadEmpty && not isUpgradeBlock) - $ handle printValidationError - $ (handleMissingBlock =<<) - $ runPact - $ Checkpointer.readFrom (Just $ ParentHeader bhParent) $ - SomeBlockM $ Pair - (void $ Pact4.execBlock bh (CheckablePayloadWithOutputs payload)) - (void $ Pact5.execExistingBlock bh (CheckablePayloadWithOutputs payload)) + let isUpgradeBlock = isJust $ implicitVersion ^? versionUpgrades . atChain cid . ix (_evaluationCtxCurrentHeight evalCtx) + if isPayloadEmpty && not isUpgradeBlock + then Pool.withResource readSqlPool $ \sql -> withTransaction sql $ do + hist <- Checkpointer.readFrom + logger + cid + sql + (_evaluationCtxParentCreationTime evalCtx) + (_evaluationCtxRankedParentHash evalCtx) + Checkpointer.PactRead + { pact5Read = \blockEnv blockHandle -> + runExceptT $ flip evalStateT blockHandle $ + void $ Pact.execExistingBlock logger serviceEnv blockEnv (CheckablePayloadWithOutputs payload) + , pact4Read = \blockEnv -> + runExceptT $ + void $ Pact4.execBlock logger serviceEnv blockEnv (CheckablePayloadWithOutputs payload) + } + either Just (\_ -> Nothing) <$> throwIfNoHistory hist + else + return Nothing ) - validationFailed <- readIORef validationFailedRef - when validationFailed $ - throwM $ BlockValidationFailure $ BlockValidationFailureMsg "Prior block validation errors" - return r - - heightProgress :: BlockHeight -> BlockHeight -> IORef BlockHeight -> (Text -> IO ()) -> IO () - heightProgress initialHeight endHeight ref logFun = do - heightAndRateRef <- newIORef (initialHeight, 0.0 :: Double) - let delayMicros = 20_000_000 - liftIO $ threadDelay (delayMicros `div` 2) - forever $ do - liftIO $ threadDelay delayMicros - (lastHeight, oldRate) <- readIORef heightAndRateRef - now' <- getCurrentTime - currentHeight <- readIORef ref - let blocksPerSecond - = 0.8 - * oldRate - + 0.2 - * fromIntegral (currentHeight - lastHeight) - / (fromIntegral delayMicros / 1_000_000) - writeIORef heightAndRateRef (currentHeight, blocksPerSecond) - let est = - flip addUTCTime now' - $ realToFrac @Double @NominalDiffTime - $ fromIntegral @BlockHeight @Double - (endHeight - initialHeight) - / blocksPerSecond - logFun - $ Text.pack $ printf "height: %d | rate: %.1f blocks/sec | est. %s" - (fromIntegral @BlockHeight @Int $ currentHeight - initialHeight) - blocksPerSecond - (formatShow iso8601Format est) + & fmap catMaybes execLocal :: (Logger logger, CanReadablePayloadCas tbl) - => Pact4.UnparsedTransaction + => HasVersion + => logger + -> ServiceEnv tbl + -> Pact.Transaction -> Maybe LocalPreflightSimulation -- ^ preflight flag -> Maybe LocalSignatureVerification -- ^ turn off signature verification checks? -> Maybe RewindDepth -- ^ rewind depth - -> PactServiceM logger tbl LocalResult -execLocal cwtx preflight sigVerify rdepth = pactLabel "execLocal" $ do - - e@PactServiceEnv{..} <- ask - - let !cmd = Pact4.payloadObj <$> cwtx - !pm = Pact4.publicMetaOf cmd - !v = _chainwebVersion e - !cid = _chainId e - - bhdb <- view psBlockHeaderDb - - -- when no depth is defined, treat - -- withCheckpointerRewind as readFrom - -- (i.e. setting rewind to 0). - let rewindDepth = maybe 0 _rewindDepth rdepth - - let timeoutLimit - | _psEnableLocalTimeout = Just (2 * 1_000_000) - | otherwise = Nothing - - let localPact4 = do - pc <- view psParentHeader - let spv = Pact4.pactSPV bhdb (_parentHeader pc) - ctx <- Pact4.getTxContext noMiner pm - let bh = Pact4.ctxCurrentBlockHeight ctx - let gasModel = Pact4.getGasModel ctx - mc <- Pact4.getInitCache - dbEnv <- Pact4._cpPactDbEnv <$> view psBlockDbEnv - logger <- view (psServiceEnv . psLogger) - - evalContT $ withEarlyReturn $ \earlyReturn -> do - pact4Cwtx <- liftIO (runExceptT (Pact4.checkParse logger v cid bh cwtx)) >>= \case - Left err -> earlyReturn $ - let - parseError = Pact4.CommandResult - { _crReqKey = Pact4.cmdToRequestKey cmd - , _crTxId = Nothing - , _crResult = Pact4.PactResult (Left (Pact4.PactError Pact4.SyntaxError Pact4.noInfo [] (sshow err))) - , _crGas = cmd ^. Pact4.cmdPayload . Pact4.pMeta . Pact4.pmGasLimit . to int - , _crLogs = Nothing - , _crContinuation = Nothing - , _crMetaData = Nothing - , _crEvents = [] - } - in case preflight of - Just PreflightSimulation -> Pact4LocalResultWithWarns parseError [] - _ -> Pact4LocalResultLegacy parseError - Right pact4Cwtx -> return pact4Cwtx - case (preflight, sigVerify) of - (_, Just NoVerify) -> do - let payloadBS = SB.fromShort (Pact4._cmdPayload $ Pact4.payloadBytes <$> cwtx) - let validated = Pact4.verifyHash @'Pact4.Blake2b_256 (Pact4._cmdHash cmd) payloadBS - case validated of - Left err -> earlyReturn $ review _MetadataValidationFailure $ NonEmpty.singleton $ Text.pack err - Right _ -> return () - _ -> do - let validated = Pact4.assertCommand pact4Cwtx (validPPKSchemes v cid bh) (isWebAuthnPrefixLegal v cid bh) - case validated of - Left err -> earlyReturn $ review _MetadataValidationFailure (pure $ displayAssertCommandError err) - Right () -> return () - - -- - -- if the ?preflight query parameter is set to True, we run the `applyCmd` workflow - -- otherwise, we prefer the old (default) behavior. When no preflight flag is - -- specified, we run the old behavior. When it is set to true, we also do metadata - -- validations. - -- - case preflight of - Just PreflightSimulation -> do - lift (Pact4.liftPactServiceM (Pact4.assertPreflightMetadata cmd ctx sigVerify)) >>= \case - Left err -> earlyReturn $ review _MetadataValidationFailure err - Right () -> return () - let initialGas = Pact4.initialGasOf $ Pact4._cmdPayload pact4Cwtx - T3 cr _mc warns <- liftIO $ Pact4.applyCmd - _psVersion _psLogger _psGasLogger Nothing dbEnv - noMiner gasModel ctx (TxBlockIdx 0) spv (Pact4.payloadObj <$> pact4Cwtx) - initialGas mc ApplyLocal - - let cr' = hashPact4TxLogs cr - warns' = Pact4.renderCompactText <$> toList warns - pure $ Pact4LocalResultWithWarns cr' warns' - _ -> liftIO $ do - let execConfig = Pact4.mkExecutionConfig $ - [ Pact4.FlagAllowReadInLocal | _psAllowReadsInLocal ] ++ - Pact4.enablePactEvents' v cid bh ++ - Pact4.enforceKeysetFormats' v cid bh ++ - Pact4.disableReturnRTC v cid bh - - cr <- Pact4.applyLocal - _psLogger _psGasLogger dbEnv - gasModel ctx spv - pact4Cwtx mc execConfig - - let cr' = hashPact4TxLogs cr - pure $ Pact4LocalResultLegacy cr' - - let localPact5 = do - ph <- view psParentHeader - let pact5RequestKey = Pact5.RequestKey (Pact5.Hash $ Pact4.unHash $ Pact4.toUntypedHash $ Pact4._cmdHash cwtx) - evalContT $ withEarlyReturn $ \earlyReturn -> do - pact5Cmd <- case Pact5.parsePact4Command cwtx of - Left (Left errText) -> do - earlyReturn $ Pact5LocalResultLegacy Pact5.CommandResult - { _crReqKey = pact5RequestKey - , _crTxId = Nothing - , _crResult = Pact5.PactResultErr $ - Pact5.pactErrorToOnChainError $ Pact5.PEParseError - (Pact5.ParsingError $ "pact 4/5 parsing compatibility mismatch: " <> errText) - (Pact5.LineInfo 0) - , _crGas = Pact5.Gas $ fromIntegral $ cmd ^. Pact4.cmdPayload . Pact4.pMeta . Pact4.pmGasLimit - , _crLogs = Nothing - , _crContinuation = Nothing - , _crMetaData = Nothing - , _crEvents = [] - } - Left (Right (fmap Pact5.spanInfoToLineInfo -> parseError)) -> - earlyReturn $ Pact5LocalResultLegacy Pact5.CommandResult - { _crReqKey = pact5RequestKey - , _crTxId = Nothing - , _crResult = Pact5.PactResultErr $ - Pact5.pactErrorToOnChainError parseError - , _crGas = Pact5.Gas $ fromIntegral $ cmd ^. Pact4.cmdPayload . Pact4.pMeta . Pact4.pmGasLimit - , _crLogs = Nothing - , _crContinuation = Nothing - , _crMetaData = Nothing - , _crEvents = [] - } - Right pact5Cmd -> return pact5Cmd - - -- this is just one of our metadata validation passes. - -- in preflight, we do another one, which replicates some of this work; - -- TODO: unify preflight, newblock, and validateblock tx metadata validation - case (preflight, sigVerify) of - (_, Just NoVerify) -> do - let payloadBS = SB.fromShort (Pact4._cmdPayload $ Pact4.payloadBytes <$> cwtx) - let validated = Pact5.verifyHash (Pact5._cmdHash pact5Cmd) payloadBS - case validated of - Left err -> earlyReturn $ - review _MetadataValidationFailure $ NonEmpty.singleton $ Text.pack err - Right _ -> return () - _ -> do - let validated = Pact5.assertCommand pact5Cmd - case validated of - Left err -> earlyReturn $ - review _MetadataValidationFailure (pure $ displayAssertCommandError err) - Right () -> return () - - let txCtx = Pact5.TxContext ph noMiner - let spvSupport = Pact5.pactSPV bhdb (_parentHeader ph) - case preflight of - Just PreflightSimulation -> do - -- preflight needs to do additional checks on the metadata - -- to match on-chain tx validation - lift (Pact5.liftPactServiceM (Pact5.assertPreflightMetadata (view Pact5.payloadObj <$> pact5Cmd) txCtx sigVerify)) >>= \case - Left err -> earlyReturn $ review _MetadataValidationFailure err - Right () -> return () - let initialGas = Pact5.initialGasOf v cid (Pact5.ctxCurrentBlockHeight txCtx) (Pact5.ctxParentForkNumber txCtx) pact5Cmd - applyCmdResult <- lift $ Pact5.pactTransaction Nothing (\dbEnv -> - Pact5.applyCmd - _psLogger _psGasLogger dbEnv - txCtx (TxBlockIdx 0) spvSupport initialGas (view Pact5.payloadObj <$> pact5Cmd) - ) - commandResult <- case applyCmdResult of - Left err -> - earlyReturn $ Pact5LocalResultWithWarns Pact5.CommandResult - { _crReqKey = Pact5.RequestKey (Pact5.Hash $ Pact4.unHash $ Pact4.toUntypedHash $ Pact4._cmdHash cwtx) - , _crTxId = Nothing - , _crResult = Pact5.PactResultErr $ - Pact5.PactOnChainError - -- the only legal error type, once chainweaver is really gone, we - -- can use a real error type - (Pact5.ErrorType "EvalError") - (Pact5.mkBoundedText $ prettyPact5GasPurchaseFailure err) - (Pact5.LocatedErrorInfo Pact5.TopLevelErrorOrigin Pact5.noInfo) - , _crGas = Pact5.Gas $ fromIntegral $ cmd ^. Pact4.cmdPayload . Pact4.pMeta . Pact4.pmGasLimit - , _crLogs = Nothing - , _crContinuation = Nothing - , _crMetaData = Nothing - , _crEvents = [] - } - [] - Right commandResult -> return commandResult - let pact5Pm = pact5Cmd ^. Pact5.cmdPayload . Pact5.payloadObj . Pact5.pMeta - let metadata = J.toJsonViaEncode $ Pact5.StableEncoding $ Pact5.ctxToPublicData pact5Pm txCtx - let commandResult' = hashPact5TxLogs $ set Pact5.crMetaData (Just metadata) commandResult - -- TODO: once Pact 5 has warnings, include them here. - pure $ Pact5LocalResultWithWarns - (Pact5.pactErrorToOnChainError <$> commandResult') - [] - _ -> lift $ do - -- default is legacy mode: use applyLocal, don't buy gas, don't do any - -- metadata checks beyond signature and hash checking - cr <- Pact5.pactTransaction Nothing $ \dbEnv -> do - fmap Pact5.pactErrorToOnChainError <$> Pact5.applyLocal _psLogger _psGasLogger dbEnv txCtx spvSupport (view Pact5.payloadObj <$> pact5Cmd) - pure $ Pact5LocalResultLegacy (hashPact5TxLogs cr) - - let doLocal = Checkpointer.readFromNthParent (fromIntegral rewindDepth) - $ SomeBlockM $ Pair localPact4 localPact5 - + -> IO (Historical LocalResult) +execLocal logger serviceEnv cwtx preflight sigVerify rdepth = do case timeoutLimit of Nothing -> doLocal - Just limit -> withPactState $ \run -> timeoutYield limit (run doLocal) >>= \case + Just limit -> timeoutYield limit doLocal >>= \case Just r -> pure r Nothing -> do - logError_ _psLogger $ "Local action timed out for cwtx:\n" <> sshow cwtx - pure $ review _LocalTimeout () - -execSyncToBlock - :: (CanReadablePayloadCas tbl, Logger logger) - => BlockHeader - -> PactServiceM logger tbl () -execSyncToBlock targetHeader = pactLabel "execSyncToBlock" $ do - latestHeader <- Checkpointer.findLatestValidBlockHeader' >>= maybe failNonGenesisOnEmptyDb return - if latestHeader == targetHeader - then do - logInfoPact $ "checkpointer at checkpointer target" - <> ". target height: " <> sshow (view blockHeight latestHeader) - <> "; target hash: " <> blockHashToText (view blockHash latestHeader) - else do - logInfoPact $ "rewind to checkpointer target" - <> ". current height: " <> sshow (view blockHeight latestHeader) - <> "; current hash: " <> blockHashToText (view blockHash latestHeader) - <> "; target height: " <> sshow targetHeight - <> "; target hash: " <> blockHashToText targetHash - Checkpointer.rewindToIncremental Nothing (ParentHeader targetHeader) + logError_ logger $ "Local action timed out for cwtx:\n" <> sshow cwtx + pure $ Historical LocalTimeout where - targetHeight = view blockHeight targetHeader - targetHash = view blockHash targetHeader - failNonGenesisOnEmptyDb = error "impossible: playing non-genesis block to empty DB" - --- | Validate a mined block `(headerToValidate, payloadToValidate). --- Note: The BlockHeader here is the header of the block being validated. --- To do this, we atomically: --- - determine if the block is on a different fork from the checkpointer's --- current latest block, and execute all of the blocks on that fork if so, --- all the way to the parent of the block we're validating. --- - run the Pact transactions in the block. --- - commit the result to the database. --- -execValidateBlock - :: (CanReadablePayloadCas tbl, Logger logger) - => MemPoolAccess - -> BlockHeader - -> CheckablePayload - -> PactServiceM logger tbl (PayloadWithOutputs, Pact4.Gas) -execValidateBlock memPoolAccess headerToValidate payloadToValidate = pactLabel "execValidateBlock" $ do - bhdb <- view psBlockHeaderDb - payloadDb <- view psPdb - v <- view chainwebVersion - cid <- view chainId - RewindLimit reorgLimit <- view psReorgLimit - - -- The parent block header must be available in the block header database. - parentOfHeaderToValidate <- getTarget - - -- Add block-hash to the logs if presented - let logBlockHash = - localLabelPact ("block-hash", blockHashToText (view blockParent headerToValidate)) - - logBlockHash $ do - currHeader <- Checkpointer.findLatestValidBlockHeader' - -- find the common ancestor of the new block and our current block - commonAncestor <- liftIO $ case (currHeader, parentOfHeaderToValidate) of - (Just currHeader', Just ph) -> - Just <$> forkEntry bhdb currHeader' (_parentHeader ph) - _ -> - return Nothing - -- check that we don't exceed the rewind limit. for the purpose - -- of this check, the genesis block and the genesis parent - -- have the same height. - let !currHeight = maybe (genesisHeight v cid) (view blockHeight) currHeader - let !ancestorHeight = maybe (genesisHeight v cid) (view blockHeight) commonAncestor - let !rewindLimitSatisfied = ancestorHeight + fromIntegral reorgLimit >= currHeight - unless rewindLimitSatisfied $ - throwM $ RewindLimitExceeded - (RewindLimit reorgLimit) - currHeader - commonAncestor - -- get all blocks on the fork we're going to play, up to the parent - -- of the block we're validating - let withForkBlockStream kont = case parentOfHeaderToValidate of - Nothing -> - -- we're validating a genesis block, so there are no fork blocks to speak of. - kont (pure ()) - Just (ParentHeader parentHeaderOfHeaderToValidate) -> - let forkStartHeight = maybe (genesisHeight v cid) (succ . view blockHeight) commonAncestor - in getBranchIncreasing bhdb parentHeaderOfHeaderToValidate (fromIntegral forkStartHeight) kont - - ((), results) <- - withPactState $ \runPact -> - withForkBlockStream $ \forkBlockHeaders -> do - - -- given a header for a block in the fork, fetch its payload - -- and run its transactions, validating its hashes - let runForkBlockHeaders = forkBlockHeaders & Stream.map (\forkBh -> do - payload <- liftIO $ lookupPayloadWithHeight payloadDb (Just $ view blockHeight forkBh) (view blockPayloadHash forkBh) >>= \case - Nothing -> internalError - $ "execValidateBlock: lookup of payload failed" - <> ". BlockPayloadHash: " <> encodeToText (view blockPayloadHash forkBh) - <> ". Block: " <> encodeToText (ObjectEncoded forkBh) - Just x -> return $ payloadWithOutputsToPayloadData x - SomeBlockM $ Pair - (void $ Pact4.execBlock forkBh (CheckablePayload payload)) - (void $ Pact5.execExistingBlock forkBh (CheckablePayload payload)) - return ([], forkBh) - ) - - -- run the new block, the one we're validating, and - -- validate its hashes - let runThisBlock = Stream.yield $ SomeBlockM $ Pair - (do - !output <- Pact4.execBlock headerToValidate payloadToValidate - return ([output], headerToValidate) - ) - (do - !(gas, pwo) <- Pact5.execExistingBlock headerToValidate payloadToValidate - return ([(fromIntegral (Pact5._gas gas), pwo)], headerToValidate) - ) - -- here we rewind to the common ancestor block, run the - -- transactions in all of its child blocks until the parent - -- of the block we're validating, then run the block we're - -- validating. - runPact $ Checkpointer.restoreAndSave - (ParentHeader <$> commonAncestor) - (runForkBlockHeaders >> runThisBlock) - let logRewind = - -- we consider a fork of height more than 3 to be notable. - if ancestorHeight + 3 < currHeight - then logWarnPact - else logDebugPact - logRewind $ - "execValidateBlock: rewound " <> sshow (currHeight - ancestorHeight) <> " blocks" - (totalGasUsed, result) <- case results of - [r] -> return r - _ -> internalError "execValidateBlock: wrong number of block results returned from _cpRestoreAndSave." + 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 + let blockCtx = view psBlockCtx blockEnv + let requestKey = Pact.cmdToRequestKey cwtx + evalContT $ withEarlyReturn $ \earlyReturn -> do + -- this is just one of our metadata validation passes. + -- in preflight, we do another one, which replicates some of this work; + -- TODO: unify preflight, newblock, and validateblock tx metadata validation + case (preflight, sigVerify) of + (_, Just NoVerify) -> do + let payloadBS = SB.fromShort (Pact._cmdPayload $ view Pact.payloadBytes <$> cwtx) + case Pact.verifyHash (Pact._cmdHash cwtx) payloadBS of + Left err -> earlyReturn $ + MetadataValidationFailure $ NonEmpty.singleton $ Text.pack err + Right _ -> return () + _ -> do + case Pact.assertCommand cwtx of + Left err -> earlyReturn $ + MetadataValidationFailure (pure $ displayAssertCommandError err) + Right () -> return () + + case preflight of + Just PreflightSimulation -> do + -- preflight needs to do additional checks on the metadata + -- to match on-chain tx validation + case (Pact.assertPreflightMetadata serviceEnv (view Pact.payloadObj <$> cwtx) blockCtx sigVerify) of + Left err -> earlyReturn $ MetadataValidationFailure err + Right () -> return () + let initialGas = Pact.initialGasOf + implicitVersion + (_bctxChainId blockCtx) + (_bctxCurrentBlockHeight blockCtx) + (_bctxParentForkNumber blockCtx) + cwtx + applyCmdResult <- liftIO $ flip evalStateT blockHandle $ doChainwebPactDbTransaction (blockEnv ^. psBlockDbEnv) Nothing (\dbEnv spvSupport -> + Pact.applyCmd + logger gasLogger dbEnv noMiner + blockCtx (TxBlockIdx 0) spvSupport initialGas (view Pact.payloadObj <$> cwtx) + ) + commandResult <- case applyCmdResult of + Left err -> + earlyReturn $ LocalResultWithWarns (Pact.CommandResult + { _crReqKey = requestKey + , _crTxId = Nothing + , _crResult = Pact.PactResultErr $ + txInvalidErrorToOnChainPactError err + , _crGas = + cwtx ^. Pact.cmdPayload . Pact.payloadObj . Pact.pMeta . Pact.pmGasLimit . Pact._GasLimit + , _crLogs = Nothing + , _crContinuation = Nothing + , _crMetaData = Nothing + , _crEvents = [] + }) + [] + Right commandResult -> return commandResult + let pact5Pm = cwtx ^. Pact.cmdPayload . Pact.payloadObj . Pact.pMeta + let metadata = J.toJsonViaEncode $ Pact.StableEncoding $ Pact.ctxToPublicData pact5Pm blockCtx + let commandResult' = hashPactTxLogs $ set Pact.crMetaData (Just metadata) commandResult + -- TODO: once Pact 5 has warnings, include them here. + pure $ LocalResultWithWarns + (Pact.pactErrorToOnChainError <$> commandResult') + [] + _ -> lift $ do + -- default is legacy mode: use applyLocal, don't buy gas, don't do any + -- metadata checks beyond signature and hash checking + cr <- flip evalStateT blockHandle $ doChainwebPactDbTransaction (blockEnv ^. psBlockDbEnv) Nothing $ \dbEnv spvSupport -> do + -- TODO: PPgaslog + fmap Pact.pactErrorToOnChainError <$> Pact.applyLocal logger Nothing dbEnv blockCtx spvSupport (view Pact.payloadObj <$> cwtx) + pure $ LocalResultLegacy $ hashPactTxLogs cr + + gasLogger = view psGasLogger serviceEnv + enableLocalTimeout = view psEnableLocalTimeout serviceEnv + cid = _chainId serviceEnv - -- update mempool - -- - -- Using the parent isn't optimal, since it doesn't delete the txs of - -- `currHeader` from the set of pending tx. The reason for this is that the - -- implementation 'mpaProcessFork' uses the chain database and at this point - -- 'currHeader' is generally not yet available in the database. It would be - -- possible to extract the txs from the result and remove them from the set - -- of pending txs. However, that would add extra complexity and at little - -- gain. - -- - case parentOfHeaderToValidate of - Nothing -> return () - Just (ParentHeader p) -> liftIO $ do - mpaProcessFork memPoolAccess p - mpaSetLastHeader memPoolAccess p + -- when no depth is defined, treat + -- withCheckpointerRewind as readFrom + -- (i.e. setting rewind to 0). + rewindDepth = maybe 0 _rewindDepth rdepth + + timeoutLimit + | enableLocalTimeout = Just (2 * 1_000_000) + | otherwise = Nothing + +makeEmptyBlock + :: forall logger tbl. (Logger logger) + => HasVersion + => logger + -> ServiceEnv tbl + -> BlockEnv + -> BlockHandle + -> IO BlockInProgress +makeEmptyBlock logger serviceEnv blockEnv initialBlockHandle = + flip evalStateT initialBlockHandle $ do + miner <- liftIO getMiner + let blockGasLimit = _psNewBlockGasLimit serviceEnv + coinbaseOutput <- revertStateOnFailure (Pact.runCoinbase logger blockEnv miner) >>= \case + Left coinbaseError -> error $ "Error during coinbase: " <> sshow coinbaseError + Right coinbaseOutput -> + -- pretend that coinbase can throw an error, when we know it can't. + -- perhaps we can make the Transactions express this, may not be worth it. + return $ coinbaseOutput & Pact.crResult . Pact._PactResultErr %~ absurd + hndl <- get + return BlockInProgress + { _blockInProgressHandle = hndl + , _blockInProgressBlockCtx = view psBlockCtx blockEnv + , _blockInProgressRemainingGasLimit = blockGasLimit + , _blockInProgressTransactions = Transactions + { _transactionCoinbase = coinbaseOutput + , _transactionPairs = mempty + } + , _blockInProgressNumber = 0 + } + where + revertStateOnFailure :: Monad m => StateT s (ExceptT e m) a -> StateT s m (Either e a) + revertStateOnFailure s = do + StateT $ \old -> + runExceptT (runStateT s old) <&> f old + where + f old = \case + Left err -> (Left err, old) + Right (success, new) -> (Right success, new) + getMiner :: HasCallStack => IO Miner + getMiner = case _psMiner serviceEnv of + Nothing -> error "Chainweb.Pact.PactService: Mining is disabled, but was invoked. This is a bug in chainweb." + Just miner -> return miner + +syncToFork + :: forall tbl logger + . (CanPayloadCas tbl, Logger logger) + => HasVersion + => logger + -> ServiceEnv tbl + -> Maybe Hints + -> ForkInfo + -> IO ConsensusState +syncToFork logger serviceEnv hints forkInfo = do + (rewoundTxs, validatedTxs, newConsensusState) <- withTransaction sql $ do + pactConsensusState <- Checkpointer.getConsensusState sql + let atTarget = + _syncStateBlockHash (_consensusStateLatest pactConsensusState) == + _latestBlockHash forkInfo._forkInfoTargetState + + if atTarget + then do + -- no work to do at all except set consensus state + -- TODO PP: disallow rewinding final? + logFunctionText logger Debug $ "no work done to move to " <> brief forkInfo._forkInfoTargetState + Checkpointer.setConsensusState sql forkInfo._forkInfoTargetState + return (mempty, mempty, forkInfo._forkInfoTargetState) + else do + -- check if the target is in our history + latestBlockRewindable <- + isJust <$> Checkpointer.lookupBlockHash sql (_latestBlockHash forkInfo._forkInfoTargetState) + + if latestBlockRewindable + then do + -- we just have to rewind and set the final + safe blocks + -- TODO PP: disallow rewinding final? + logFunctionText logger Debug $ "pure rewind to " <> brief forkInfo._forkInfoTargetState + rewoundTxs <- getRewoundTxs (Parent forkInfo._forkInfoTargetState._consensusStateLatest._syncStateHeight) + Checkpointer.rewindTo cid sql (Parent $ _syncStateRankedBlockHash (_consensusStateLatest forkInfo._forkInfoTargetState)) + Checkpointer.setConsensusState sql forkInfo._forkInfoTargetState + return (rewoundTxs, mempty, forkInfo._forkInfoTargetState) + else do + let traceBlockHashesAscending = _forkInfoTraceBlockHashes forkInfo + + logFunctionText logger Debug $ "playing blocks from fork info trace" + <> "; from: " <> brief pactConsensusState + <> "; target: " <> brief (_forkInfoTargetState forkInfo) + <> "; trace: " <> brief traceBlockHashesAscending + + findForkChainAscending (reverse $ zip forkInfo._forkInfoTrace traceBlockHashesAscending) >>= \case - return (result, totalGasUsed) + Nothing -> do + logFunctionText logger Info $ + "impossible to move" + <> "; from: " <> brief pactConsensusState + <> "; target: " <> brief forkInfo._forkInfoTargetState + <> "; trace: " <> brief (align forkInfo._forkInfoTrace traceBlockHashesAscending) + -- error: we have no way to get to the target block. just report + -- our current state and do nothing else. + return (mempty, mempty, pactConsensusState) + + Just forkChainBottomToTop -> do + logFunctionText logger Debug $ "fork chain found: " <> brief forkChainBottomToTop + rewoundTxs <- getRewoundTxs (Parent forkInfo._forkInfoTargetState._consensusStateLatest._syncStateHeight) + -- the happy case: we can find a way to get to the target block + -- look up all of the payloads to see if we've run them before + -- even then we still have to run them, because they aren't in the checkpointer + knownPayloads <- liftIO $ + tableLookupBatch' pdb (each . _2) ((\e -> (e, _evaluationCtxRankedPayloadHash $ fst e)) <$> forkChainBottomToTop) + + let unknownPayloads = NEL.filter (isNothing . snd) knownPayloads + unless (null unknownPayloads) + $ logFunctionText logger Debug $ "unknown blocks in context" + <> "; count: " <> sshow (length unknownPayloads) + <> "; hashes: " <> brief (snd . fst <$> unknownPayloads) + + runnableBlocks <- forM knownPayloads $ \((evalCtx, rankedBHash), maybePayload) -> do + logFunctionText logger Debug $ "running block: " <> brief rankedBHash + payload <- case maybePayload of + -- fetch payload if missing + Nothing -> getPayloadForContext logger serviceEnv hints evalCtx + Just payload -> return payload + let expectedPayloadHash = _consensusPayloadHash $ _evaluationCtxPayload evalCtx + let blockCtx = blockCtxOfEvaluationCtx cid evalCtx + if guardCtx pact5 blockCtx + then + return $ + Checkpointer.Pact5RunnableBlock $ \chainwebPactDb -> do + (_, pwo, validatedTxs) <- + Pact.execExistingBlock logger serviceEnv + (BlockEnv blockCtx chainwebPactDb) + (CheckablePayload expectedPayloadHash payload) + -- add payload immediately after executing the block, because this is when we learn it's valid + liftIO $ addNewPayload + (_payloadStoreTable $ _psPdb serviceEnv) + (_evaluationCtxCurrentHeight evalCtx) + pwo + return $ (DList.singleton validatedTxs, (_ranked rankedBHash, expectedPayloadHash)) + else + return $ + Checkpointer.Pact4RunnableBlock $ \blockDbEnv -> do + (_, pwo) <- + Pact4.execBlock logger serviceEnv + (Pact4.BlockEnv blockCtx blockDbEnv) + (CheckablePayload expectedPayloadHash payload) + -- add payload immediately after executing the block, because this is when we learn it's valid + liftIO $ addNewPayload + (_payloadStoreTable $ _psPdb serviceEnv) + (_evaluationCtxCurrentHeight evalCtx) + pwo + -- don't remove pact 4 txs from the mempool, who cares when we can't make Pact 4 blocks anymore? + return $ (mempty, (_ranked rankedBHash, expectedPayloadHash)) + + runExceptT (Checkpointer.restoreAndSave logger cid sql + (knownPayloads ^. head1 . _1 . _1 . to _evaluationCtxRankedParentHash) + runnableBlocks + ) >>= \case + Left err -> do + logFunctionText logger Error $ "Error in execValidateBlock: " <> sshow err + return (mempty, mempty, pactConsensusState) + Right (DList.toList -> blockResults) -> do + let validatedTxs = msum blockResults + Checkpointer.setConsensusState sql forkInfo._forkInfoTargetState + return (rewoundTxs, validatedTxs, forkInfo._forkInfoTargetState) + + liftIO $ mpaProcessFork memPoolAccess (V.concat rewoundTxs, validatedTxs) + case forkInfo._forkInfoNewBlockCtx of + Just newBlockCtx + | Just _ <- _psMiner serviceEnv + , pact5 cid (_rankedHeight (_latestRankedBlockHash newConsensusState)) + , _syncStateBlockHash (_consensusStateLatest newConsensusState) == + _latestBlockHash forkInfo._forkInfoTargetState -> do + -- if we're at the target block we were sent, and we were + -- told to start mining, we produce an empty block + -- immediately. then we set up a separate thread + -- to add new transactions to the block. + logFunctionText logger Debug "producing new block" + emptyBlock <- + Checkpointer.readFromLatest logger cid sql (_newBlockCtxParentCreationTime newBlockCtx) + $ Checkpointer.readPact5 "Pact 4 cannot make new blocks" $ \blockEnv blockHandle -> + makeEmptyBlock logger serviceEnv blockEnv blockHandle + let payloadVar = view psMiningPayloadVar serviceEnv + + -- cancel payload refresher thread + liftIO $ + atomically (fmap (view _1) <$> tryTakeTMVar payloadVar) + >>= traverse_ cancel + + startPayloadRefresher logger serviceEnv emptyBlock + + _ -> return () + return newConsensusState + where + memPoolAccess = view psMempoolAccess serviceEnv + sql = view psReadWriteSql serviceEnv + pdb = view psPdb serviceEnv + cid = _chainId serviceEnv + + findForkChainAscending + :: Brief p + => [(EvaluationCtx p, RankedBlockHash)] + -> IO (Maybe (NEL.NonEmpty (EvaluationCtx p, RankedBlockHash))) + findForkChainAscending [] = return Nothing + findForkChainAscending (tip:chain) = go [] (tip:chain) + where + go + :: Brief p + => [(EvaluationCtx p, RankedBlockHash)] + -> [(EvaluationCtx p, RankedBlockHash)] + -> IO (Maybe (NEL.NonEmpty (EvaluationCtx p, RankedBlockHash))) + go !acc (tip':chain') = do + -- note that if we see the eval ctx in the checkpointer, + -- that means that the parent block has been evaluated, thus we do + -- include `tip` in the resulting list. + known <- Checkpointer.lookupRankedBlockHash sql (unwrapParent $ _evaluationCtxRankedParentHash $ fst tip') + if known + then do + logFunctionText logger Debug $ "fork point: " <> brief (printable tip') + return $ Just $ tip' NEL.:| acc + -- if we don't know this block, remember it for later as we'll + -- need to execute it on top + else do + logFunctionText logger Debug $ + "block not in checkpointer: " + <> brief (printable tip') + go (tip' : acc) chain' + go _ [] = do + logFunctionText logger Info $ + "no fork point found for chain: " + <> brief (printable <$> (tip:chain)) + return Nothing + printable (a, b) = (a, b) + + -- remember to call this *before* executing the actual rewind, + -- and only alter the mempool *after* the db transaction is done. + getRewoundTxs :: Parent BlockHeight -> IO [Vector Pact.Transaction] + getRewoundTxs rewindTargetHeight = do + rewoundPayloadHashes <- Checkpointer.getPayloadsAfter sql rewindTargetHeight + rewoundPayloads <- lookupPayloadDataWithHeightBatch + (_payloadStoreTable pdb) + [(Just (rank rbph), _ranked rbph) | rbph <- rewoundPayloadHashes] + forM (zip rewoundPayloadHashes rewoundPayloads) $ \case + (rbph, Nothing) -> do + logFunctionText logger Error $ "missing payload in database: " <> brief rbph + return V.empty + (rbph, Just payload) -> case pact5TransactionsFromPayload payload of + Right txs -> do + return txs + Left err -> do + logFunctionText logger Error $ "invalid payload in database (" <> brief rbph <> "): " <> sshow err + return V.empty + +-- | Start a thread that makes fresh payloads periodically +startPayloadRefresher :: Logger logger => HasVersion => logger -> ServiceEnv tbl -> BlockInProgress -> IO () +startPayloadRefresher logger serviceEnv startBlock = + mask $ \restore -> do + refresherThread <- async (restore $ refreshPayloads logger serviceEnv) + atomically $ writeTMVar payloadVar (refresherThread, startBlock) where - getTarget - | isGenesisBlockHeader headerToValidate = return Nothing - | otherwise = Just . ParentHeader - <$> lookupBlockHeader (view blockParent headerToValidate) "execValidateBlock" - -- It is up to the user of pact service to guaranteed that this - -- succeeds. If this fails it usually means that the block - -- header database is corrupted. + payloadVar = _psMiningPayloadVar serviceEnv -execBlockTxHistory +refreshPayloads :: Logger logger - => BlockHeader - -> Pact5.Domain Pact5.RowKey Pact5.RowData Pact5.CoreBuiltin Pact5.Info - -> PactServiceM logger tbl (Historical BlockTxHistory) -execBlockTxHistory bh d = - pactLabel "execBlockTxHistory" $ Checkpointer.getBlockHistory bh d + => HasVersion + => logger + -> ServiceEnv tbl + -> IO () +refreshPayloads logger serviceEnv = do + -- note that if this is empty, we wait; taking from it is the way to make us stop + let logOutraced = + liftIO $ logFunctionText logger Debug "Refresher outraced by new block" + (_, blockInProgress) <- liftIO $ atomically $ readTMVar payloadVar + logFunctionText logger Debug $ + "refreshing payloads for " <> + brief (_bctxParentRankedBlockHash $ _blockInProgressBlockCtx 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 + Historical refreshedBlockInProgress -> do + outraced <- liftIO $ atomically $ do + (_, latestBlockInProgress) <- readTMVar payloadVar + -- the block has been replaced, this is a possible race + if _blockInProgressBlockCtx latestBlockInProgress /= _blockInProgressBlockCtx refreshedBlockInProgress + then return True + else do + writeTMVar payloadVar . (_2 .~ refreshedBlockInProgress) =<< readTMVar payloadVar + return False + if outraced + then logOutraced + else do + approximateThreadDelay (int $ _psBlockRefreshInterval serviceEnv) + refreshPayloads logger serviceEnv + where -execHistoricalLookup - :: Logger logger - => BlockHeader - -> Pact5.Domain Pact5.RowKey Pact5.RowData Pact5.CoreBuiltin Pact5.Info - -> Pact5.RowKey - -> PactServiceM logger tbl (Historical (Maybe (Pact5.TxLog Pact5.RowData))) -execHistoricalLookup bh d k = - pactLabel "execHistoricalLookup" $ Checkpointer.lookupHistorical bh d k + payloadVar = _psMiningPayloadVar serviceEnv + cid = _chainId serviceEnv + +getPayloadForContext + :: CanReadablePayloadCas tbl + => Logger logger + => logger + -> ServiceEnv tbl + -> Maybe Hints + -> EvaluationCtx ConsensusPayload + -> IO PayloadData +getPayloadForContext logger serviceEnv h ctx = do + mapM_ insertPayloadData (_consensusPayloadData $ _evaluationCtxPayload ctx) + + pld <- getPayload + pdb + candPdb + (Priority $ negate $ int $ _evaluationCtxCurrentHeight ctx) + (_hintsOrigin <$> h) + (_evaluationCtxRankedPayloadHash ctx) + tableInsert candPdb rh pld + return pld + where + rh = _evaluationCtxRankedPayloadHash ctx + pdb = view psPdb serviceEnv + candPdb = view psCandidatePdb serviceEnv + + insertPayloadData (EncodedPayloadData epld) = case decodePayloadData epld of + Right pld -> tableInsert candPdb rh pld + Left e -> + logFunctionText logger Warn $ "failed to decode encoded payload from evaluation ctx: " <> sshow e + +getPayloadsForConsensusPayloads + :: CanReadablePayloadCas tbl + => Logger logger + => logger + -> ServiceEnv tbl + -> Maybe Hints + -> [Ranked ConsensusPayload] + -> IO [(RankedBlockPayloadHash, PayloadData)] +getPayloadsForConsensusPayloads logger serviceEnv h cps = do + insertPayloadDataBatch (view psCandidatePdb serviceEnv) + plds <- getPayloads + (view psPdb serviceEnv) + (view psCandidatePdb serviceEnv) + (Priority $ negate $ int $ _rankedHeight $ head cps) + (_hintsOrigin <$> h) + (fmap _consensusPayloadHash <$> cps) + tableInsertBatch (view psCandidatePdb serviceEnv) plds + return plds + where + insertPayloadDataBatch tbl = do + plds <- mapM decodePld cps + tableInsertBatch tbl $ catMaybes plds + + decodePld rcp@(Ranked _ cp) = + case mapM decodePayloadData $ _encodedPayloadData <$> _consensusPayloadData cp of + Right pld -> + return $ (_consensusPayloadHash <$> rcp,) <$> pld + Left e -> do + lf Warn $ "failed to decode encoded payloads from evaluation ctx: " <> sshow e + return Nothing -execPreInsertCheckReq - :: (CanReadablePayloadCas tbl, Logger logger) - => Vector Pact4.UnparsedTransaction - -> PactServiceM logger tbl (Vector (Maybe Mempool.InsertError)) -execPreInsertCheckReq txs = pactLabel "execPreInsertCheckReq" $ do - let requestKeys = V.map Pact4.cmdToRequestKey txs - logInfoPact $ "(request keys = " <> sshow requestKeys <> ")" - psEnv <- ask - psState <- get - logger <- view psLogger - let timeoutLimit = fromIntegral $ (\(Micros n) -> n) $ _psPreInsertCheckTimeout psEnv - let act = Checkpointer.readFromLatest $ SomeBlockM $ Pair - (do - pdb <- view psBlockDbEnv - pc <- view psParentHeader - let - parentTime = ParentCreationTime (view blockCreationTime $ _parentHeader pc) - currHeight = succ $ view blockHeight $ _parentHeader pc - v = _chainwebVersion pc - cid = _chainId pc - liftIO $ forM txs $ \tx -> do - let isGenesis = False - fmap (either Just (\_ -> Nothing)) $ runExceptT $ do - parsedTx <- Pact4.validateRawChainwebTx - logger v cid pdb parentTime currHeight tx - ExceptT $ evalPactServiceM psState psEnv . Pact4.runPactBlockM pc isGenesis pdb - $ attemptBuyGasPact4 noMiner parsedTx - return parsedTx - ) - (do - db <- view psBlockDbEnv - ph <- view psParentHeader - v <- view chainwebVersion - cid <- view chainId - initialBlockHandle <- use Pact5.pbBlockHandle - let - parentTime = ParentCreationTime (view blockCreationTime $ _parentHeader ph) - currHeight = succ $ view blockHeight $ _parentHeader ph - isGenesis = False - 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 - pact5Tx <- mapExceptT liftIO $ Pact5.validateRawChainwebTx - logger v cid db initialBlockHandle parentTime currHeight isGenesis tx - let logger' = addLabel ("transaction", "attemptBuyGas") logger - ExceptT $ Pact5.pactTransaction Nothing $ \pactDb -> runExceptT $ do - let txCtx = Pact5.TxContext ph noMiner - -- Note: `mempty` is fine here for the milligas limit. `buyGas` sets its own limit - -- by necessity - gasEnv <- liftIO $ Pact5.mkTableGasEnv (Pact5.MilliGasLimit mempty) Pact5.GasLogsDisabled - liftIO (Pact5.buyGas logger' gasEnv pactDb txCtx (view Pact5.payloadObj <$> pact5Tx)) >>= \case - Left err -> do - throwError $ InsertErrorBuyGas $ prettyPact5GasPurchaseFailure $ BuyGasError (Pact5.cmdToRequestKey pact5Tx) err - Right (_ :: Pact5.EvalResult) -> return () + lf = logFunctionText logger - -- check if the continuation is continuing a defpact that has already finished - case pact5Tx ^? Pact5.cmdPayload . Pact5.payloadObj . Pact5.pPayload . Pact5._Continuation of - Just contMsg -> do - let pactId = Pact5._cmPactId contMsg - defPactState <- liftIO $ Pact5.ignoreGas (Pact5.LineInfo 0) $ Pact5._pdbRead pactDb Pact5.DDefPacts pactId - let isComplete = defPactState == Just Nothing - when isComplete $ - throwError (InsertErrorDefPactComplete (sshow pactId)) - Nothing -> return () - ) - withPactState $ \run -> - timeoutYield timeoutLimit (run act) >>= \case +execPreInsertCheckReq + :: (Logger logger) + => HasVersion + => logger + -> ServiceEnv tbl + -> Vector Pact.Transaction + -> IO (Vector (Maybe Mempool.InsertError)) +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 = 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 logDebug_ logger $ "Mempool pre-insert check result: " <> sshow r pure r @@ -1220,64 +887,62 @@ execPreInsertCheckReq txs = pactLabel "execPreInsertCheckReq" $ do pure result where - attemptBuyGasPact4 - :: forall logger tbl. (Logger logger) - => Miner - -> Pact4.Transaction - -> Pact4.PactBlockM logger tbl (Either InsertError ()) - attemptBuyGasPact4 miner tx = Pact4.localLabelBlock ("transaction", "attemptBuyGas") $ do - mcache <- Pact4.getInitCache - l <- view (psServiceEnv . psLogger) - do - let cmd = Pact4.payloadObj <$> tx - gasPrice = view Pact4.cmdGasPrice cmd - gasLimit = fromIntegral $ view Pact4.cmdGasLimit cmd - txst = Pact4.TransactionState - { _txCache = mcache - , _txLogs = mempty - , _txGasUsed = 0 - , _txGasId = Nothing - , _txGasModel = Pact4._geGasModel Pact4.freeGasEnv - , _txWarnings = mempty - } - let !nid = Pact4.networkIdOf cmd - let !rk = Pact4.cmdToRequestKey cmd - pd <- Pact4.getTxContext miner (Pact4.publicMetaOf cmd) - bhdb <- view (psServiceEnv . psBlockHeaderDb) - dbEnv <- Pact4._cpPactDbEnv <$> view psBlockDbEnv - spv <- Pact4.pactSPV bhdb . _parentHeader <$> view psParentHeader - let ec = Pact4.mkExecutionConfig $ - [ Pact4.FlagDisableModuleInstall - , Pact4.FlagDisableHistoryInTransactionalMode ] ++ - Pact4.disableReturnRTC (Pact4.ctxVersion pd) (Pact4.ctxChainId pd) (Pact4.ctxCurrentBlockHeight pd) - let buyGasEnv = Pact4.TransactionEnv Pact4.Transactional dbEnv l Nothing (Pact4.ctxToPublicData pd) spv nid gasPrice rk gasLimit ec Nothing Nothing - - cr <- liftIO - $! Pact4.catchesPactError l Pact4.CensorsUnexpectedError - $! Pact4.execTransactionM buyGasEnv txst - $! Pact4.buyGas pd cmd miner - - return $ bimap (InsertErrorBuyGas . sshow) (\_ -> ()) cr + preInsertCheckTimeout = view psPreInsertCheckTimeout serviceEnv + cid = _chainId serviceEnv + timeoutLimit = fromIntegral $ (\(Micros n) -> n) preInsertCheckTimeout + attemptBuyGas + :: BlockEnv + -> Pact.Transaction + -> StateT BlockHandle (ExceptT InsertError IO) () + attemptBuyGas blockEnv tx = do + let logger' = addLabel ("transaction", "attemptBuyGas") logger + let bctx = view psBlockCtx blockEnv + result <- mapStateT liftIO $ doChainwebPactDbTransaction (blockEnv ^. psBlockDbEnv) Nothing $ \pactDb _spv -> do + -- Note: `mempty` is fine here for the milligas limit. `buyGas` sets its own limit + -- by necessity + gasEnv <- Pact.mkTableGasEnv (Pact.MilliGasLimit mempty) Pact.GasLogsDisabled + Pact.buyGas logger' gasEnv pactDb noMiner bctx (view Pact.payloadObj <$> tx) >>= \case + Left err -> pure $ Left $ InsertErrorBuyGas $ Pact._boundedText $ Pact._peMsg $ + txInvalidErrorToOnChainPactError (BuyGasError err) + Right evalResult -> do + let continuation = tx ^? + Pact.cmdPayload . Pact.payloadObj . Pact.pPayload . Pact._Continuation + isComplete <- case continuation of + Nothing -> pure False + Just contMsg -> do + let pactId = Pact._cmPactId contMsg + defPactState <- Pact.ignoreGas (Pact.LineInfo 0) $ + Pact._pdbRead pactDb Pact.DDefPacts pactId + pure $ defPactState == Just Nothing + pure $ case (continuation, isComplete) of + (Just contMsg, True) -> Left $ + InsertErrorDefPactComplete (sshow $ Pact._cmPactId contMsg) + _ -> Right evalResult + case result of + Left err -> throwError err + Right (_ :: Pact.EvalResult) -> return () execLookupPactTxs :: (CanReadablePayloadCas tbl, Logger logger) - => Maybe ConfirmationDepth + => HasVersion + => logger + -> ServiceEnv tbl + -> Maybe ConfirmationDepth -> Vector SB.ShortByteString - -> PactServiceM logger tbl (HM.HashMap SB.ShortByteString (T2 BlockHeight BlockHash)) -execLookupPactTxs confDepth txs = pactLabel "execLookupPactTxs" $ do - if V.null txs then return mempty else go + -> IO (Historical (HM.HashMap SB.ShortByteString (T3 BlockHeight BlockPayloadHash BlockHash))) +execLookupPactTxs logger serviceEnv confDepth txs = do + if V.null txs + then return (Historical mempty) + else do + go =<< liftIO Checkpointer.mkFakeParentCreationTime where - go = Checkpointer.readFromNthParent (maybe 0 (fromIntegral . _confirmationDepth) confDepth) $ - SomeBlockM $ Pair - (do - dbenv <- view psBlockDbEnv - fmap (HM.mapKeys coerce) $ liftIO $ Pact4._cpLookupProcessedTx dbenv (coerce txs) - ) - (do - dbenv <- view psBlockDbEnv - fmap (HM.mapKeys coerce) $ liftIO $ Pact5.lookupPactTransactions dbenv (coerce txs) - ) - -pactLabel :: (Logger logger) => Text -> PactServiceM logger tbl x -> PactServiceM logger tbl x -pactLabel lbl x = localLabelPact ("pact-request", lbl) x + depth = maybe 0 (fromIntegral . _confirmationDepth) confDepth + cid = _chainId serviceEnv + 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 + $ Checkpointer.readPact5 "Pact 4 cannot look up transactions" $ \blockEnv _ -> do + let dbenv = view psBlockDbEnv blockEnv + fmap (HM.mapKeys coerce) $ liftIO $ Pact.lookupPactTransactions dbenv (coerce txs) diff --git a/src/Chainweb/Pact/PactService/Checkpointer.hs b/src/Chainweb/Pact/PactService/Checkpointer.hs index 1fe11e3690..96d3e95a0b 100644 --- a/src/Chainweb/Pact/PactService/Checkpointer.hs +++ b/src/Chainweb/Pact/PactService/Checkpointer.hs @@ -1,21 +1,27 @@ {-# LANGUAGE BangPatterns #-} +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE DerivingVia #-} {-# LANGUAGE EmptyCase #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE ImportQualifiedPost #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiWayIf #-} {-# LANGUAGE NumericUnderscores #-} +{-# LANGUAGE OverloadedRecordDot #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE DerivingVia #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE OverloadedRecordDot #-} -- | -- Module: Chainweb.Pact.PactService.Checkpointer @@ -27,95 +33,78 @@ -- Checkpointer interaction for Pact service. -- module Chainweb.Pact.PactService.Checkpointer - ( readFromLatest + ( mkFakeParentCreationTime + , readFromLatest , readFromNthParent , readFrom , restoreAndSave - , findLatestValidBlockHeader' - , findLatestValidBlockHeader - , exitOnRewindLimitExceeded - , rewindToIncremental - , SomeBlockM(..) + , rewindTo + -- , findLatestValidBlockHeader' + -- , findLatestValidBlockHeader + -- , exitOnRewindLimitExceeded , getEarliestBlock , getLatestBlock - , lookupHistorical - , getBlockHistory - , Internal.withCheckpointerResources + -- , lookupBlock + , lookupRankedBlockHash + , lookupBlockHash + , lookupBlockWithHeight + , getPayloadsAfter + , getConsensusState + , setConsensusState + , RunnableBlock(..) + , PactRead(..) + , readPact5 ) where -import Control.Concurrent -import Control.Concurrent.Async -import Control.Lens hiding ((:>)) +import Control.Lens hiding ((:>), (:<)) import Control.Monad -import Control.Monad.Catch import Control.Monad.Reader -import Control.Monad.State - -import Data.Functor.Product -import Data.IORef import Data.Maybe -import Data.Monoid hiding (Product(..)) -import Data.Text (Text) - +import Data.Monoid hiding (Product (..)) import GHC.Stack - -import qualified Pact.JSON.Encode as J - import Prelude hiding (lookup) - -import Streaming (Stream, Of(..)) -import qualified Streaming as S -import qualified Streaming.Prelude as S - --- internal modules - +import Pact.Core.Persistence.Types qualified as Pact +import Chainweb.BlockCreationTime +import Chainweb.BlockHash import Chainweb.BlockHeader import Chainweb.BlockHeight +import Chainweb.ForkState (pact4ForkNumber) import Chainweb.Logger - -import qualified Chainweb.Pact.PactService.Pact4.ExecBlock as Pact4 -import qualified Chainweb.Pact.PactService.Pact5.ExecBlock as Pact5 +import Chainweb.MinerReward +import Chainweb.Pact.Backend.ChainwebPactDb qualified as ChainwebPactDb +import Chainweb.Pact.Backend.Types +import Chainweb.Pact.Backend.Utils qualified as Backend.Utils import Chainweb.Pact.Types -import Chainweb.Payload -import Chainweb.Payload.PayloadStore -import Chainweb.TreeDB (getBranchIncreasing, forkEntry, lookup, seekAncestor) +import Chainweb.Parent +import Chainweb.PayloadProvider +import Chainweb.Ranked +import Chainweb.Time import Chainweb.Utils hiding (check) import Chainweb.Version -import qualified Chainweb.Pact4.Types as Pact4 -import qualified Chainweb.Pact5.Types as Pact5 import Chainweb.Version.Guards (pact5) -import qualified Chainweb.Pact.PactService.Checkpointer.Internal as Internal -import Chainweb.BlockHash -import qualified Pact.Core.Names as Pact5 -import qualified Pact.Core.Persistence.Types as Pact5 -import qualified Pact.Core.Builtin as Pact5 -import qualified Pact.Core.Evaluate as Pact5 - -exitOnRewindLimitExceeded :: PactServiceM logger tbl a -> PactServiceM logger tbl a -exitOnRewindLimitExceeded = handle $ \case - e@RewindLimitExceeded{..} -> do - killFunction <- asks (\x -> _psOnFatalError x) - liftIO $ killFunction e (J.encodeText $ msg _rewindExceededLimit _rewindExceededLast _rewindExceededTarget) - e -> throwM e - where - msg (RewindLimit limit) lastHeader targetHeader = J.object - [ "details" J..= J.object - [ "limit" J..= J.number (fromIntegral limit) - , "last" J..= fmap (J.text . blockHeaderShortDescription) lastHeader - , "target" J..= fmap (J.text . blockHeaderShortDescription) targetHeader - ] - , "message" J..= J.text "Your node is part of a losing fork longer than your\ - \ reorg-limit, which is a situation that requires manual\ - \ intervention.\ - \ For information on recovering from this, please consult:\ - \ https://github.com/kadena-io/chainweb-node/blob/master/\ - \ docs/RecoveringFromDeepForks.md" - ] - -newtype SomeBlockM logger tbl a = SomeBlockM (Product (Pact4.PactBlockM logger tbl) (Pact5.PactBlockM logger tbl) a) - deriving newtype (Functor, Applicative, Monad) -instance MonadIO (SomeBlockM logger tbl) where - liftIO a = SomeBlockM $ Pair (liftIO a) (liftIO a) +import Control.Exception.Safe (MonadMask) +import Data.List.NonEmpty (NonEmpty) +import Chainweb.Pact.Backend.ChainwebPactDb (lookupRankedBlockHash) +import Control.Monad.State.Strict +import System.LogLevel +import Chainweb.Pact4.Backend.ChainwebPactDb qualified as Pact4 +import Control.Concurrent.MVar +import Pact.Types.Persistence qualified as Pact4 +import Chainweb.Pact.Backend.DbCache (defaultModuleCacheLimit) +import Pact.Interpreter qualified as Pact4 +import Data.ByteString.Short qualified as BS +import Data.Coerce +import Data.HashMap.Strict qualified as HashMap +import Pact.Types.Command qualified as Pact4 +import Pact.Types.Hash qualified as Pact4 +import Data.Foldable1 (foldlMapM1) + +-- readFrom demands to know this context in case it's mining a block. +-- But it's not really used by /local, or polling, so we fabricate it +-- for those users. +mkFakeParentCreationTime :: IO (Parent BlockCreationTime) +mkFakeParentCreationTime = do + Parent . BlockCreationTime <$> getCurrentTimeIntegral -- read-only rewind to the latest block. -- note: because there is a race between getting the latest header @@ -124,297 +113,294 @@ instance MonadIO (SomeBlockM logger tbl) where -- we just keep grabbing the new "latest header" until we succeed. -- note: this function will never rewind before genesis. readFromLatest - :: Logger logger - => SomeBlockM logger tbl a - -> PactServiceM logger tbl a -readFromLatest doRead = readFromNthParent 0 doRead + :: (HasCallStack, HasVersion, Logger logger) + => logger + -> ChainId + -> SQLiteEnv + -> Parent BlockCreationTime + -> PactRead a + -> IO a +readFromLatest logger cid sql parentCreationTime doRead = + readFromNthParent logger cid sql parentCreationTime 0 doRead >>= \case + NoHistory -> error "readFromLatest: failed to grab the latest header, this is a bug in chainweb" + Historical a -> return a -- read-only rewind to the nth parent before the latest block. -- note: this function will never rewind before genesis. readFromNthParent - :: forall logger tbl a - . Logger logger - => Word - -> SomeBlockM logger tbl a - -> PactServiceM logger tbl a -readFromNthParent n doRead = go 0 - where - go :: Int -> PactServiceM logger tbl a - go retryCount = do - bhdb <- view psBlockHeaderDb - ParentHeader latest <- findLatestValidBlockHeader - v <- view chainwebVersion - cid <- view chainId - let parentHeight = - -- guarantees that the subtraction doesn't overflow - -- this will never give us before genesis - fromIntegral $ max (genesisHeight v cid + fromIntegral n) (view blockHeight latest) - fromIntegral n - nthParent <- liftIO $ - seekAncestor bhdb latest parentHeight >>= \case - Nothing -> internalError - $ "readFromNthParent: Failed to lookup nth ancestor, block " <> sshow latest - <> ", depth " <> sshow n - Just nthParentHeader -> - return $ ParentHeader nthParentHeader - readFrom (Just nthParent) doRead >>= \case - -- note: because there is a race between getting the nth header - -- and doing the rewind, there's a chance that the nth header - -- will be unavailable when we do the rewind. in that case - -- we just keep grabbing the new "nth header" until we succeed. - NoHistory - | retryCount < 10 -> - go (retryCount + 1) - | otherwise -> internalError "readFromNthParent: failed after 10 retries" - Historical r -> return r + :: (HasCallStack, HasVersion, Logger logger) + => logger + -> ChainId + -> SQLiteEnv + -> Parent BlockCreationTime + -> Word + -> PactRead a + -> IO (Historical a) +readFromNthParent logger cid sql parentCreationTime n doRead = do + latest <- + fmap (fromMaybe (error "readFromNthParent is illegal to call before genesis")) + $ ChainwebPactDb.throwOnDbError + $ ChainwebPactDb.getLatestBlock 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. readFrom - :: Logger logger - => Maybe ParentHeader - -> SomeBlockM logger tbl a - -> PactServiceM logger tbl (Historical a) -readFrom ph doRead = do - cp <- view psCheckpointer - pactParent <- getPactParent ph - let bh = _parentHeader <$> ph - s <- get - e <- ask - v <- view chainwebVersion - cid <- view chainId - let currentHeight = maybe (genesisHeight v cid) (succ . view blockHeight) bh - let execPact4 act = - liftIO $ Internal.readFrom cp ph Pact4T $ \dbenv _ -> - evalPactServiceM s e $ - Pact4.runPactBlockM pactParent (isNothing ph) dbenv act - let execPact5 act = - liftIO $ Internal.readFrom cp ph Pact5T $ \dbenv blockHandle -> - evalPactServiceM s e $ do - fst <$> Pact5.runPactBlockM pactParent (isNothing ph) dbenv blockHandle act - case doRead of - SomeBlockM (Pair forPact4 forPact5) - | pact5 v cid currentHeight -> execPact5 forPact5 - | otherwise -> execPact4 forPact4 - --- here we cheat, making the genesis block header's parent the genesis --- block header, only for Pact's information, *not* for the checkpointer; --- the checkpointer knows the difference between rewinding to before the --- genesis block and rewinding to just after the genesis block. -getPactParent :: Maybe ParentHeader -> PactServiceM logger tbl ParentHeader -getPactParent ph = do - case ph of - Nothing -> do - bh <- genesisBlockHeader <$> view chainwebVersion <*> view chainId - return (ParentHeader bh) - Just h -> return h - --- play multiple blocks starting at a given parent header. -restoreAndSave - :: (CanReadablePayloadCas tbl, Logger logger, Monoid q) - => Maybe ParentHeader - -> Stream (Of (SomeBlockM logger tbl (q, BlockHeader))) IO r - -> PactServiceM logger tbl (r, q) -restoreAndSave ph blocks = do - cp <- view psCheckpointer - v <- view chainwebVersion - cid <- view chainId - -- the height of the first block in the stream - let firstBlockHeight = case ph of - Nothing -> genesisHeight v cid - Just (ParentHeader bh) -> succ (bh ^. blockHeight) - withPactState $ \runPact -> - Internal.restoreAndSave cp ph - $ blocks & S.zip (S.iterate succ firstBlockHeight) & S.map - (\case - (height, SomeBlockM (Pair pact4Block pact5Block)) - | pact5 v cid height -> - Pact5RunnableBlock $ \dbEnv mph blockHandle -> runPact $ do - pactParent <- getPactParent mph - let isGenesis = isNothing mph - Pact5.runPactBlockM pactParent isGenesis dbEnv blockHandle pact5Block - | otherwise -> - Pact4RunnableBlock $ \dbEnv mph -> runPact $ do - pactParent <- getPactParent mph - let isGenesis = isNothing mph - Pact4.runPactBlockM pactParent isGenesis dbEnv pact4Block - ) - --- | Find the latest block stored in the checkpointer for which the respective --- block header is available in the block header database. A block header may be in --- the checkpointer but not in the block header database during deep catch-up --- or reorgs. Why? It appears to be a race, where a thread's insert into rocksdb --- may not be seen by another thread immediately. --- --- First the result of '_cpGetLatestBlock' is checked. If the respective block --- header isn't available, the function recursively checks the result of --- '_cpGetBlockParent'. --- -findLatestValidBlockHeader' :: (Logger logger) => PactServiceM logger tbl (Maybe BlockHeader) -findLatestValidBlockHeader' = do - cp <- view psCheckpointer - latestInCheckpointer <- liftIO (Internal.getLatestBlock cp.cpSql) - case latestInCheckpointer of - Nothing -> return Nothing - Just (height, hash) -> Just <$> go height hash + :: (HasCallStack, HasVersion, Logger logger) + => logger + -> ChainId + -> SQLiteEnv + -> Parent BlockCreationTime + -- ^ you can fake this if you're not making a new block + -> Parent RankedBlockHash + -> PactRead a + -> IO (Historical a) +readFrom logger cid sql parentCreationTime parent pactRead = do + let blockCtx = BlockCtx + { _bctxParentCreationTime = parentCreationTime + , _bctxParentHash = _rankedBlockHashHash <$> parent + , _bctxParentHeight = _rankedBlockHashHeight <$> parent + , _bctxParentForkNumber = pact4ForkNumber + , _bctxMinerReward = blockMinerReward (childBlockHeight cid parent) + , _bctxChainId = cid + } + !latestHeader <- ChainwebPactDb.throwOnDbError + $ fmap (maybe (genesisRankedParentBlockHash cid) (Parent . _syncStateRankedBlockHash)) + $ ChainwebPactDb.getLatestBlock sql + -- is the parent the latest header, i.e., can we get away without rewinding? + let parentIsLatestHeader = latestHeader == parent + let currentHeight = _bctxCurrentBlockHeight blockCtx + Backend.Utils.getEndTxId cid sql parent >>= traverse \startTxId -> + if pact5 cid currentHeight then do + let + blockHandlerEnv = ChainwebPactDb.BlockHandlerEnv + { ChainwebPactDb._blockHandlerDb = sql + , ChainwebPactDb._blockHandlerLogger = logger + , ChainwebPactDb._blockHandlerChainId = cid + , ChainwebPactDb._blockHandlerBlockHeight = currentHeight + , ChainwebPactDb._blockHandlerMode = Pact.Transactional + , ChainwebPactDb._blockHandlerUpperBoundTxId = startTxId + , ChainwebPactDb._blockHandlerAtTip = parentIsLatestHeader + } + let pactDb = ChainwebPactDb.chainwebPactBlockDb blockHandlerEnv + let blockEnv = BlockEnv blockCtx pactDb + pact5Read pactRead blockEnv (emptyBlockHandle startTxId) + else do + let pact4TxId = Pact4.TxId (coerce startTxId) + let blockHandlerEnv = Pact4.mkBlockHandlerEnv cid currentHeight sql logger + newBlockDbEnv <- liftIO $ newMVar $ Pact4.BlockDbEnv + blockHandlerEnv + -- FIXME not sharing the cache + (Pact4.initBlockState defaultModuleCacheLimit pact4TxId) + let pactDb = Pact4.rewoundPactDb currentHeight pact4TxId + + let pact4DbEnv = Pact4.CurrentBlockDbEnv + { _cpPactDbEnv = Pact4.PactDbEnv pactDb newBlockDbEnv + , _cpRegisterProcessedTx = \hash -> + Pact4.runBlockDbEnv newBlockDbEnv (Pact4.indexPactTransaction $ BS.fromShort $ Pact4.unHash $ Pact4.unRequestKey hash) + , _cpLookupProcessedTx = \hs -> do + res <- Backend.Utils.doLookupSuccessful sql currentHeight (coerce hs) + return + $ HashMap.mapKeys coerce + $ HashMap.map + (\(T3 height _payloadhash bhash) -> T2 height bhash) + res + , _cpHeaderOracle = Pact4.headerOracleForBlock blockHandlerEnv + } + pact4Read pactRead (Pact4.BlockEnv blockCtx pact4DbEnv) + +-- the special case where one doesn't want to extend the chain, just rewind it. +rewindTo + :: HasVersion + => ChainId + -> SQLiteEnv + -> Parent RankedBlockHash + -> IO () +rewindTo cid sql ancestor = do + void $ Backend.Utils.rewindDbTo cid sql ancestor + +data PactRead a + = PactRead + { pact4Read :: (forall logger. HasCallStack => Logger logger => Pact4.BlockEnv logger -> IO a) + , pact5Read :: HasCallStack => BlockEnv -> BlockHandle -> IO a + } + +readPact5 :: String -> (BlockEnv -> BlockHandle -> IO a) -> PactRead a +readPact5 msg act = PactRead + { pact4Read = \_ -> error msg + , pact5Read = act + } + +data RunnableBlock m q + = Pact4RunnableBlock + (forall logger. Logger logger => Pact4.CurrentBlockDbEnv logger -> m (q, (BlockHash, BlockPayloadHash))) + | Pact5RunnableBlock + (ChainwebPactDb -> StateT BlockHandle m (q, (BlockHash, BlockPayloadHash))) + +foldState1 + :: (Monad m, Semigroup a) + => NonEmpty (s -> m (a, s)) + -> s + -> m a +foldState1 bs !initialState = do + fst <$> foldlMapM1 ($ initialState) g bs where - go height hash = do - bhdb <- view psBlockHeaderDb - liftIO (lookup bhdb hash) >>= \case - Nothing -> do - logInfoPact $ "Latest block isn't valid." - <> " Failed to lookup hash " <> sshow (height, hash) <> " in block header db." - <> " Continuing with parent." - cp <- view psCheckpointer - liftIO (Internal.getBlockParent cp.cpCwVersion cp.cpChainId cp.cpSql (height, hash)) >>= \case - Nothing -> internalError - $ "missing block parent of last hash " <> sshow (height, hash) - Just predHash -> go (pred height) predHash - Just x -> return x - -findLatestValidBlockHeader :: (Logger logger) => PactServiceM logger tbl ParentHeader -findLatestValidBlockHeader = do - findLatestValidBlockHeader' >>= - maybe (throwM NoBlockValidatedYet) (return . ParentHeader) - --- -------------------------------------------------------------------------- -- --- Incremental rewindTo - --- | INTERNAL FUNCTION. DON'T USE UNLESS YOU KNOW WHAT YOU DO. --- --- Used for large incremental rewinds during pact history replay. Unlike --- @rewindTo@, this version is not transactional but instead incrementally --- commits the intermediate evaluation state to the pact database. + g (a, s) f = do + (b, s') <- f s + let !c = a <> b + pure (c, s') + +-- TODO: log more? +-- | Given a list of blocks in ascending order, rewind to the first +-- of them and play all of the subsequent blocks, saving the result persistently. +-- this function takes care of making sure that this is done *atomically*. +-- The two following expressions should be equivalent: +-- restoreAndSave cp v cid blocks1 <> restoreAndSave cp v cid blocks2 +-- restoreAndSave cp v cid (blocks1 <> blocks2) -- --- Rewinds the pact state to the given parent header. --- --- If the rewind is deeper than the optionally provided rewind limit, an --- exception is raised. --- -rewindToIncremental - :: forall logger tbl - . (HasCallStack, CanReadablePayloadCas tbl, Logger logger) - => Maybe RewindLimit - -- ^ if set, limit rewinds to this delta - -> ParentHeader - -- ^ The parent header which is the rewind target - -> PactServiceM logger tbl () -rewindToIncremental rewindLimit (ParentHeader parent) = do - - latestHeader <- findLatestValidBlockHeader' >>= maybe failNonGenesisOnEmptyDb return - - failOnTooLowRequestedHeight latestHeader - playFork latestHeader - +-- prerequisites: +-- - the first block's parent must be an ancestor of the latest block in the database. +-- - each subsequent block must be the direct child of the previous block. +restoreAndSave + :: forall logger m q. + (Logger logger, MonadIO m, MonadMask m, Semigroup q, HasCallStack, HasVersion) + => logger + -> ChainId + -> SQLiteEnv + -> Parent RankedBlockHash + -> NonEmpty (RunnableBlock m q) + -> m q +restoreAndSave logger cid sql parent blocks = do + -- TODO PP: check first if we're rewinding past "final" point? same with rewindTo above. + startTxId <- liftIO $ Backend.Utils.rewindDbTo cid sql parent + let startBlockHeight = childBlockHeight cid parent + foldState1 (fmap executeBlock blocks) (T2 startBlockHeight startTxId) where - parentHeight = view blockHeight parent - - - failOnTooLowRequestedHeight lastHeader = case rewindLimit of - Just limit - | let limitHeight = BlockHeight $ _rewindLimit limit - , parentHeight + 1 + limitHeight < lastHeight -> -- need to stick with addition because Word64 - throwM $ RewindLimitExceeded limit (Just lastHeader) (Just parent) - _ -> return () - where - lastHeight = view blockHeight lastHeader - - failNonGenesisOnEmptyDb = error "impossible: playing non-genesis block to empty DB" - - playFork :: BlockHeader -> PactServiceM logger tbl () - playFork lastHeader = do - bhdb <- asks _psBlockHeaderDb - commonAncestor <- liftIO $ forkEntry bhdb lastHeader parent - cp <- view psCheckpointer - payloadDb <- view psPdb - let ancestorHeight = view blockHeight commonAncestor - - logger <- view psLogger - - -- 'getBranchIncreasing' expects an 'IO' callback because it - -- maintains an 'TreeDB' iterator. 'withPactState' allows us to call - -- pact service actions from the callback. - - (_ :> c) <- withPactState $ \runPact -> - getBranchIncreasing bhdb parent (int ancestorHeight) $ \newBlocks -> do - - -- fastforwards all blocks in a chunk in a single database - -- transaction. - -- invariant: when playing a chunk, the checkpointer must - -- already be at `cur`. - let playChunk :: IORef BlockHeight -> BlockHeader -> Stream (Of BlockHeader) IO r -> IO (Of BlockHeader r) - playChunk heightRef cur blockChunk = runPact $ do - (r, Last header) <- restoreAndSave - (Just $ ParentHeader cur) - $ blockChunk & S.map - (\blockHeader -> do - payload <- liftIO $ lookupPayloadWithHeight payloadDb (Just $ view blockHeight blockHeader) (view blockPayloadHash blockHeader) >>= \case - Nothing -> internalError - $ "Checkpointer.rewindTo.fastForward: lookup of payload failed" - <> ". BlockPayloadHash: " <> encodeToText (view blockPayloadHash blockHeader) - <> ". Block: "<> encodeToText (ObjectEncoded blockHeader) - Just x -> return $ payloadWithOutputsToPayloadData x - liftIO $ writeIORef heightRef (view blockHeight blockHeader) - SomeBlockM $ Pair - (void $ Pact4.execBlock blockHeader (CheckablePayload payload)) - (void $ Pact5.execExistingBlock blockHeader (CheckablePayload payload)) - return (Last (Just blockHeader), blockHeader) - ) - - return $! fromJuste header :> r - - -- This stream is guaranteed to at least contain @e@. - (curHdr, remaining) <- fromJuste <$> S.uncons newBlocks - - -- we have to rewind to the current header to start, for - -- playChunk's invariant to be satisfied - Internal.rewindTo cp - (Just $ ParentHeader curHdr) - - heightRef <- newIORef (view blockHeight curHdr) - withAsync (heightProgress (view blockHeight curHdr) heightRef (logInfo_ logger)) $ \_ -> - remaining - & S.copy - & S.length_ - & S.chunksOf 1000 - & foldChunksM (playChunk heightRef) curHdr - - when (c /= 0) $ - logInfoPact $ "rewindTo.playFork: replayed " <> sshow c <> " blocks" - -getEarliestBlock :: PactServiceM logger tbl (Maybe (BlockHeight, BlockHash)) -getEarliestBlock = do - cp <- view psCheckpointer - liftIO $ Internal.getEarliestBlock cp.cpSql - -getLatestBlock :: PactServiceM logger tbl (Maybe (BlockHeight, BlockHash)) -getLatestBlock = do - cp <- view psCheckpointer - liftIO $ Internal.getLatestBlock cp.cpSql - -lookupHistorical - :: BlockHeader - -> Pact5.Domain Pact5.RowKey Pact5.RowData Pact5.CoreBuiltin Pact5.Info - -> Pact5.RowKey - -> PactServiceM logger tbl (Historical (Maybe (Pact5.TxLog Pact5.RowData))) -lookupHistorical blockHeader d k = do - cp <- view psCheckpointer - liftIO $ Internal.lookupHistorical cp.cpSql blockHeader d k -getBlockHistory - :: BlockHeader - -> Pact5.Domain Pact5.RowKey Pact5.RowData Pact5.CoreBuiltin Pact5.Info - -> PactServiceM logger tbl (Historical BlockTxHistory) -getBlockHistory blockHeader d = do - cp <- view psCheckpointer - liftIO $ Internal.getBlockHistory cp.cpSql blockHeader d + executeBlock :: RunnableBlock m q -> T2 BlockHeight Pact.TxId -> m (q, T2 BlockHeight Pact.TxId) + executeBlock blockAction (T2 currentBlockHeight startTxId) = do + case blockAction of + Pact4RunnableBlock block | not (pact5 cid currentBlockHeight) -> do + let pact4TxId = Pact4.TxId (coerce startTxId) + let blockHandlerEnv = Pact4.mkBlockHandlerEnv cid currentBlockHeight sql logger + newBlockDbEnv <- liftIO $ newMVar $ Pact4.BlockDbEnv + blockHandlerEnv + -- FIXME not sharing the cache + (Pact4.initBlockState defaultModuleCacheLimit pact4TxId) + let pactDb = Pact4.chainwebPactDb + + let pact4DbEnv = Pact4.CurrentBlockDbEnv + { _cpPactDbEnv = Pact4.PactDbEnv pactDb newBlockDbEnv + , _cpRegisterProcessedTx = \hash -> + Pact4.runBlockDbEnv newBlockDbEnv (Pact4.indexPactTransaction $ BS.fromShort $ Pact4.unHash $ Pact4.unRequestKey hash) + , _cpLookupProcessedTx = \hs -> do + res <- Backend.Utils.doLookupSuccessful sql currentBlockHeight (coerce hs) + return + $ HashMap.mapKeys coerce + $ HashMap.map + (\(T3 height _payloadhash bhash) -> T2 height bhash) + res + , _cpHeaderOracle = Pact4.headerOracleForBlock blockHandlerEnv + } + !(!m, !blockInfo) <- block pact4DbEnv + -- let outputBlockHandle = + finalBlockState <- liftIO $ + Pact4._benvBlockState <$> readMVar newBlockDbEnv + -- TODO Robert: use payload hash here too + liftIO $ Pact4.commitBlockStateToDatabase sql (fst blockInfo) (snd blockInfo) currentBlockHeight finalBlockState + let currentRbh = RankedBlockHash currentBlockHeight (fst blockInfo) + return + (m + , T2 + (childBlockHeight cid (Parent currentRbh)) + (Pact.TxId $ coerce $ Pact4._bsTxId finalBlockState)) + Pact5RunnableBlock block | pact5 cid currentBlockHeight -> do + let + blockEnv = ChainwebPactDb.BlockHandlerEnv + { ChainwebPactDb._blockHandlerDb = sql + , ChainwebPactDb._blockHandlerLogger = logger + , ChainwebPactDb._blockHandlerBlockHeight = currentBlockHeight + , ChainwebPactDb._blockHandlerChainId = cid + , ChainwebPactDb._blockHandlerMode = Pact.Transactional + , ChainwebPactDb._blockHandlerUpperBoundTxId = startTxId + , ChainwebPactDb._blockHandlerAtTip = True + } + pactDb = ChainwebPactDb.chainwebPactBlockDb blockEnv + -- run the block + !((!m', !blockInfo), !blockHandle) <- + runStateT (block pactDb) (emptyBlockHandle startTxId) + -- TODO PP: also check the child matches the parent height + -- case maybeParent of + -- Nothing + -- | genesisHeight res.cpCwVersion res.cpChainId /= succ (_rankedBlockHashHeight nextBlock) -> error + -- "doRestoreAndSave: block with no parent, genesis block, should have genesis height but doesn't," + -- Just (Parent ph) + -- | bh /= _rankedBlockHashHeight nextBlock -> error $ + -- "doRestoreAndSave: non-genesis block should be one higher than its parent. parent at " + -- <> sshow (_rankedBlockHashHeight ph) <> ", child height " <> sshow (_rankedBlockHashHeight nextBlock) + -- _ -> return () + liftIO $ ChainwebPactDb.commitBlockStateToDatabase + sql + (Ranked currentBlockHeight blockInfo) + blockHandle + let currentRbh = RankedBlockHash currentBlockHeight (fst blockInfo) + return + (m' + , T2 + (childBlockHeight cid (Parent currentRbh)) + (_blockHandleTxId blockHandle)) + + _ -> do + error $ "pact 4/5 mismatch: " <> sshow (cid, currentBlockHeight) + +getEarliestBlock :: SQLiteEnv -> IO (Maybe RankedBlockHash) +getEarliestBlock sql = do + ChainwebPactDb.throwOnDbError $ ChainwebPactDb.getEarliestBlock sql + +getLatestBlock :: SQLiteEnv -> IO (Maybe SyncState) +getLatestBlock sql = do + ChainwebPactDb.throwOnDbError $ Backend.Utils.getLatestBlock sql + +getConsensusState :: SQLiteEnv -> IO ConsensusState +getConsensusState sql = do + ChainwebPactDb.throwOnDbError $ Backend.Utils.getConsensusState sql + +setConsensusState :: SQLiteEnv -> ConsensusState -> IO () +setConsensusState sql cs = do + ChainwebPactDb.throwOnDbError $ Backend.Utils.setConsensusState sql cs + +lookupBlockWithHeight :: HasCallStack => SQLiteEnv -> BlockHeight -> IO (Maybe (Ranked BlockHash)) +lookupBlockWithHeight sql bh = do + ChainwebPactDb.throwOnDbError $ Backend.Utils.lookupBlockWithHeight sql bh + +lookupBlockHash :: HasCallStack => SQLiteEnv -> BlockHash -> IO (Maybe BlockHeight) +lookupBlockHash sql pbh = do + ChainwebPactDb.throwOnDbError $ Backend.Utils.lookupBlockHash sql pbh + +getPayloadsAfter :: SQLiteEnv -> Parent BlockHeight -> IO [Ranked BlockPayloadHash] +getPayloadsAfter sql b = do + ChainwebPactDb.throwOnDbError $ Backend.Utils.getPayloadsAfter sql b -- -------------------------------------------------------------------------- -- -- Utils -heightProgress :: BlockHeight -> IORef BlockHeight -> (Text -> IO ()) -> IO () -heightProgress initialHeight ref logFun = forever $ do - threadDelay (20 * 1_000_000) - h <- readIORef ref - logFun - $ "processed blocks: " <> sshow (h - initialHeight) - <> ", current height: " <> sshow h +-- heightProgress :: BlockHeight -> IORef BlockHeight -> (Text -> IO ()) -> IO () +-- heightProgress initialHeight ref logFun = forever $ do +-- threadDelay (20 * 1_000_000) +-- h <- readIORef ref +-- logFun +-- $ "processed blocks: " <> sshow (h - initialHeight) +-- <> ", current height: " <> sshow h diff --git a/src/Chainweb/Pact/PactService/Checkpointer/Internal.hs b/src/Chainweb/Pact/PactService/Checkpointer/Internal.hs deleted file mode 100644 index 06cfd9983f..0000000000 --- a/src/Chainweb/Pact/PactService/Checkpointer/Internal.hs +++ /dev/null @@ -1,542 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE NumericUnderscores #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE OverloadedRecordDot #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE ViewPatterns #-} -{-# LANGUAGE BlockArguments #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE MultiWayIf #-} -{-# LANGUAGE TypeApplications #-} - --- | --- Module: Chainweb.Pact.Backend.RelationalCheckpointer --- Copyright: Copyright © 2018 - 2020 Kadena LLC. --- License: See LICENSE file --- Maintainers: Emmanuel Denloye --- Stability: experimental --- --- Pact Checkpointer for Chainweb -module Chainweb.Pact.PactService.Checkpointer.Internal - ( Checkpointer(..) - , initCheckpointerResources - , withCheckpointerResources - , rewindTo - , readFrom - , restoreAndSave - , lookupBlock - , getEarliestBlock - , getLatestBlock - , getBlockHistory - , getBlockParent - , lookupHistorical - ) where - -import Control.Concurrent (threadDelay) -import Control.Concurrent.Async -import Control.Concurrent.MVar -import Control.Lens (view) -import Control.Monad -import Control.Monad.Catch -import Control.Monad.IO.Class - -import qualified Data.ByteString.Short as BS -#if !MIN_VERSION_base(4,20,0) -import Data.Foldable (foldl') -#endif -import Data.Int -import Data.Coerce -import qualified Data.Map.Strict as M -import Data.Maybe -import qualified Data.HashMap.Strict as HashMap -import qualified Data.Set as S -import qualified Data.Text as T -import qualified Data.Text.Encoding as T -import GHC.Stack (HasCallStack) - -import Database.SQLite3.Direct - -import Prelude hiding (log) -import Streaming -import qualified Streaming.Prelude as Streaming - -import System.LogLevel - --- pact - -import Pact.Interpreter (PactDbEnv(..)) -import Pact.Types.Command(RequestKey(..)) -import Pact.Types.Hash (Hash(..)) -import Pact.Types.Persistence -import Pact.Types.SQLite - -import qualified Pact.Core.Persistence as Pact5 - --- chainweb -import Chainweb.BlockHash -import Chainweb.BlockHeader -import Chainweb.BlockHeight -import Chainweb.Logger -import qualified Chainweb.Pact4.Backend.ChainwebPactDb as Pact4 -import qualified Chainweb.Pact5.Backend.ChainwebPactDb as Pact5 - -import Chainweb.Pact.Backend.DbCache -import Chainweb.Pact.Backend.Utils -import Chainweb.Pact.Backend.Types -import Chainweb.Pact.Types -import Chainweb.Utils -import Chainweb.Utils.Serialization -import Chainweb.Version -import Chainweb.Version.Guards -import qualified Pact.Core.Builtin as Pact5 -import qualified Pact.Core.Evaluate as Pact5 -import qualified Pact.Core.Names as Pact5 -import qualified Chainweb.Pact.Backend.Utils as PactDb - -withCheckpointerResources - :: (Logger logger) - => logger - -> DbCacheLimitBytes - -> SQLiteEnv - -> IntraBlockPersistence - -> ChainwebVersion - -> ChainId - -> (Checkpointer logger -> IO a) - -> IO a -withCheckpointerResources logger dbCacheLimit sqlenv p v cid inner = do - cp <- initCheckpointerResources dbCacheLimit sqlenv p logger v cid - withAsync (logModuleCacheStats (cpModuleCacheVar cp)) $ \_ -> inner cp - where - logFun = logFunctionText logger - logModuleCacheStats e = runForever logFun "ModuleCacheStats" $ do - stats <- modifyMVar e $ \db -> do - let (s, !mc') = updateCacheStats db - return (mc', s) - logFunctionJson logger Info stats - threadDelay 60_000_000 {- 1 minute -} - -initCheckpointerResources - :: (Logger logger) - => DbCacheLimitBytes - -> SQLiteEnv - -> IntraBlockPersistence - -> logger - -> ChainwebVersion - -> ChainId - -> IO (Checkpointer logger) -initCheckpointerResources dbCacheLimit sql p loggr v cid = do - Pact5.initSchema sql - moduleCacheVar <- newMVar (emptyDbCache dbCacheLimit) - return Checkpointer - { cpLogger = loggr - , cpCwVersion = v - , cpChainId = cid - , cpSql = sql - , cpIntraBlockPersistence = p - , cpModuleCacheVar = moduleCacheVar - } - --- | Rewind to a particular block *in-memory*, producing a read-write snapshot --- of the database at that block to compute some value, after which the snapshot --- is discarded and nothing is saved to the database. --- --- prerequisite: ParentHeader is an ancestor of the "latest block"; --- if that isn't the case, NoHistory is returned. -readFrom - :: forall logger pv a - . (Logger logger) - => Checkpointer logger - -> Maybe ParentHeader - -> PactVersionT pv - -> (PactDbFor logger pv -> BlockHandle pv -> IO a) - -> IO (Historical a) -readFrom res maybeParent pactVersion doRead = do - let currentHeight = case maybeParent of - Nothing -> genesisHeight res.cpCwVersion res.cpChainId - Just parent -> succ . view blockHeight . _parentHeader $ parent - - modifyMVar res.cpModuleCacheVar $ \sharedModuleCache -> do - bracket - (beginSavepoint res.cpSql BatchSavepoint) - (\_ -> abortSavepoint res.cpSql BatchSavepoint) \() -> do - -- NB it's important to do this *after* you start the savepoint (and thus - -- the db transaction) to make sure that the latestHeader check is up to date. - latestHeader <- getLatestBlock res.cpSql - h <- case pactVersion of - Pact4T - | pact5 res.cpCwVersion res.cpChainId currentHeight -> internalError $ - "Pact 4 readFrom executed on block height after Pact 5 fork, height: " <> sshow currentHeight - | otherwise -> PactDb.getEndTxId "doReadFrom" res.cpSql maybeParent >>= traverse \startTxId -> do - newDbEnv <- newMVar $ Pact4.BlockEnv - (Pact4.mkBlockHandlerEnv res.cpCwVersion res.cpChainId currentHeight res.cpSql DoNotPersistIntraBlockWrites res.cpLogger) - (Pact4.initBlockState defaultModuleCacheLimit startTxId) - { Pact4._bsModuleCache = sharedModuleCache } - let - -- is the parent the latest header, i.e., can we get away without rewinding? - parentIsLatestHeader = case (latestHeader, maybeParent) of - (Nothing, Nothing) -> True - (Just (_, latestHash), Just (ParentHeader ph)) -> - view blockHash ph == latestHash - _ -> False - mkBlockDbEnv db = Pact4.CurrentBlockDbEnv - { Pact4._cpPactDbEnv = PactDbEnv db newDbEnv - , Pact4._cpRegisterProcessedTx = \hash -> - Pact4.runBlockEnv newDbEnv (Pact4.indexPactTransaction $ BS.fromShort $ coerce hash) - , Pact4._cpLookupProcessedTx = \hs -> - HashMap.mapKeys coerce <$> doLookupSuccessful res.cpSql currentHeight (coerce hs) - } - pactDb - | parentIsLatestHeader = Pact4.chainwebPactDb - | otherwise = Pact4.rewoundPactDb currentHeight startTxId - r <- doRead (mkBlockDbEnv pactDb) (emptyPact4BlockHandle startTxId) - finalCache <- Pact4._bsModuleCache . Pact4._benvBlockState <$> readMVar newDbEnv - return (r, finalCache) - - Pact5T - | pact5 res.cpCwVersion res.cpChainId currentHeight -> - PactDb.getEndTxId "doReadFrom" res.cpSql maybeParent >>= traverse \startTxId -> do - let - -- is the parent the latest header, i.e., can we get away without rewinding? - parentIsLatestHeader = case (latestHeader, maybeParent) of - (Nothing, Nothing) -> True - (Just (_, latestHash), Just (ParentHeader ph)) -> - view blockHash ph == latestHash - _ -> False - blockHandlerEnv = Pact5.BlockHandlerEnv - { Pact5._blockHandlerDb = res.cpSql - , Pact5._blockHandlerLogger = res.cpLogger - , Pact5._blockHandlerVersion = res.cpCwVersion - , Pact5._blockHandlerChainId = res.cpChainId - , Pact5._blockHandlerBlockHeight = currentHeight - , Pact5._blockHandlerMode = Pact5.Transactional - , Pact5._blockHandlerUpperBoundTxId = Pact5.TxId $ fromIntegral startTxId - , Pact5._blockHandlerAtTip = parentIsLatestHeader - } - let pactDb = Pact5.chainwebPactBlockDb blockHandlerEnv - r <- doRead pactDb (emptyPact5BlockHandle startTxId) - return (r, sharedModuleCache) - | otherwise -> - internalError $ - "Pact 5 readFrom executed on block height before Pact 5 fork, height: " <> sshow currentHeight - case h of - NoHistory -> return (sharedModuleCache, NoHistory) - Historical (r, finalCache) -> return (finalCache, Historical r) - - - --- the special case where one doesn't want to extend the chain, just rewind it. -rewindTo :: Logger logger => Checkpointer logger -> Maybe ParentHeader -> IO () -rewindTo cp ancestor = void $ restoreAndSave cp - ancestor - (pure () :: Stream (Of (RunnableBlock logger ())) IO ()) - --- TODO: log more? --- | Rewind to a particular block, and play a stream of blocks afterward, --- extending the chain and saving the result persistently. for example, --- to validate a block `vb`, we rewind to the common ancestor of `vb` and --- the latest block, and extend the chain with all of the blocks on `vb`'s --- fork, including `vb`. --- this function takes care of making sure that this is done *atomically*. --- TODO: fix the below w.r.t. its latest type --- promises: --- - excluding the fact that each _cpRestoreAndSave call is atomic, the --- following two expressions should be equivalent: --- do --- _cpRestoreAndSave cp p1 x --- ((,) <$> (bs1 <* Stream.yield p2) <*> bs2) runBlk --- do --- (r1, q1) <- _cpRestoreAndSave cp p1 x (bs1 <* Stream.yield p2) runBlk --- (r2, q2) <- _cpRestoreAndSave cp (Just (x p2)) x bs2 runBlk --- return ((r1, r2), q1 <> q2) --- i.e. rewinding, extending, then rewinding to the point you extended --- to and extending some more, should give the same result as rewinding --- once and extending to the same final point. --- - no block in the stream is used more than once. --- prerequisites: --- - the parent being rewound to must be a direct ancestor --- of the latest block, i.e. what's returned by _cpLatestBlock. --- - the stream must start with a block that is a child of the rewind --- target and each block after must be the child of the previous block. -restoreAndSave - :: forall logger r q. - (Logger logger, Monoid q, HasCallStack) - => Checkpointer logger - -> Maybe ParentHeader - -> Stream (Of (RunnableBlock logger q)) IO r - -> IO (r, q) -restoreAndSave res rewindParent blocks = do - modifyMVar res.cpModuleCacheVar $ \moduleCache -> do - fmap fst $ generalBracket - (beginSavepoint res.cpSql BatchSavepoint) - (\_ -> \case - ExitCaseSuccess {} -> commitSavepoint res.cpSql BatchSavepoint - _ -> abortSavepoint res.cpSql BatchSavepoint - ) $ \_ -> do - startTxId <- PactDb.rewindDbTo res.cpSql rewindParent - ((q, _, _, finalModuleCache) :> r) <- extend startTxId moduleCache - return (finalModuleCache, (r, q)) - where - - extend - :: TxId -> DbCache PersistModuleData - -> IO (Of (q, Maybe ParentHeader, TxId, DbCache PersistModuleData) r) - extend startTxId startModuleCache = Streaming.foldM - (\(m, maybeParent, txid, moduleCache) block -> do - let - !bh = case maybeParent of - Nothing -> genesisHeight res.cpCwVersion res.cpChainId - Just parent -> (succ . view blockHeight . _parentHeader) parent - case block of - Pact4RunnableBlock runBlock - | pact5 res.cpCwVersion res.cpChainId bh -> - internalError $ - "Pact 4 block executed on block height after Pact 5 fork, height: " <> sshow bh - | otherwise -> do - -- prepare a fresh block state - let handlerEnv = Pact4.mkBlockHandlerEnv res.cpCwVersion res.cpChainId bh res.cpSql res.cpIntraBlockPersistence res.cpLogger - let state = (Pact4.initBlockState defaultModuleCacheLimit txid) - { Pact4._bsModuleCache = moduleCache } - dbMVar <- newMVar Pact4.BlockEnv - { Pact4._blockHandlerEnv = handlerEnv - , Pact4._benvBlockState = state - } - - let - mkBlockDbEnv db = Pact4.CurrentBlockDbEnv - { Pact4._cpPactDbEnv = db - , Pact4._cpRegisterProcessedTx = \hash -> - Pact4.runBlockEnv dbMVar (Pact4.indexPactTransaction $ BS.fromShort $ coerce hash) - , Pact4._cpLookupProcessedTx = \hs -> - fmap (HashMap.mapKeys coerce) $ - doLookupSuccessful res.cpSql bh $ - coerce hs - } - - -- execute the block - let pact4Db = PactDbEnv Pact4.chainwebPactDb dbMVar - (m', newBh) <- runBlock (mkBlockDbEnv pact4Db) maybeParent - - -- grab any resulting state that we're interested in keeping - nextState <- Pact4._benvBlockState <$> takeMVar dbMVar - let !nextTxId = Pact4._bsTxId nextState - let !nextModuleCache = Pact4._bsModuleCache nextState - when (isJust (Pact4._bsPendingTx nextState)) $ - internalError "tx still in progress at the end of block" - -- compute the accumulator early - let !m'' = m <> m' - -- check that the new parent header has the right height for a child - -- of the previous block - case maybeParent of - Nothing - | genesisHeight res.cpCwVersion res.cpChainId /= view blockHeight newBh -> internalError - "doRestoreAndSave: block with no parent, genesis block, should have genesis height but doesn't," - Just (ParentHeader ph) - | succ (view blockHeight ph) /= view blockHeight newBh -> internalError $ - "doRestoreAndSave: non-genesis block should be one higher than its parent. parent at " - <> sshow (view blockHeight ph) <> ", child height " <> sshow (view blockHeight newBh) - _ -> return () - -- persist any changes to the database - Pact4.commitBlockStateToDatabase res.cpSql - (view blockHash newBh) (view blockHeight newBh) - (BlockHandle (Pact4._bsTxId nextState) (Pact4._bsPendingBlock nextState)) - return (m'', Just (ParentHeader newBh), nextTxId, nextModuleCache) - Pact5RunnableBlock runBlock - | pact5 res.cpCwVersion res.cpChainId bh -> do - let - blockEnv = Pact5.BlockHandlerEnv - { Pact5._blockHandlerDb = res.cpSql - , Pact5._blockHandlerLogger = res.cpLogger - , Pact5._blockHandlerVersion = res.cpCwVersion - , Pact5._blockHandlerBlockHeight = bh - , Pact5._blockHandlerChainId = res.cpChainId - , Pact5._blockHandlerMode = Pact5.Transactional - , Pact5._blockHandlerUpperBoundTxId = Pact5.TxId $ fromIntegral txid - , Pact5._blockHandlerAtTip = True - } - pactDb = Pact5.chainwebPactBlockDb blockEnv - -- run the block - ((m', nextBlockHeader), blockHandle) <- runBlock pactDb maybeParent (emptyPact5BlockHandle txid) - -- compute the accumulator early - let !m'' = m <> m' - case maybeParent of - Nothing - | genesisHeight res.cpCwVersion res.cpChainId /= view blockHeight nextBlockHeader -> internalError - "doRestoreAndSave: block with no parent, genesis block, should have genesis height but doesn't," - Just (ParentHeader ph) - | succ (view blockHeight ph) /= view blockHeight nextBlockHeader -> internalError $ - "doRestoreAndSave: non-genesis block should be one higher than its parent. parent at " - <> sshow (view blockHeight ph) <> ", child height " <> sshow (view blockHeight nextBlockHeader) - _ -> return () - Pact5.commitBlockStateToDatabase res.cpSql - (view blockHash nextBlockHeader) (view blockHeight nextBlockHeader) - blockHandle - - return (m'', Just (ParentHeader nextBlockHeader), _blockHandleTxId blockHandle, moduleCache) - - | otherwise -> internalError $ - "Pact 5 block executed on block height before Pact 5 fork, height: " <> sshow bh - ) - (return (mempty, rewindParent, startTxId, startModuleCache)) - return - blocks - --- | Get the checkpointer's idea of the earliest block. The block height --- is the height of the block of the block hash. -getEarliestBlock :: HasCallStack => SQLiteEnv -> IO (Maybe (BlockHeight, BlockHash)) -getEarliestBlock db = do - r <- qry_ db qtext [RInt, RBlob] >>= mapM go - case r of - [] -> return Nothing - (!o:_) -> return (Just o) - where - qtext = "SELECT blockheight, hash FROM BlockHistory ORDER BY blockheight ASC LIMIT 1" - - go [SInt hgt, SBlob blob] = - let hash = either error id $ runGetEitherS decodeBlockHash blob - in return (fromIntegral hgt, hash) - go _ = fail "Chainweb.Pact.Backend.RelationalCheckpointer.doGetEarliest: impossible. This is a bug in chainweb-node." - --- | Get the checkpointer's idea of the latest block. The block height is --- is the height of the block of the block hash. --- --- TODO: Under which circumstances does this return 'Nothing'? -getLatestBlock :: HasCallStack => SQLiteEnv -> IO (Maybe (BlockHeight, BlockHash)) -getLatestBlock db = do - r <- qry_ db qtext [RInt, RBlob] >>= mapM go - case r of - [] -> return Nothing - (!o:_) -> return (Just o) - where - qtext = "SELECT blockheight, hash FROM BlockHistory ORDER BY blockheight DESC LIMIT 1" - - go [SInt hgt, SBlob blob] = - let hash = either error id $ runGetEitherS decodeBlockHash blob - in return (fromIntegral hgt, hash) - go _ = fail "Chainweb.Pact.Backend.RelationalCheckpointer.getLatest: impossible. This is a bug in chainweb-node." - --- | Ask: is the checkpointer aware of the given block? -lookupBlock :: SQLiteEnv -> (BlockHeight, BlockHash) -> IO Bool -lookupBlock db (bheight, bhash) = do - r <- qry db qtext [SInt $ fromIntegral bheight, SBlob (runPutS (encodeBlockHash bhash))] - [RInt] - liftIO (expectSingle "row" r) >>= \case - [SInt n] -> return $! n == 1 - _ -> internalError "lookupBlock: output type mismatch" - where - qtext = "SELECT COUNT(*) FROM BlockHistory WHERE blockheight = ? AND hash = ?;" - -getBlockParent :: ChainwebVersion -> ChainId -> SQLiteEnv -> (BlockHeight, BlockHash) -> IO (Maybe BlockHash) -getBlockParent v cid db (bh, hash) - | bh == genesisHeight v cid = return Nothing - | otherwise = do - blockFound <- lookupBlock db (bh, hash) - if not blockFound - then return Nothing - else do - r <- qry db qtext [SInt (fromIntegral (pred bh))] [RBlob] - case r of - [[SBlob blob]] -> - either (internalError . T.pack) (return . return) $! runGetEitherS decodeBlockHash blob - [] -> internalError "getBlockParent: block was found but its parent couldn't be found" - _ -> error "getBlockParent: output type mismatch" - where - qtext = "SELECT hash FROM BlockHistory WHERE blockheight = ?" - - --- TODO: do this in ChainwebPactDb instead? -getBlockHistory - :: SQLiteEnv - -> BlockHeader - -> Pact5.Domain Pact5.RowKey Pact5.RowData Pact5.CoreBuiltin Pact5.Info - -> IO (Historical BlockTxHistory) -getBlockHistory db blockHeader d = do - historicalEndTxId <- - fmap fromIntegral - <$> PactDb.getEndTxId "getBlockHistory" db (Just $ ParentHeader blockHeader) - forM historicalEndTxId $ \endTxId -> do - startTxId <- - if bHeight == genesisHeight v cid - then return 0 - else PactDb.getEndTxId' "getBlockHistory" db (pred bHeight) (view blockParent blockHeader) >>= \case - NoHistory -> - internalError $ "getBlockHistory: missing parent for: " <> sshow blockHeader - Historical startTxId -> - return $ fromIntegral startTxId - - let tname = Pact5.domainTableName d - history <- queryHistory tname startTxId endTxId - let (!hkeys,tmap) = foldl' procTxHist (S.empty,mempty) history - !prev <- M.fromList . catMaybes <$> mapM (queryPrev tname startTxId) (S.toList hkeys) - return $ BlockTxHistory tmap prev - where - v = _chainwebVersion blockHeader - cid = view blockChainId blockHeader - bHeight = view blockHeight blockHeader - - procTxHist - :: (S.Set Utf8, M.Map TxId [Pact5.TxLog Pact5.RowData]) - -> (Utf8,TxId,Pact5.TxLog Pact5.RowData) - -> (S.Set Utf8,M.Map TxId [Pact5.TxLog Pact5.RowData]) - procTxHist (ks,r) (uk,t,l) = (S.insert uk ks, M.insertWith (++) t [l] r) - - -- Start index is inclusive, while ending index is not. - -- `endingtxid` in a block is the beginning txid of the following block. - queryHistory :: Utf8 -> Int64 -> Int64 -> IO [(Utf8,TxId,Pact5.TxLog Pact5.RowData)] - queryHistory tableName s e = do - let sql = "SELECT txid, rowkey, rowdata FROM [" <> tableName <> - "] WHERE txid >= ? AND txid < ?" - r <- qry db sql - [SInt s,SInt e] - [RInt,RText,RBlob] - forM r $ \case - [SInt txid, SText key, SBlob value] -> - (key,fromIntegral txid,) - <$> Pact5.toTxLog (_chainwebVersion blockHeader) (_chainId blockHeader) (view blockHeight blockHeader) (Pact5.renderDomain d) key value - err -> internalError $ - "queryHistory: Expected single row with three columns as the \ - \result, got: " <> T.pack (show err) - - -- Get last tx data, if any, for key before start index. - queryPrev :: Utf8 -> Int64 -> Utf8 -> IO (Maybe (RowKey,Pact5.TxLog Pact5.RowData)) - queryPrev tableName s k@(Utf8 sk) = do - let sql = "SELECT rowdata FROM [" <> tableName <> - "] WHERE rowkey = ? AND txid < ? " <> - "ORDER BY txid DESC LIMIT 1" - r <- qry db sql - [SText k,SInt s] - [RBlob] - case r of - [] -> return Nothing - [[SBlob value]] -> - Just . (RowKey $ T.decodeUtf8 sk,) - <$> Pact5.toTxLog (_chainwebVersion blockHeader) (_chainId blockHeader) (view blockHeight blockHeader) (Pact5.renderDomain d) k value - _ -> internalError $ "queryPrev: expected 0 or 1 rows, got: " <> T.pack (show r) - --- TODO: do this in ChainwebPactDb instead? -lookupHistorical - :: SQLiteEnv - -> BlockHeader - -> Pact5.Domain Pact5.RowKey Pact5.RowData Pact5.CoreBuiltin Pact5.Info - -> Pact5.RowKey - -> IO (Historical (Maybe (Pact5.TxLog Pact5.RowData))) -lookupHistorical db blockHeader d k = do - historicalEndTxId <- - PactDb.getEndTxId "lookupHistorical" db (Just $ ParentHeader blockHeader) - forM historicalEndTxId (queryHistoryLookup . fromIntegral) - where - queryHistoryLookup :: Int64 -> IO (Maybe (Pact5.TxLog Pact5.RowData)) - queryHistoryLookup e = do - let sql = "SELECT rowKey, rowdata FROM [" <> Pact5.domainTableName d <> - "] WHERE txid < ? AND rowkey = ? ORDER BY txid DESC LIMIT 1;" - r <- qry db sql - [SInt e, SText (toUtf8 $ Pact5.convRowKey k)] - [RText, RBlob] - case r of - [[SText key, SBlob value]] -> - Just <$> Pact5.toTxLog (_chainwebVersion blockHeader) (_chainId blockHeader) (view blockHeight blockHeader) (Pact5.renderDomain d) key value - [] -> pure Nothing - _ -> internalError $ "lookupHistorical: expected single-row result, got " <> sshow r diff --git a/src/Chainweb/Pact/PactService/ExecBlock.hs b/src/Chainweb/Pact/PactService/ExecBlock.hs new file mode 100644 index 0000000000..ff1d5f8179 --- /dev/null +++ b/src/Chainweb/Pact/PactService/ExecBlock.hs @@ -0,0 +1,615 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE ViewPatterns #-} + +module Chainweb.Pact.PactService.ExecBlock + ( runCoinbase + , continueBlock + , execExistingBlock + , validateParsedChainwebTx + , pact5TransactionsFromPayload + , BlockInvalidError(..) + ) where + +import Chainweb.Logger +import Chainweb.Miner.Pact +import Chainweb.Pact.Backend.ChainwebPactDb qualified as Pact +import Chainweb.Pact.Backend.Types +import Chainweb.Pact.Mempool.Mempool(BlockFill (..), pactRequestKeyToTransactionHash, InsertError (..)) +import Chainweb.Pact.NoCoinbase +import Chainweb.Pact.Payload +import Chainweb.Pact.Payload qualified as Chainweb +import Chainweb.Pact.Payload.PayloadStore +import Chainweb.Pact.Transaction +import Chainweb.Pact.Transaction qualified as Pact +import Chainweb.Pact.TransactionExec +import Chainweb.Pact.Types +import Chainweb.Pact.Types qualified as Pact +import Chainweb.Pact.Validations qualified as Pact +import Chainweb.Parent +import Chainweb.Time +import Chainweb.Utils +import Chainweb.Version +import Chainweb.Version.Guards +import Chronos qualified +import Control.Lens +import Control.Monad +import Control.Monad.Except +import Control.Monad.IO.Class +import Control.Monad.State.Strict +import Data.Aeson qualified as Aeson +import Data.ByteString (ByteString) +import Data.ByteString.Short qualified as SB +import Data.Coerce +import Data.Either (partitionEithers) +import Data.Foldable +import Data.HashMap.Strict qualified as HashMap +import Data.List.NonEmpty qualified as NEL +import Data.Maybe +import Data.Set qualified as S +import Data.Text qualified as T +import Data.Text.Encoding qualified as T +import Data.Vector (Vector) +import Data.Vector qualified as V +import Data.Void +import Pact.Core.ChainData hiding (ChainId) +import Pact.Core.ChainData qualified as Pact +import Pact.Core.Command.Types qualified as Pact +import Pact.Core.Errors qualified as Pact +import Pact.Core.Evaluate qualified as Pact +import Pact.Core.Gas qualified as P +import Pact.Core.Gas qualified as Pact +import Pact.Core.Hash +import Pact.Core.Hash qualified as Pact +import Pact.Core.Persistence qualified as Pact +import Pact.JSON.Encode qualified as J +import System.LogLevel +import System.Timeout +import Utils.Logging.Trace + +runCoinbase + :: (Logger logger) + => HasVersion + => logger + -> BlockEnv + -> Miner + -> StateT BlockHandle (ExceptT (Pact.PactError Pact.Info) IO) (Pact.CommandResult [Pact.TxLog ByteString] Void) +runCoinbase logger blockEnv miner = do + let isGenesis = _bctxIsGenesis $ _psBlockCtx blockEnv + if isGenesis + then return noCoinbase + else do + let blockCtx = _psBlockCtx blockEnv + + -- the coinbase request key is not passed here because TransactionIndex + -- does not contain coinbase transactions + mapStateT liftIO + (doChainwebPactDbTransaction (blockEnv ^. psBlockDbEnv) Nothing + (\db _spv -> applyCoinbase logger db miner blockCtx)) + >>= liftEither + +-- | Continue adding transactions to an existing block. +continueBlock + :: forall logger tbl + . (Logger logger) + => HasVersion + => logger + -> ServiceEnv tbl + -> ChainwebPactDb + -> BlockInProgress + -> IO BlockInProgress +continueBlock logger serviceEnv dbEnv blockInProgress = do + let mpAccess = view psMempoolAccess serviceEnv + miner <- maybe (error "no miner but tried continuing block") return $ _psMiner serviceEnv + let blockCtx = _blockInProgressBlockCtx blockInProgress + let blockEnv = BlockEnv blockCtx dbEnv + (blockInProgress', _newHandle) <- flip runStateT (_blockInProgressHandle blockInProgress) $ do + -- update the mempool, ensuring that we reintroduce any transactions that + -- were removed due to being completed in a block on a different fork. + liftIO $ + if _bctxIsGenesis blockCtx + then do + logFunctionText logger Info + "Continuing genesis block" + else do + logFunctionText logger Info $ + "continue creating block" + <> "; parent height: " <> toText (unwrapParent $ _bctxParentHeight blockCtx) + <> "; parent hash: " <> toText (unwrapParent $ _bctxParentHash blockCtx) + <> "; tx count: " <> sshow (V.length $ _transactionPairs $ _blockInProgressTransactions blockInProgress) + <> "; remaining gas: " <> sshow (_blockInProgressRemainingGasLimit blockInProgress) + <> "; sequence number: " <> sshow (_blockInProgressNumber blockInProgress) + + let blockGasLimit = view psNewBlockGasLimit serviceEnv + let mTxTimeLimit = view psNewPayloadTxTimeLimit serviceEnv + let txTimeHeadroomFactor :: Double + txTimeHeadroomFactor = 5 + let txTimeLimit :: Micros + -- 2.5 us per unit gas + txTimeLimit = fromMaybe (round $ 2.5 * txTimeHeadroomFactor * fromIntegral (view (Pact._GasLimit . to Pact._gas) blockGasLimit)) mTxTimeLimit + liftIO $ + logFunctionText logger Debug $ T.unwords + [ "continueBlock" + , ". Block gas limit: ", sshow blockGasLimit + , ", Transaction time limit: ", sshow txTimeLimit + ] + + let startTxs = _transactionPairs (_blockInProgressTransactions blockInProgress) + let startTxsRequestKeys = + foldMap' (S.singleton . pactRequestKeyToTransactionHash . view Pact.crReqKey . ssnd) startTxs + let initState = BlockFill + { _bfTxHashes = startTxsRequestKeys + , _bfGasLimit = _blockInProgressRemainingGasLimit blockInProgress + , _bfCount = 0 + } + + let fetchLimit = fromIntegral $ view (Pact._GasLimit . to Pact._gas) blockGasLimit `div` 1000 + + (BlockFill { _bfGasLimit = finalGasLimit }, valids, invalids) <- + refill blockEnv miner fetchLimit txTimeLimit initState + + finalBlockHandle <- get + + liftIO $ mpaBadlistTx mpAccess + (V.fromList $ pactRequestKeyToTransactionHash <$> concat invalids) + + let !blockInProgress' = blockInProgress + & blockInProgressHandle .~ + finalBlockHandle + & blockInProgressTransactions . transactionPairs .~ + startTxs <> V.fromList (concat valids) + & blockInProgressRemainingGasLimit .~ + finalGasLimit + & blockInProgressNumber %~ + succ + + liftIO $ logFunctionText logger Debug + $ "continueBlock: block with new transactions: " + <> sshow (Pact.unRequestKey . Pact._crReqKey . ssnd <$> _transactionPairs (_blockInProgressTransactions blockInProgress')) + + return blockInProgress' + return blockInProgress' + + where + refill blockEnv miner fetchLimit txTimeLimit blockFillState = over _2 reverse <$> go [] [] blockFillState + where + go + :: [CompletedTransactions] + -> [InvalidTransactions] + -> BlockFill + -> StateT BlockHandle IO (BlockFill, [CompletedTransactions], [InvalidTransactions]) + go completedTransactions invalidTransactions prevBlockFillState@BlockFill + { _bfGasLimit = prevRemainingGas, _bfCount = prevFillCount, _bfTxHashes = prevTxHashes } + | prevFillCount > fetchLimit = liftIO $ do + logFunctionText logger Info $ "continueBlock.refill" + <> ": fetch limit exceeded" + <> "; fillCount: " <> sshow prevFillCount + <> "; limit: " <> sshow fetchLimit + pure stop + | prevRemainingGas == Pact.GasLimit (Pact.Gas 0) = + pure stop + | otherwise = do + newTxs <- liftIO $ getBlockTxs blockEnv prevBlockFillState + liftIO $ logFunctionText logger Debug $ "continueBlock.refill: fetched transactions: " <> sshow (V.length newTxs) + if V.null newTxs + then pure stop + else do + (newCompletedTransactions, newInvalidTransactions, newBlockGasLimit, timedOut) <- + execNewTransactions prevRemainingGas txTimeLimit newTxs + + liftIO $ do + logFunctionText logger Debug $ "continueBlock.refill: included: " + <> sshow @[Hash] (fmap (Pact.unRequestKey . Pact._crReqKey . ssnd) newCompletedTransactions) + <> ", badlisted: " + <> sshow @[Hash] (fmap Pact.unRequestKey newInvalidTransactions) + + let newBlockFillState = BlockFill + { _bfCount = succ prevFillCount + , _bfGasLimit = newBlockGasLimit + , _bfTxHashes = + flip + (foldr (S.insert . pactRequestKeyToTransactionHash . view (_2 . Pact.crReqKey))) + newCompletedTransactions + $ flip + (foldr (S.insert . pactRequestKeyToTransactionHash)) + newInvalidTransactions + $ prevTxHashes + } + let completedTransactions' = newCompletedTransactions : completedTransactions + let invalidTransactions' = newInvalidTransactions : invalidTransactions + if timedOut + then + -- stop; we've used so much time already that we should just return what we have + pure (newBlockFillState, completedTransactions', invalidTransactions') + else + go completedTransactions' invalidTransactions' newBlockFillState + + where + stop = (prevBlockFillState, completedTransactions, invalidTransactions) + + execNewTransactions + :: P.GasLimit + -> Micros + -> Vector Pact.Transaction + -> StateT BlockHandle IO (CompletedTransactions, InvalidTransactions, P.GasLimit, Bool) + execNewTransactions remainingGas timeLimit txs = do + startBlockHandle <- get + let blockCtx = view psBlockCtx blockEnv + ((txResults, timedOut), (finalBlockHandle, Identity finalRemainingGas)) <- + liftIO $ flip runStateT (startBlockHandle, Identity remainingGas) $ foldr + (\(txIdxInBlock, tx) rest -> StateT $ \s -> do + let logger' = addLabel ("transactionHash", sshow (Pact._cmdHash tx)) logger + let timeoutFunc runTx = + if _bctxIsGenesis blockCtx + then do + logFunctionText logger Info "continueBlock.refill: Running genesis command" + fmap Just runTx + else + newTimeout (fromIntegral @Micros @Int timeLimit) runTx + m <- liftIO $ timeoutFunc + $ runExceptT $ runStateT (applyCmdInBlock logger' serviceEnv blockEnv miner (TxBlockIdx txIdxInBlock) tx) s + case m of + Nothing -> do + logFunctionJson logger Warn $ Aeson.object + [ "function" Aeson..= Aeson.String "continueBlock.refill.execNewTransactions" + , "type" Aeson..= Aeson.String "newblock timeout" + , "hash" Aeson..= Aeson.String (sshow (Pact._cmdHash tx)) + , "payload" Aeson..= Aeson.String ( + T.decodeUtf8 $ SB.fromShort $ tx ^. Pact.cmdPayload . Pact.payloadBytes + ) + ] + return (([Left (Pact._cmdHash tx)], True), s) + Just (Left err) -> do + logFunctionText logger Debug $ + -- TODO PP: prettify + "continueBlock.refill: applyCmdInBlock failed to buy gas: " <> sshow err + ((as, timedOut), s') <- runStateT rest s + return ((Left (Pact._cmdHash tx):as, timedOut), s') + Just (Right (a, s')) -> do + ((as, timedOut), s'') <- runStateT rest s' + let !txBytes = commandToBytes tx + return ((Right (T2 txBytes a):as, timedOut), s'') + ) + (return ([], False)) + (zip [0..] (V.toList txs)) + put finalBlockHandle + let (invalidTxHashes, completedTxs) = partitionEithers txResults + return (completedTxs, Pact.RequestKey <$> invalidTxHashes, finalRemainingGas, timedOut) + + getBlockTxs :: BlockEnv -> BlockFill -> IO (Vector Pact.Transaction) + getBlockTxs blockEnv blockFillState = do + liftIO $ logFunctionText logger Debug "continueBlock.refill: fetching transactions" + let validate _bha txs = do + forM txs $ \tx -> + (tx <$) <$> runExceptT (validateParsedChainwebTx logger blockEnv tx) + let mpAccess = _psMempoolAccess serviceEnv + let blockCtx = _psBlockCtx blockEnv + liftIO $ mpaGetBlock mpAccess blockFillState validate (evaluationCtxOfBlockCtx blockCtx) + +type CompletedTransactions = [T2 Chainweb.Transaction Pact.OffChainCommandResult] +type InvalidTransactions = [Pact.RequestKey] + +-- Apply a Pact command in the current block. +-- This function completely ignores timeouts! +applyCmdInBlock + :: (Traversable t, Logger logger) + => HasVersion + => logger + -> ServiceEnv tbl + -> BlockEnv + -> Miner + -> TxIdxInBlock -> Pact.Transaction + -> StateT + (BlockHandle, t P.GasLimit) + (ExceptT TxInvalidError IO) + OffChainCommandResult +applyCmdInBlock logger serviceEnv blockEnv miner txIdxInBlock tx = StateT $ \(blockHandle, blockGasRemaining) -> do + -- we set the command gas limit to the minimum of its original value and the remaining gas in the block + -- this way Pact never uses more gas than remains in the block, and the tx fails otherwise + let alteredTx = (view payloadObj <$> tx) & Pact.cmdPayload . Pact.pMeta . pmGasLimit %~ maybe id min (blockGasRemaining ^? traversed) + let blockCtx = _psBlockCtx blockEnv + resultOrGasError <- liftIO $ unsafeApplyCmdInBlock + blockHandle + (initialGasOf implicitVersion (_bctxChainId blockCtx) + (_bctxCurrentBlockHeight blockCtx) (_bctxParentForkNumber blockCtx) tx) + alteredTx + case resultOrGasError of + Left err -> throwError err + Right (result, nextHandle) + -- if there is a fixed remaining amount of gas in the block + | Just blockGas <- blockGasRemaining ^? traversed + -- and the transaction gas limit is more than that + , let txGasLimit = tx ^. Pact.cmdPayload . payloadObj . Pact.pMeta . pmGasLimit + , txGasLimit > blockGas + -- then the transaction is not allowed to fail, or it would consume more gas than remains in the block + , Pact.PactResultErr _ <- Pact._crResult result + -> throwError TxExceedsBlockGasLimit + | otherwise -> do + let subtractGasLimit limit subtrahend = + let limitGas = limit ^. Pact._GasLimit + in if limitGas < subtrahend + -- this should be impossible. + -- we never allow a transaction to run with a gas limit higher than the block gas limit. + then error $ + "applyCmdInBlock.subtractGasLimit: transaction ran with higher gas limit than block gas limit: " <> + sshow subtrahend <> " > " <> sshow limit + else pure $ Pact.GasLimit $ Pact.Gas (Pact._gas limitGas - Pact._gas subtrahend) + blockGasRemaining' <- + traverse (`subtractGasLimit` Pact._crGas result) blockGasRemaining + return (result, (nextHandle, blockGasRemaining')) + where + -- | Apply a Pact command in the current block. + -- This function completely ignores timeouts and the block gas limit! + unsafeApplyCmdInBlock + :: BlockHandle + -> Pact.Gas + -> Pact.Command (Pact.Payload PublicMeta Pact.ParsedCode) + -> IO + (Either TxInvalidError (OffChainCommandResult, BlockHandle)) + unsafeApplyCmdInBlock blockHandle initialGas cmd = do + -- TODO PP: use + let gasLogger = _psGasLogger serviceEnv + let _txFailuresCounter = _psTxFailuresCounter serviceEnv + let dbEnv = _psBlockDbEnv blockEnv + let blockCtx = _psBlockCtx blockEnv + -- TODO: trace more info? + let rk = Pact.RequestKey $ Pact._cmdHash cmd + (resultOrError, blockHandle') <- flip runStateT blockHandle $ + trace' (logFunction logger) "applyCmdInBlock" computeTrace (const 0) $ + doChainwebPactDbTransaction dbEnv (Just rk) $ \pactDb spv -> + if _bctxIsGenesis blockCtx + then do + logFunctionText logger Debug "applyCmdInBlock.unsafeApplyCmdInBlock: running genesis command!" + r <- runGenesisPayload logger pactDb spv blockCtx cmd + case r of + Left genesisError -> error $ "applyCmdInBlock.unsafeApplyCmdInBlock: Genesis failed" + <> "; " <> sshow cmd + <> "; " <> sshow genesisError + -- pretend that genesis commands can throw non-fatal errors, + -- to make types line up + Right res -> return (Right (absurd <$> res)) + else applyCmd logger gasLogger pactDb miner blockCtx txIdxInBlock spv initialGas cmd + case resultOrError of + -- unknown exceptions are logged specially, because they indicate bugs in Pact or chainweb + Right + Pact.CommandResult + { + _crResult = + Pact.PactResultErr (Pact.PEExecutionError (Pact.UnknownException unknownExceptionMessage) _ _) + } -> logFunctionText logger Error + $ "applyCmdInBlock.unsafeAppplyCmdInBlock: unknown exception encountered: " <> unknownExceptionMessage + Left gasBuyError -> + liftIO $ logFunction logger Debug + -- TODO: replace with better print function for gas buy errors + (PactTxFailureLog rk (sshow gasBuyError)) + Right Pact.CommandResult + { _crResult = Pact.PactResultErr err + } -> + liftIO $ logFunction logger Debug + (PactTxFailureLog rk (sshow err)) + _ -> + return () + return $ (,blockHandle') <$> resultOrError + where + computeTrace (Left gasPurchaseFailure) = Aeson.object + [ "result" Aeson..= Aeson.String "gas purchase failure" + , "hash" Aeson..= J.toJsonViaEncode (Pact._cmdHash cmd) + , "error" Aeson..= Aeson.String (sshow gasPurchaseFailure) + ] + computeTrace (Right result) = Aeson.object + [ "gas" Aeson..= Pact._gas (Pact._crGas result) + , "result" Aeson..= Aeson.String (case Pact._crResult result of + Pact.PactResultOk _ -> + "success" + Pact.PactResultErr _ -> + "failure" + ) + , "hash" Aeson..= J.toJsonViaEncode (Pact._cmdHash cmd) + ] + +-- | The principal validation logic for groups of Pact Transactions. +-- This is used by the mempool to estimate tx validity +-- before inclusion into blocks, but it's also used by ExecBlock to check +-- if all of the txs in a block are valid. +-- +-- Skips validation for genesis transactions, since gas accounts, etc. don't +-- exist yet. +-- +validateParsedChainwebTx + :: (Logger logger) + => HasVersion + => logger + -> BlockEnv + -- ^ reference time for tx validation. + -> Pact.Transaction + -> ExceptT InsertError IO () +validateParsedChainwebTx _logger blockEnv tx + | _bctxIsGenesis blockCtx = pure () + | otherwise = do + checkUnique tx + checkTxHash tx + checkChain + checkTxSigs tx + checkTimes tx + return () + where + db = _psBlockDbEnv blockEnv + blockCtx = _psBlockCtx blockEnv + cid = blockCtx ^. chainId + bh = _bctxCurrentBlockHeight blockCtx + txValidationTime = _bctxParentCreationTime blockCtx + + checkChain :: ExceptT InsertError IO () + checkChain = unless (Pact.assertChainId cid txCid) $ + throwError $ InsertErrorWrongChain (toText cid) (Pact._chainId txCid) + where + txCid = view (Pact.cmdPayload . Pact.payloadObj . Pact.pMeta . Pact.pmChainId) tx + + checkUnique :: Pact.Transaction -> ExceptT InsertError IO () + checkUnique t = do + found <- liftIO $ + HashMap.lookup (coerce $ Pact._cmdHash t) <$> + Pact.lookupPactTransactions db + (V.singleton $ coerce $ Pact._cmdHash t) + case found of + Nothing -> pure () + Just _ -> throwError InsertErrorDuplicate + + checkTimes :: Pact.Transaction -> ExceptT InsertError IO () + checkTimes t = do + if | skipTxTimingValidation cid bh -> pure () + | not (Pact.assertTxNotInFuture txValidationTime (view Pact.payloadObj <$> t)) -> do + throwError InsertErrorTimeInFuture + | not (Pact.assertTxTimeRelativeToParent txValidationTime (view Pact.payloadObj <$> t)) -> do + throwError InsertErrorTTLExpired + | otherwise -> do + pure () + + checkTxHash :: Pact.Transaction -> ExceptT InsertError IO () + checkTxHash t = do + case Pact.verifyHash (Pact._cmdHash t) (SB.fromShort $ view Pact.payloadBytes $ Pact._cmdPayload t) of + Left _ + | doCheckTxHash cid bh -> throwError InsertErrorInvalidHash + | otherwise -> pure () + Right _ -> pure () + + + checkTxSigs :: Pact.Transaction -> ExceptT InsertError IO () + checkTxSigs t = do + case Pact.assertValidateSigs hsh signers sigs of + Right _ -> do + pure () + Left err -> do + throwError $ InsertErrorInvalidSigs (displayAssertValidateSigsError err) + where + hsh = Pact._cmdHash t + sigs = Pact._cmdSigs t + signers = Pact._pSigners $ view Pact.payloadObj $ Pact._cmdPayload t + +pact5TransactionsFromPayload + :: PayloadData + -> Either BlockInvalidError (Vector Pact.Transaction) +pact5TransactionsFromPayload plData = do + let vtrans = + map toCWTransaction $ + toList (view payloadDataTransactions plData) + let (theLefts, theRights) = partitionEithers vtrans + unless (null theLefts) $ do + let ls = map T.pack theLefts + throwError $ BlockInvalidDueToTxDecodeFailure ls + return $! V.fromList theRights + where + toCWTransaction bs = + codecDecode commandCodec (_transactionBytes bs) + +execExistingBlock + :: (CanReadablePayloadCas tbl, Logger logger) + => HasVersion + => logger + -> ServiceEnv tbl + -> BlockEnv + -> CheckablePayload + -> StateT BlockHandle (ExceptT BlockInvalidError IO) (P.Gas, PayloadWithOutputs, Vector Pact.Transaction) +execExistingBlock logger serviceEnv blockEnv payload = do + let blockCtx = _psBlockCtx blockEnv + let plData = checkablePayloadToPayloadData payload + miner :: Miner <- decodeStrictOrThrow (_minerData $ view payloadDataMiner plData) + txs <- liftEither $ pact5TransactionsFromPayload plData + let + errors <- liftIO $ flip foldMap txs $ \tx -> do + errorOrSuccess <- runExceptT $ + validateParsedChainwebTx logger blockEnv tx + case errorOrSuccess of + Right () -> return [] + Left err -> return [(Pact.RequestKey (Pact._cmdHash tx), err)] + case NEL.nonEmpty errors of + Nothing -> return () + Just errorsNel -> throwError $ BlockInvalidDueToInvalidTxs errorsNel + + coinbaseResult <- fmap (fmap absurd) + $ mapStateT (withExceptT BlockInvalidDueToCoinbaseFailure) + $ runCoinbase logger blockEnv miner + + let blockGasLimit = + Pact.GasLimit . Pact.Gas . fromIntegral <$> + maxBlockGasLimit (_bctxParentForkNumber blockCtx) (_bctxCurrentBlockHeight blockCtx) + + (V.fromList -> results, _finalBlockGasLimit) <- flip weaveStatesFst blockGasLimit $ + -- flip runStateT (postCoinbaseBlockHandle, blockGasLimit) $ + forM (zip [0..] (V.toList txs)) $ \(txIdxInBlock, tx) -> + T2 tx <$> + mapStateT + (mapExceptT (liftIO . fmap (over _Left BlockInvalidDueToInvalidTxAtRuntime))) + (applyCmdInBlock logger serviceEnv blockEnv miner (TxBlockIdx txIdxInBlock) tx) + -- incorporate the final state of the transactions into the block state + + let !totalGasUsed = foldOf (folded . _2 . to Pact._crGas) results + + pwo <- liftEither . over _Left BlockInvalidDueToOutputMismatch $ + validateHashes blockCtx payload miner (Transactions results coinbaseResult) + return (totalGasUsed, pwo, txs) + where + -- introduce a new state, s2, temporarily for an inner action + weaveStatesFst :: Monad m => StateT (s1, s2) m a -> s2 -> StateT s1 m (a, s2) + weaveStatesFst act s2 = StateT $ \s1 -> do + (a, (s1', s2')) <- runStateT act (s1, s2) + return ((a, s2'), s1') + + +-- | Check that the two payloads agree. If we have access to the outputs, we +-- check those too. +validateHashes + :: BlockCtx + -> CheckablePayload + -> Miner + -> Transactions Pact.Transaction Pact.OffChainCommandResult + -> Either BlockOutputMismatchError PayloadWithOutputs +validateHashes blockCtx payload miner transactions = + if newHash == expectedPayloadHash + then + Right actualPwo + else + Left $ BlockOutputMismatchError + { blockOutputMismatchCtx = blockCtx + , blockOutputMismatchActualPayload = actualPwo + , blockOutputMismatchExpectedPayload = payload + } + where + expectedPayloadHash = checkablePayloadExpectedHash payload + + actualPwo = toPayloadWithOutputs miner + (over (transactionPairs . mapped . _1) commandToBytes transactions) + + newHash = _payloadWithOutputsPayloadHash actualPwo + + -- The following JSON encodings are used in the BlockValidationFailure message + +data CRLogPair = CRLogPair Hash [Pact.TxLog ByteString] + +instance J.Encode CRLogPair where + build (CRLogPair h logs) = J.object + [ "hash" J..= h + , "rawLogs" J..= J.Array + [ J.text (_txDomain <> ": " <> _txKey <> " -> " <> T.decodeUtf8 _txValue) + | Pact.TxLog {..} <- logs + ] + ] + {-# INLINE build #-} + +-- | This timeout variant returns Nothing if the timeout elapsed, regardless of whether or not it was actually able to interrupt its argument. +-- This is more robust in the face of scheduler behavior than the standard 'System.Timeout.timeout', with small timeouts. +newTimeout :: Int -> IO a -> IO (Maybe a) +newTimeout n f = do + (timeSpan, a) <- Chronos.stopwatch (timeout n f) + if Chronos.getTimespan timeSpan > fromIntegral (n * 1000) + then return Nothing + else return a diff --git a/src/Chainweb/Pact/PactService/Pact4/ExecBlock.hs b/src/Chainweb/Pact/PactService/Pact4/ExecBlock.hs index a0fb97a8c1..629484c3e8 100644 --- a/src/Chainweb/Pact/PactService/Pact4/ExecBlock.hs +++ b/src/Chainweb/Pact/PactService/Pact4/ExecBlock.hs @@ -1,17 +1,19 @@ {-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE ImportQualifiedPost #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiWayIf #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PartialTypeSignatures #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ViewPatterns #-} -- | @@ -26,180 +28,173 @@ module Chainweb.Pact.PactService.Pact4.ExecBlock ( execBlock , execTransactions - , continueBlock , toPayloadWithOutputs , validateParsedChainwebTx , validateRawChainwebTx , validateHashes - , throwCommandInvalidError , initModuleCacheForBlock , runCoinbase - , CommandInvalidError(..) , checkParse ) where -import Chronos qualified +import Chainweb.BlockCreationTime +import Chainweb.BlockHeader +import Chainweb.BlockHeight +import Chainweb.ForkState (pact4ForkNumber) +import Chainweb.Logger +import Chainweb.Miner.Pact +import Chainweb.MinerReward +import Chainweb.Pact.Mempool.Mempool as Mempool +import Chainweb.Pact.Payload +import Chainweb.Pact.Payload.PayloadStore +import Chainweb.Pact.Types (ServiceEnv(..), Transactions (..), bctxParentCreationTime, bctxParentHeight, _bctxIsGenesis, _bctxCurrentBlockHeight, BlockCtx, BlockInvalidError (..), TxInvalidError (..)) +import Chainweb.Pact4.Backend.ChainwebPactDb +import Chainweb.Pact4.ModuleCache +import Chainweb.Pact4.NoCoinbase +import Chainweb.Pact4.SPV qualified as Pact4 +import Chainweb.Pact4.Transaction qualified as Pact4 +import Chainweb.Pact4.TransactionExec qualified as Pact4 +import Chainweb.Pact4.Types +import Chainweb.Pact4.Validations qualified as Pact4 +import Chainweb.Parent +import Chainweb.Utils hiding (check) +import Chainweb.Version +import Chainweb.Version.Guards import Control.Concurrent.MVar -import Control.DeepSeq import Control.Exception (evaluate) import Control.Lens import Control.Monad import Control.Monad.Catch +import Control.Monad.Except import Control.Monad.Reader import Control.Monad.State.Strict - -import System.LogLevel (LogLevel(..)) -import qualified Data.ByteString.Short as SB -import Data.List qualified as List +import Data.ByteString.Short qualified as SB +import Data.Coerce import Data.Either import Data.Foldable (toList) -import qualified Data.HashMap.Strict as HashMap -import qualified Data.Map as Map +import Data.HashMap.Strict qualified as HashMap +import Data.List qualified as List +import Data.List.NonEmpty qualified as NE +import Data.Map qualified as M +import Data.Map qualified as Map import Data.Maybe import Data.Text (Text) -import qualified Data.Text as T +import Data.Text qualified as T import Data.Vector (Vector) -import qualified Data.Vector as V - -import System.IO -import System.Timeout - -import Prelude hiding (lookup) - +import Data.Vector qualified as V import Pact.Compile (compileExps) -import Pact.Interpreter(PactDbEnv(..)) -import qualified Pact.JSON.Encode as J -import qualified Pact.Parse as Pact4 hiding (parsePact) -import qualified Pact.Types.Command as Pact4 +import Pact.Core.Command.Types qualified as Pact5 +import Pact.Core.Hash qualified as Pact5 +import Pact.JSON.Encode qualified as J +import Pact.Parse qualified as Pact4 hiding (parsePact) +import Pact.Types.Command qualified as Pact4 import Pact.Types.ExpParser (mkTextInfo, ParseEnv(..)) -import qualified Pact.Types.Hash as Pact4 +import Pact.Types.Hash qualified as Pact4 import Pact.Types.RPC -import qualified Pact.Types.Runtime as Pact4 -import qualified Pact.Types.SPV as Pact4 +import Pact.Types.Runtime qualified as Pact4 +import Pact.Types.SPV qualified as Pact4 +import Prelude hiding (lookup) +import System.LogLevel (LogLevel(..)) -import Chainweb.BlockHeader -import Chainweb.BlockHeight -import Chainweb.Logger -import Chainweb.Mempool.Mempool as Mempool -import Chainweb.MinerReward -import Chainweb.Miner.Pact +-- | Update init cache at adjusted parent block height (APBH). +-- Contents are merged with cache found at or before APBH. +-- APBH is 0 for genesis and (parent block height + 1) thereafter. +updateInitCache :: HasVersion => BlockCtx -> ModuleCache -> StateT ModuleInitCache IO () +updateInitCache bctx mc = get >>= \initCache -> do + let bf 0 = 0 + bf h = succ h + let pbh = bf (view (bctxParentHeight . _Parent) bctx) -import Chainweb.Pact.Types -import Chainweb.Pact4.SPV qualified as Pact4 -import Chainweb.Pact4.NoCoinbase -import qualified Chainweb.Pact4.Transaction as Pact4 -import qualified Chainweb.Pact4.TransactionExec as Pact4 -import qualified Chainweb.Pact4.Validations as Pact4 -import Chainweb.Payload -import Chainweb.Payload.PayloadStore -import Chainweb.Time -import Chainweb.Utils hiding (check) -import Chainweb.Version -import Chainweb.ForkState (pact4ForkNumber) -import Chainweb.Version.Guards -import Chainweb.Pact4.Backend.ChainwebPactDb -import Data.Coerce -import Data.Word -import GrowableVector.Lifted (Vec) -import Control.Monad.Primitive -import qualified GrowableVector.Lifted as Vec -import qualified Data.Set as S -import Chainweb.Pact4.Types -import Chainweb.Pact4.ModuleCache -import Control.Monad.Except -import qualified Data.List.NonEmpty as NE -import Chainweb.Pact.Backend.Types (BlockHandle(..)) + let cid = view chainId bctx + put $ case M.lookupLE pbh initCache of + Nothing -> M.singleton pbh mc + Just (_,before) + | cleanModuleCache cid pbh -> + M.insert pbh mc initCache + | otherwise -> M.insert pbh (before <> mc) initCache -- | Execute a block -- only called in validate either for replay or for validating current block. -- execBlock - :: (CanReadablePayloadCas tbl, Logger logger) - => BlockHeader - -- ^ this is the current header. We may consider changing this to the parent - -- header to avoid confusion with new block and prevent using data from this - -- header when we should use the respective values from the parent header - -- instead. + :: (CanReadablePayloadCas tbl, Logger logger1, Logger logger2) + => HasVersion + => logger1 + -> ServiceEnv tbl + -> BlockEnv logger2 -> CheckablePayload - -> PactBlockM logger tbl (Pact4.Gas, PayloadWithOutputs) -execBlock currHeader payload = do + -> ExceptT BlockInvalidError IO (Pact4.Gas, PayloadWithOutputs) +execBlock logger serviceEnv blockEnv payload = do let plData = checkablePayloadToPayloadData payload - dbEnv <- view psBlockDbEnv miner <- decodeStrictOrThrow' (_minerData $ view payloadDataMiner plData) + let currentHeight = blockEnv ^. benvBlockCtx . to _bctxCurrentBlockHeight - trans <- liftIO $ pact4TransactionsFromPayload - (pact4ParserVersion v (_chainId currHeader) (view blockHeight currHeader)) + trans <- pact4TransactionsFromPayload + (pact4ParserVersion (blockEnv ^. benvBlockCtx . chainId) currentHeight) plData - logger <- view (psServiceEnv . psLogger) -- The reference time for tx timings validation. -- -- The legacy behavior is to use the creation time of the /current/ header. -- The new default behavior is to use the creation time of the /parent/ header. -- - txValidationTime <- if isGenesisBlockHeader currHeader - then return (ParentCreationTime $ view blockCreationTime currHeader) - else ParentCreationTime . view blockCreationTime . _parentHeader <$> view psParentHeader + let txValidationTime = + if blockEnv ^. benvBlockCtx . to _bctxIsGenesis + then Parent $ implicitVersion ^?! versionGenesis . genesisTime . atChain (view chainId serviceEnv) + else blockEnv ^. benvBlockCtx . bctxParentCreationTime -- prop_tx_ttl_validate errorsIfPresent <- liftIO $ forM (V.toList trans) $ \tx -> fmap (Pact4._cmdHash tx,) $ runExceptT $ - validateParsedChainwebTx logger v cid dbEnv txValidationTime - (view blockHeight currHeader) tx + validateParsedChainwebTx logger cid (blockEnv ^. benvDbEnv) txValidationTime + currentHeight tx - case NE.nonEmpty [ (hsh, sshow err) | (hsh, Left err) <- errorsIfPresent ] of + case NE.nonEmpty + [ (Pact5.RequestKey $ Pact5.Hash hsh, err) + | (Pact4.toUntypedHash -> Pact4.Hash hsh, Left err) <- errorsIfPresent ] + of Nothing -> return () - Just errs -> throwM $ Pact4TransactionValidationException errs + Just errs -> throwError $ BlockInvalidDueToInvalidTxs (coerce errs) + + liftIO logInitCache - logInitCache + startModuleInitCache <- liftIO $ readMVar (_psModuleInitCacheVar serviceEnv) - !results <- go miner trans >>= throwCommandInvalidError + !(results, finalModuleInitCache) <- runStateT (go miner trans) startModuleInitCache + + _ <- liftIO $ swapMVar (_psModuleInitCacheVar serviceEnv) finalModuleInitCache let !totalGasUsed = sumOf (folded . to Pact4._crGas) results pwo <- either throwM return $ - validateHashes currHeader payload miner results + validateHashes (blockEnv ^. benvBlockCtx) payload miner results return (totalGasUsed, pwo) where blockGasLimit = - fromIntegral <$> maxBlockGasLimit v pact4ForkNumber (view blockHeight currHeader) + fromIntegral <$> maxBlockGasLimit pact4ForkNumber + (blockEnv ^. benvBlockCtx . to _bctxCurrentBlockHeight) - logInitCache = liftPactServiceM $ do - mc <- fmap (fmap instr . _getModuleCache) <$> use psInitCache - logDebugPact $ "execBlock: initCache: " <> sshow mc + logInitCache = do + mc <- fmap (fmap instr . _getModuleCache) <$> readMVar (_psModuleInitCacheVar serviceEnv) + liftIO $ logFunctionText logger Debug $ "execBlock: initCache: " <> sshow mc instr (md,_) = preview (Pact4._MDModule . Pact4.mHash) $ Pact4._mdModule md - v = _chainwebVersion currHeader - cid = _chainId currHeader + cid = blockEnv ^. benvBlockCtx . chainId - isGenesisBlock = isGenesisBlockHeader currHeader + isGenesisBlock = blockEnv ^. benvBlockCtx . to _bctxIsGenesis go m txs = if isGenesisBlock then -- GENESIS VALIDATE COINBASE: Reject bad coinbase, use date rule for precompilation - execTransactions m txs - (EnforceCoinbaseFailure True) (CoinbaseUsePrecompiled False) blockGasLimit Nothing + execTransactions logger serviceEnv blockEnv m txs + (EnforceCoinbaseFailure True) (CoinbaseUsePrecompiled False) blockGasLimit else -- VALIDATE COINBASE: back-compat allow failures, use date rule for precompilation - execTransactions m txs - (EnforceCoinbaseFailure False) (CoinbaseUsePrecompiled False) blockGasLimit Nothing - -throwCommandInvalidError - :: Transactions Pact4 (Either CommandInvalidError a) - -> PactBlockM logger tbl (Transactions Pact4 a) -throwCommandInvalidError = (transactionPairs . traverse . _2) throwGasFailure - where - throwGasFailure = \case - Left (CommandInvalidGasPurchaseFailure e) -> throwM (Pact4BuyGasFailure e) - - -- this should be impossible because we don't - -- set tx time limits in validateBlock - Left (CommandInvalidTxTimeout t) -> throwM t - - Right r -> pure r + execTransactions logger serviceEnv blockEnv m txs + (EnforceCoinbaseFailure False) (CoinbaseUsePrecompiled False) blockGasLimit -- | The validation logic for Pact Transactions that have not had their -- code parsed yet. This is used by the mempool to estimate tx validity @@ -212,19 +207,19 @@ throwCommandInvalidError = (transactionPairs . traverse . _2) throwGasFailure validateRawChainwebTx :: forall logger . (Logger logger) + => HasVersion => logger - -> ChainwebVersion -> ChainId - -> PactDbFor logger Pact4 - -> ParentCreationTime + -> CurrentBlockDbEnv logger + -> Parent BlockCreationTime -- ^ reference time for tx validation. -> BlockHeight -- ^ Current block height -> Pact4.UnparsedTransaction -> ExceptT InsertError IO Pact4.Transaction -validateRawChainwebTx logger v cid dbEnv txValidationTime bh tx = do - parsed <- checkParse logger v cid bh tx - validateParsedChainwebTx logger v cid dbEnv txValidationTime bh parsed +validateRawChainwebTx logger cid dbEnv txValidationTime bh tx = do + parsed <- checkParse logger cid bh tx + validateParsedChainwebTx logger cid dbEnv txValidationTime bh parsed return parsed -- | The principal validation logic for groups of Pact Transactions. @@ -236,40 +231,40 @@ validateRawChainwebTx logger v cid dbEnv txValidationTime bh tx = do -- exist yet. -- validateParsedChainwebTx - :: Logger logger - => logger - -> ChainwebVersion + :: (Logger logger1, Logger logger2) + => HasVersion + => logger1 -> ChainId - -> PactDbFor logger Pact4 - -> ParentCreationTime + -> CurrentBlockDbEnv logger2 + -> Parent BlockCreationTime -- ^ reference time for tx validation. -> BlockHeight -- ^ Current block height -> Pact4.Transaction -> ExceptT InsertError IO () -validateParsedChainwebTx logger v cid dbEnv txValidationTime bh tx - | bh == genesisHeight v cid = pure () +validateParsedChainwebTx logger cid dbEnv txValidationTime bh tx + | bh == genesisHeight cid = pure () | otherwise = do checkUnique logger dbEnv tx - checkTxHash logger v cid bh tx + checkTxHash logger cid bh tx checkChain cid tx - checkTxSigs logger v cid bh tx - checkTimes logger v cid bh txValidationTime tx - _ <- checkCompile logger v cid bh tx + checkTxSigs logger cid bh tx + checkTimes logger cid bh txValidationTime tx + _ <- checkCompile logger cid bh tx return () checkChain :: ChainId -> Pact4.Transaction -> ExceptT InsertError IO () checkChain cid tx = unless (Pact4.assertChainId cid txCid) $ - throwError $ InsertErrorWrongChain (chainIdToText cid) (Pact4._chainId txCid) + throwError $ InsertErrorWrongChain (toText cid) (Pact4._chainId txCid) where txCid = view (Pact4.cmdPayload . to Pact4.payloadObj . Pact4.pMeta . Pact4.pmChainId) tx checkUnique - :: (Logger logger) - => logger - -> PactDbFor logger Pact4 + :: (Logger logger1, Logger logger2) + => logger1 + -> CurrentBlockDbEnv logger2 -> Pact4.Command (Pact4.PayloadWithText meta code) -> ExceptT InsertError IO () checkUnique logger dbEnv t = do @@ -284,16 +279,16 @@ checkUnique logger dbEnv t = do checkTimes :: (Logger logger) + => HasVersion => logger - -> ChainwebVersion -> ChainId -> BlockHeight - -> ParentCreationTime + -> Parent BlockCreationTime -> Pact4.Command (Pact4.PayloadWithText Pact4.PublicMeta code) -> ExceptT InsertError IO () -checkTimes logger v cid bh txValidationTime t = do +checkTimes logger cid bh txValidationTime t = do liftIO $ logFunctionText logger Debug $ "Pact4.checkTimes: " <> sshow (Pact4._cmdHash t) - if | skipTxTimingValidation v cid bh -> + if | skipTxTimingValidation cid bh -> return () | not (Pact4.assertTxNotInFuture txValidationTime (Pact4.payloadObj <$> t)) -> throwError InsertErrorTimeInFuture @@ -304,51 +299,51 @@ checkTimes logger v cid bh txValidationTime t = do checkTxHash :: (Logger logger) + => HasVersion => logger - -> ChainwebVersion -> ChainId -> BlockHeight -> Pact4.Command (Pact4.PayloadWithText Pact4.PublicMeta code) -> ExceptT InsertError IO () -checkTxHash logger v cid bh t = do +checkTxHash logger cid bh t = do liftIO $ logFunctionText logger Debug $ "Pact4.checkTxHash: " <> sshow (Pact4._cmdHash t) case Pact4.verifyHash (Pact4._cmdHash t) (SB.fromShort $ Pact4.payloadBytes $ Pact4._cmdPayload t) of Left _ - | doCheckTxHash v cid bh -> throwError InsertErrorInvalidHash + | doCheckTxHash cid bh -> throwError InsertErrorInvalidHash | otherwise -> pure () Right _ -> pure () checkTxSigs :: (MonadIO f, MonadError InsertError f, Logger logger) + => HasVersion => logger - -> ChainwebVersion -> ChainId -> BlockHeight -> Pact4.Command (Pact4.PayloadWithText m c) -> f () -checkTxSigs logger v cid bh t = do +checkTxSigs logger cid bh t = do liftIO $ logFunctionText logger Debug $ "Pact4.checkTxSigs: " <> sshow (Pact4._cmdHash t) case Pact4.assertValidateSigs validSchemes webAuthnPrefixLegal hsh signers sigs of Right _ -> do pure () Left err -> do - throwError $ InsertErrorInvalidSigs (displayAssertValidateSigsError err) + throwError $ InsertErrorInvalidSigs (Pact4.displayAssertValidateSigsError err) where hsh = Pact4._cmdHash t sigs = Pact4._cmdSigs t signers = Pact4._pSigners $ Pact4.payloadObj $ Pact4._cmdPayload t - validSchemes = validPPKSchemes v cid bh - webAuthnPrefixLegal = isWebAuthnPrefixLegal v cid bh + validSchemes = validPPKSchemes cid bh + webAuthnPrefixLegal = isWebAuthnPrefixLegal cid bh checkCompile :: (Logger logger) + => HasVersion => logger - -> ChainwebVersion -> ChainId -> BlockHeight -> Pact4.Command (Pact4.PayloadWithText Pact4.PublicMeta Pact4.ParsedCode) -> ExceptT InsertError IO Pact4.Transaction -checkCompile logger v cid bh tx = do +checkCompile logger cid bh tx = do liftIO $ logFunctionText logger Debug $ "Pact4.checkCompile: " <> sshow (Pact4._cmdHash tx) case payload of Exec (ExecMsg parsedCode _) -> @@ -359,163 +354,140 @@ checkCompile logger v cid bh tx = do where payload = Pact4._pPayload $ Pact4.payloadObj $ Pact4._cmdPayload tx compileCode p = - let e = ParseEnv (chainweb216Pact v cid bh) + let e = ParseEnv (chainweb216Pact cid bh) in compileExps e (mkTextInfo (Pact4._pcCode p)) (Pact4._pcExps p) checkParse :: (Logger logger) + => HasVersion => logger - -> ChainwebVersion -> ChainId -> BlockHeight -> Pact4.Command (Pact4.PayloadWithText Pact4.PublicMeta Text) -> ExceptT InsertError IO Pact4.Transaction -checkParse logger v cid bh tx = do +checkParse logger cid bh tx = do liftIO $ logFunctionText logger Debug $ "Pact4.checkParse: " <> sshow (Pact4._cmdHash tx) forMOf (traversed . traversed) tx - (either (throwError . InsertErrorPactParseError . T.pack) return . Pact4.parsePact (pact4ParserVersion v cid bh)) + (either (throwError . InsertErrorPactParseError . T.pack) return . Pact4.parsePact (pact4ParserVersion cid bh)) execTransactions - :: (Logger logger) - => Miner + :: (Logger logger1, Logger logger2) + => HasVersion + => logger1 + -> ServiceEnv tbl + -> BlockEnv logger2 + -> Miner -> Vector Pact4.Transaction -> EnforceCoinbaseFailure -> CoinbaseUsePrecompiled -> Maybe Pact4.Gas - -> Maybe Micros - -> PactBlockM logger tbl (Transactions Pact4 (Either CommandInvalidError (Pact4.CommandResult [Pact4.TxLogJson]))) -execTransactions miner ctxs enfCBFail usePrecomp gasLimit timeLimit = do - mc <- initModuleCacheForBlock + -> StateT ModuleInitCache (ExceptT BlockInvalidError IO) (Transactions Pact4.Transaction ((Pact4.CommandResult [Pact4.TxLogJson]))) +execTransactions logger serviceEnv blockEnv miner ctxs enfCBFail usePrecomp gasLimit = do + mc <- mapStateT lift $ initModuleCacheForBlock logger blockEnv -- for legacy reasons (ask Emily) we don't use the module cache resulting -- from coinbase to run the pact cmds - coinOut <- runCoinbase miner enfCBFail usePrecomp mc - T2 txOuts _mcOut <- applyPactCmds ctxs miner mc gasLimit timeLimit - return $! Transactions (V.zip ctxs txOuts) coinOut - -initModuleCacheForBlock :: (Logger logger) => PactBlockM logger tbl ModuleCache -initModuleCacheForBlock = do - PactServiceState{..} <- get - isGenesis <- view psIsGenesis - pbh <- views psParentHeader (view blockHeight . _parentHeader) - case Map.lookupLE pbh _psInitCache of + coinOut <- mapStateT lift $ runCoinbase logger enfCBFail usePrecomp blockEnv miner mc + T2 txOuts _mcOut <- lift $ applyPactCmds logger serviceEnv blockEnv ctxs miner mc gasLimit + return $! Transactions (V.zipWith T2 ctxs txOuts) coinOut + +initModuleCacheForBlock + :: (Logger logger1, Logger logger2) + => HasVersion + => logger1 + -> BlockEnv logger2 + -> StateT ModuleInitCache IO ModuleCache +initModuleCacheForBlock logger blockEnv = do + moduleInitCache <- get + let pbh = blockEnv ^. benvBlockCtx . bctxParentHeight . _Parent + let isGenesis = blockEnv ^. benvBlockCtx . to _bctxIsGenesis + case Map.lookupLE pbh moduleInitCache of Nothing -> if isGenesis then return mempty else do - mc <- Pact4.readInitModules - updateInitCacheM mc + mc <- liftIO $ Pact4.readInitModules logger blockEnv + updateInitCache (blockEnv ^. benvBlockCtx) mc return mc Just (_,mc) -> pure mc runCoinbase - :: (Logger logger) - => Miner + :: (Logger logger1, Logger logger2) + => HasVersion + => logger1 -> EnforceCoinbaseFailure -> CoinbaseUsePrecompiled + -> BlockEnv logger2 + -> Miner -> ModuleCache - -> PactBlockM logger tbl (Pact4.CommandResult [Pact4.TxLogJson]) -runCoinbase miner enfCBFail usePrecomp mc = do - isGenesis <- view psIsGenesis - if isGenesis + -> StateT ModuleInitCache IO (Pact4.CommandResult [Pact4.TxLogJson]) +runCoinbase logger enfCBFail usePrecomp blockEnv miner mc = do + if blockEnv ^. benvBlockCtx . to _bctxIsGenesis then return noCoinbase else do - logger <- view (psServiceEnv . psLogger) - v <- view chainwebVersion - txCtx <- getTxContext miner Pact4.noPublicMeta - - let !bh = ctxCurrentBlockHeight txCtx + let !bh = _bctxCurrentBlockHeight (blockEnv ^. benvBlockCtx) - let reward = minerReward v bh - dbEnv <- view psBlockDbEnv - let pactDb = _cpPactDbEnv dbEnv + let reward = minerReward bh T2 cr upgradedCacheM <- - liftIO $ Pact4.applyCoinbase v logger pactDb reward txCtx enfCBFail usePrecomp mc + liftIO $ Pact4.applyCoinbase logger blockEnv miner reward enfCBFail usePrecomp mc mapM_ upgradeInitCache upgradedCacheM - liftPactServiceM $ debugResult "runPact4Coinbase" (Pact4.crLogs %~ fmap J.Array $ cr) return $! cr where upgradeInitCache newCache = do - liftPactServiceM $ logInfoPact "Updating init cache for upgrade" - updateInitCacheM newCache + liftIO $ logFunctionText logger Info "Updating init cache for upgrade" + updateInitCache (blockEnv ^. benvBlockCtx) newCache -data CommandInvalidError - = CommandInvalidGasPurchaseFailure !Pact4GasPurchaseFailure - | CommandInvalidTxTimeout !TxTimeout - -- | Apply multiple Pact commands, incrementing the transaction Id for each. -- The output vector is in the same order as the input (i.e. you can zip it -- with the inputs.) applyPactCmds - :: forall logger tbl. (Logger logger) - => Vector Pact4.Transaction + :: forall logger1 logger2 tbl. (Logger logger1, Logger logger2) + => HasVersion + => logger1 + -> ServiceEnv tbl + -> BlockEnv logger2 + -> Vector Pact4.Transaction -> Miner -> ModuleCache -> Maybe Pact4.Gas - -> Maybe Micros - -> PactBlockM logger tbl (T2 (Vector (Either CommandInvalidError (Pact4.CommandResult [Pact4.TxLogJson]))) ModuleCache) -applyPactCmds cmds miner startModuleCache blockGas txTimeLimit = do - let txsGas txs = fromIntegral $ sumOf (traversed . _Right . to Pact4._crGas) txs - (txOuts, T2 mcOut _) <- tracePactBlockM' "applyPactCmds" (\_ -> ()) (txsGas . fst) $ + -> ExceptT BlockInvalidError IO (T2 (Vector ((Pact4.CommandResult [Pact4.TxLogJson]))) ModuleCache) +applyPactCmds logger serviceEnv blockEnv cmds miner startModuleCache blockGas = do + (txOuts, T2 mcOut _) <- flip runStateT (T2 startModuleCache blockGas) $ go [] (zip [0..] $ V.toList cmds) return $! T2 (V.fromList . List.reverse $ txOuts) mcOut where go - :: [Either CommandInvalidError (Pact4.CommandResult [Pact4.TxLogJson])] + :: [Pact4.CommandResult [Pact4.TxLogJson]] -> [(Word, Pact4.Transaction)] -> StateT (T2 ModuleCache (Maybe Pact4.Gas)) - (PactBlockM logger tbl) - [Either CommandInvalidError (Pact4.CommandResult [Pact4.TxLogJson])] + (ExceptT BlockInvalidError IO) + [Pact4.CommandResult [Pact4.TxLogJson]] go !acc = \case [] -> do pure acc (txIdxInBlock, tx) : rest -> do - r <- applyPactCmd (TxBlockIdx txIdxInBlock) miner txTimeLimit tx - case r of - Left e@(CommandInvalidTxTimeout _) -> do - pure (Left e : acc) - Left e@(CommandInvalidGasPurchaseFailure _) -> do - go (Left e : acc) rest - Right a -> do - go (Right a : acc) rest + r <- applyPactCmd logger serviceEnv blockEnv (TxBlockIdx txIdxInBlock) miner tx + go (r : acc) rest applyPactCmd - :: (Logger logger) - => TxIdxInBlock + :: (Logger logger1, Logger logger2) + => HasVersion + => logger1 + -> ServiceEnv tbl + -> BlockEnv logger2 + -> TxIdxInBlock -> Miner - -> Maybe Micros -> Pact4.Transaction -> StateT (T2 ModuleCache (Maybe Pact4.Gas)) - (PactBlockM logger tbl) - (Either CommandInvalidError (Pact4.CommandResult [Pact4.TxLogJson])) -applyPactCmd txIdxInBlock miner txTimeLimit cmd = StateT $ \(T2 mcache maybeBlockGasRemaining) -> do - dbEnv <- view psBlockDbEnv - let pactDb = _cpPactDbEnv dbEnv - prevBlockState <- liftIO $ fmap _benvBlockState $ - readMVar $ pdPactDbVar pactDb - logger <- view (psServiceEnv . psLogger) - gasLogger <- view (psServiceEnv . psGasLogger) - txFailuresCounter <- view (psServiceEnv . psTxFailuresCounter) - isGenesis <- view psIsGenesis - v <- view chainwebVersion + (ExceptT BlockInvalidError IO) + (Pact4.CommandResult [Pact4.TxLogJson]) +applyPactCmd logger _serviceEnv blockEnv txIdxInBlock miner cmd = StateT $ \(T2 mcache maybeBlockGasRemaining) -> do + let pactDb = blockEnv ^. benvDbEnv . cpPactDbEnv let - -- for errors so fatal that the tx doesn't make it in the block - onFatalError e - | Just (Pact4BuyGasFailure f) <- fromException e = pure (Left (CommandInvalidGasPurchaseFailure f), T2 mcache maybeBlockGasRemaining) - | Just t@(TxTimeout {}) <- fromException e = do - -- timeouts can occur at any point during the transaction, even after - -- gas has been bought (or even while gas is being redeemed, after the - -- transaction proper is done). therefore we need to revert the block - -- state ourselves if it happens. - liftIO $ Pact4.modifyMVar' - (pdPactDbVar pactDb) - (benvBlockState .~ prevBlockState) - pure (Left (CommandInvalidTxTimeout t), T2 mcache maybeBlockGasRemaining) - | otherwise = throwM e requestedTxGasLimit = view Pact4.cmdGasLimit (Pact4.payloadObj <$> cmd) -- notice that we add 1 to the remaining block gas here, to distinguish the -- cases "tx used exactly as much gas remained in the block" (which is fine) @@ -531,54 +503,49 @@ applyPactCmd txIdxInBlock miner txTimeLimit cmd = StateT $ \(T2 mcache maybeBloc initialGas = Pact4.initialGasOf (Pact4._cmdPayload cmd) let !hsh = Pact4._cmdHash cmd - handle onFatalError $ do - T2 result mcache' <- do - txCtx <- getTxContext miner (Pact4.publicMetaOf gasLimitedCmd) - let gasModel = getGasModel txCtx - if isGenesis - then liftIO $! Pact4.applyGenesisCmd logger pactDb Pact4.noSPVSupport txCtx gasLimitedCmd - else do - bhdb <- view (psServiceEnv . psBlockHeaderDb) - parent <- view psParentHeader - let spv = Pact4.pactSPV bhdb (_parentHeader parent) - let - !timeoutError = TxTimeout (pact4RequestKeyToTransactionHash $ Pact4.cmdToRequestKey cmd) - txTimeout io = case txTimeLimit of - Nothing -> do - logFunctionText logger Debug $ "txTimeLimit was not set - defaulting to a function of the block gas limit" - io - Just limit -> do - logFunctionText logger Debug $ "txTimeLimit was " <> sshow limit - maybe (throwM timeoutError) return =<< newTimeout (fromIntegral limit) io - txGas (T3 r _ _) = fromIntegral $ Pact4._crGas r - T3 r c _warns <- do - tracePactBlockM' "applyCmd" (\_ -> J.toJsonViaEncode hsh) txGas $ do - liftIO $ txTimeout $ - Pact4.applyCmd v logger gasLogger txFailuresCounter pactDb miner gasModel txCtx txIdxInBlock spv gasLimitedCmd initialGas mcache ApplySend - pure $ T2 r c - - if isGenesis - then updateInitCacheM mcache' - else liftPactServiceM $ debugResult "applyPactCmd" (Pact4.crLogs %~ fmap J.Array $ result) - - -- mark the tx as processed at the checkpointer. - liftIO $ _cpRegisterProcessedTx dbEnv (coerce $ Pact4.toUntypedHash hsh) - case maybeBlockGasRemaining of - Just blockGasRemaining - | Left _ <- Pact4._pactResult (Pact4._crResult result) - , blockGasRemaining < fromIntegral requestedTxGasLimit - -> throwM $ BlockGasLimitExceeded (fromIntegral requestedTxGasLimit - blockGasRemaining) - -- ^ this tx attempted to consume more gas than remains in the - -- block, so the block is invalid. we know this because failing - -- transactions consume their entire gas limit. - _ -> return () - let maybeBlockGasRemaining' = (\g -> g - Pact4._crGas result) <$> maybeBlockGasRemaining - pure (Right result, T2 mcache' maybeBlockGasRemaining') + T2 result mcache' <- do + let gasModel = getGasModel bCtx + if _bctxIsGenesis bCtx + then liftIO $! Pact4.applyGenesisCmd logger pactDb Pact4.noSPVSupport bCtx gasLimitedCmd + else do + let spv = Pact4.pactSPV (_cpHeaderOracle $ _benvDbEnv blockEnv) bCtx + let + txTimeout io = do + logFunctionText logger Debug $ "txTimeLimit was not set - defaulting to a function of the block gas limit" + io + T3 r c _warns <- do + liftIO $ txTimeout $ + Pact4.applyCmd logger + -- FIXME spv + blockEnv miner gasModel txIdxInBlock spv gasLimitedCmd initialGas mcache + pure $ T2 r c + + if _bctxIsGenesis bCtx + then return () + -- FIXME: what? why are we doing this here? is this a bug? + -- _k $ updateInitCache (bCtx ^. tcParentHeader) mcache' + else liftIO $ debugResult logger "applyPactCmd" (Pact4.crLogs %~ fmap J.Array $ result) + + -- mark the tx as processed at the checkpointer. + liftIO $ _cpRegisterProcessedTx (blockEnv ^. benvDbEnv) (coerce $ Pact4.toUntypedHash hsh) + case maybeBlockGasRemaining of + Just blockGasRemaining + | Left _ <- Pact4._pactResult (Pact4._crResult result) + , blockGasRemaining < fromIntegral requestedTxGasLimit + -> throwError $ BlockInvalidDueToInvalidTxAtRuntime TxExceedsBlockGasLimit + -- ^ this tx attempted to consume more gas than remains in the + -- block, so the block is invalid. we know this because failing + -- transactions consume their entire gas limit. + _ -> return () + let maybeBlockGasRemaining' = (\g -> g - Pact4._crGas result) <$> maybeBlockGasRemaining + pure (result, T2 mcache' maybeBlockGasRemaining') + where + bCtx = blockEnv ^. benvBlockCtx pact4TransactionsFromPayload :: Pact4.PactParserVersion -> PayloadData - -> IO (Vector Pact4.Transaction) + -> ExceptT BlockInvalidError IO (Vector Pact4.Transaction) pact4TransactionsFromPayload ppv plData = do vtrans <- fmap V.fromList $ mapM toCWTransaction $ @@ -586,16 +553,16 @@ pact4TransactionsFromPayload ppv plData = do let (theLefts, theRights) = partitionEithers $ V.toList vtrans unless (null theLefts) $ do let ls = map T.pack theLefts - throwM $ TransactionDecodeFailure $ "Failed to decode pact transactions: " - <> T.intercalate ". " ls + throwError $ BlockInvalidDueToTxDecodeFailure ls return $! V.fromList theRights where - toCWTransaction bs = evaluate (force (codecDecode (Pact4.payloadCodec ppv) $ - _transactionBytes bs)) + toCWTransaction bs = + liftIO $ evaluate $ + codecDecode (Pact4.payloadCodec ppv) (_transactionBytes bs) -debugResult :: J.Encode a => Logger logger => Text -> a -> PactServiceM logger tbl () -debugResult msg result = - logDebugPact $ trunc $ msg <> " result: " <> J.encodeText result +debugResult :: J.Encode a => Logger logger => logger -> Text -> a -> IO () +debugResult logger msg result = + logFunctionText logger Debug $ trunc $ msg <> " result: " <> J.encodeText result where trunc t | T.length t < limit = t | otherwise = T.take limit t <> " [truncated]" @@ -607,13 +574,13 @@ debugResult msg result = -- See: 'rewards/miner_rewards.csv' -- minerReward - :: ChainwebVersion - -> BlockHeight + :: HasVersion + => BlockHeight -> Pact4.ParsedDecimal -minerReward v = Pact4.ParsedDecimal +minerReward = Pact4.ParsedDecimal . _kda . minerRewardKda - . blockMinerReward v + . blockMinerReward {-# INLINE minerReward #-} data CRLogPair = CRLogPair Pact4.Hash [Pact4.TxLogJson] @@ -626,262 +593,27 @@ instance J.Encode CRLogPair where {-# INLINE build #-} validateHashes - :: BlockHeader + :: HasVersion + => BlockCtx -- ^ Current Header -> CheckablePayload -> Miner - -> Transactions Pact4 (Pact4.CommandResult [Pact4.TxLogJson]) - -> Either PactException PayloadWithOutputs -validateHashes bHeader payload miner transactions = - if newHash == prevHash + -> Transactions Pact4.Transaction (Pact4.CommandResult [Pact4.TxLogJson]) + -> Either PactInternalError PayloadWithOutputs +validateHashes bctx payload miner transactions = + if newHash == expectedPayloadHash then Right actualPwo - else Left $ BlockValidationFailure $ BlockValidationFailureMsg $ + else Left $ BlockValidationFailure $ J.encodeText $ J.object - [ "header" J..= J.encodeWithAeson (ObjectEncoded bHeader) + [ "header" J..= sshow @_ @Text bctx , "actual" J..= J.encodeWithAeson actualPwo , "expected" J..?= case payload of - CheckablePayload _ -> Nothing + CheckablePayload _ _ -> Nothing CheckablePayloadWithOutputs pwo -> Just $ J.encodeWithAeson pwo ] where - actualPwo = toPayloadWithOutputs Pact4T miner transactions + actualPwo = toPayloadWithOutputs miner transactions newHash = _payloadWithOutputsPayloadHash actualPwo - prevHash = view blockPayloadHash bHeader - -type GrowableVec = Vec (PrimState IO) - --- | Continue adding transactions to an existing block. -continueBlock - :: forall logger tbl - . (Logger logger, CanReadablePayloadCas tbl) - => MemPoolAccess - -> BlockInProgress Pact4 - -> PactBlockM logger tbl (BlockInProgress Pact4) -continueBlock mpAccess blockInProgress = do - v <- view chainwebVersion - cid <- view chainId - ParentHeader parent <- view psParentHeader - let pHeight = view blockHeight parent - let pHash = view blockHash parent - liftIO $ do - mpaProcessFork mpAccess parent - mpaSetLastHeader mpAccess parent - liftPactServiceM $ - logInfoPact $ "(parent height = " <> sshow pHeight <> ")" - <> " (parent hash = " <> sshow pHash <> ")" - - blockDbEnv <- view psBlockDbEnv - let pactDb = _cpPactDbEnv blockDbEnv - -- restore the block state from the block being continued - liftIO $ - modifyMVar_ (pdPactDbVar pactDb) $ \blockEnv -> - return - $! blockEnv - & benvBlockState . bsPendingBlock .~ _blockHandlePending (_blockInProgressHandle blockInProgress) - & benvBlockState . bsTxId .~ _blockHandleTxId (_blockInProgressHandle blockInProgress) - - blockGasLimit <- view (psServiceEnv . psBlockGasLimit) - mTxTimeLimit <- view (psServiceEnv . psTxTimeLimit) - - let txTimeHeadroomFactor :: Double - txTimeHeadroomFactor = 5 - let txTimeLimit :: Micros - -- 2.5 microseconds per unit gas - txTimeLimit = fromMaybe - (round $ (2.5 * txTimeHeadroomFactor) * fromIntegral blockGasLimit) - mTxTimeLimit - - let Pact4ModuleCache initCache = _blockInProgressModuleCache blockInProgress - let cb = _transactionCoinbase (_blockInProgressTransactions blockInProgress) - let startTxs = _transactionPairs (_blockInProgressTransactions blockInProgress) - - successes <- liftIO $ Vec.fromFoldable startTxs - failures <- liftIO $ Vec.new @_ @_ @TransactionHash - - let initState = BlockFill - (_blockInProgressRemainingGasLimit blockInProgress) - (S.fromList $ pact4RequestKeyToTransactionHash . Pact4._crReqKey . snd <$> V.toList startTxs) - 0 - - -- Heuristic: limit fetches to count of 1000-gas txs in block. - let fetchLimit = fromIntegral $ blockGasLimit `div` 1000 - T2 - finalModuleCache - BlockFill { _bfTxHashes = requestKeys, _bfGasLimit = finalGasLimit } - <- refill fetchLimit txTimeLimit successes failures initCache initState - - liftPactServiceM $ logInfoPact $ "(request keys = " <> sshow requestKeys <> ")" - - liftIO $ do - txHashes <- Vec.toLiftedVector failures - mpaBadlistTx mpAccess txHashes - - txs <- liftIO $ Vec.toLiftedVector successes - -- edmund: we need to be careful about timeouts. - -- If a tx times out, it must not be in the block state, otherwise - -- the "block in progress" will contain pieces of state from that tx. - -- - -- this cannot happen now because applyPactCmd doesn't let it. - finalBlockState <- fmap _benvBlockState - $ liftIO - $ readMVar - $ pdPactDbVar - $ pactDb - let !blockInProgress' = BlockInProgress - { _blockInProgressModuleCache = Pact4ModuleCache finalModuleCache - , _blockInProgressHandle = BlockHandle - { _blockHandleTxId = _bsTxId finalBlockState - , _blockHandlePending = _bsPendingBlock finalBlockState - } - , _blockInProgressParentHeader = newBlockParent - , _blockInProgressRemainingGasLimit = finalGasLimit - , _blockInProgressTransactions = Transactions - { _transactionCoinbase = cb - , _transactionPairs = txs - } - , _blockInProgressMiner = _blockInProgressMiner blockInProgress - , _blockInProgressPactVersion = Pact4T - , _blockInProgressChainwebVersion = v - , _blockInProgressChainId = cid - } - return blockInProgress' - where - newBlockParent = _blockInProgressParentHeader blockInProgress - - - getBlockTxs :: BlockFill -> PactBlockM logger tbl (Vector Pact4.Transaction) - getBlockTxs bfState = do - dbEnv <- view psBlockDbEnv - psEnv <- ask - let v = _chainwebVersion psEnv - cid = _chainId psEnv - logger <- view (psServiceEnv . psLogger) - -- parent time needs to know if we're *actually* at genesis - let parentTime = - maybe - (v ^?! versionGenesis . genesisTime . atChain cid) - (view blockCreationTime . _parentHeader) - newBlockParent - ParentHeader parent <- view psParentHeader - let pHeight = view blockHeight parent - let pHash = view blockHash parent - let validate bhi _bha txs = forM txs $ \tx -> runExceptT $ do - validateRawChainwebTx logger v cid dbEnv (ParentCreationTime parentTime) bhi tx - - liftIO $! - mpaGetBlock mpAccess bfState validate (pHeight + 1) pHash parentTime - - refill - :: Word64 - -> Micros - -> GrowableVec (Pact4.Transaction, Pact4.CommandResult [Pact4.TxLogJson]) - -> GrowableVec TransactionHash - -> ModuleCache - -> BlockFill - -> PactBlockM logger tbl (T2 ModuleCache BlockFill) - refill fetchLimit txTimeLimit successes failures = go - where - go :: ModuleCache -> BlockFill -> PactBlockM logger tbl (T2 ModuleCache BlockFill) - go mc unchanged@bfState = do - - case unchanged of - BlockFill g _ c -> do - (goodLength, badLength) <- liftIO $ (,) <$> Vec.length successes <*> Vec.length failures - liftPactServiceM $ logDebugPact $ "Block fill: count=" <> sshow c - <> ", gaslimit=" <> sshow g <> ", good=" - <> sshow goodLength <> ", bad=" <> sshow badLength - - -- LOOP INVARIANT: limit absolute recursion count - if _bfCount bfState > fetchLimit then liftPactServiceM $ do - logInfoPact $ "Refill fetch limit exceeded (" <> sshow fetchLimit <> ")" - pure (T2 mc unchanged) - else do - when (_bfGasLimit bfState < 0) $ - throwM $ MempoolFillFailure $ "Internal error, negative gas limit: " <> sshow bfState - - if _bfGasLimit bfState == 0 then pure (T2 mc unchanged) else do - - newTrans <- getBlockTxs bfState - if V.null newTrans then pure (T2 mc unchanged) else do - - T2 pairs mc' <- do - T2 txOuts mcOut <- applyPactCmds newTrans (_blockInProgressMiner blockInProgress) mc Nothing (Just txTimeLimit) - return $! T2 (V.force (V.zip newTrans txOuts)) mcOut - - oldSuccessesLength <- liftIO $ Vec.length successes - - (newState, timedOut) <- splitResults successes failures unchanged (V.toList pairs) - - -- LOOP INVARIANT: gas must not increase - when (_bfGasLimit newState > _bfGasLimit bfState) $ - throwM $ MempoolFillFailure $ "Gas must not increase: " <> sshow (bfState,newState) - - newSuccessesLength <- liftIO $ Vec.length successes - let addedSuccessCount = newSuccessesLength - oldSuccessesLength - - if timedOut - then - -- a transaction timed out, so give up early and make the block - pure (T2 mc' (incCount newState)) - else if _bfGasLimit newState >= _bfGasLimit bfState && addedSuccessCount > 0 - then - -- INVARIANT: gas must decrease if any transactions succeeded - throwM $ MempoolFillFailure - $ "Invariant failure, gas did not decrease: " - <> sshow (bfState,newState,V.length newTrans,addedSuccessCount) - else - go mc' (incCount newState) - - incCount :: BlockFill -> BlockFill - incCount b = over bfCount succ b - - -- | Split the results of applying each command into successes and failures, - -- and return the final 'BlockFill'. - -- - -- If we encounter a 'TxTimeout', we short-circuit, and only return - -- what we've put into the block before the timeout. We also report - -- that we timed out, so that `refill` can stop early. - -- - -- The failed txs are later badlisted. - splitResults :: () - => GrowableVec (Pact4.Transaction, Pact4.CommandResult [Pact4.TxLogJson]) - -> GrowableVec TransactionHash -- ^ failed txs - -> BlockFill - -> [(Pact4.Transaction, Either CommandInvalidError (Pact4.CommandResult [Pact4.TxLogJson]))] - -> PactBlockM logger tbl (BlockFill, Bool) - splitResults successes failures = go - where - go acc@(BlockFill g rks i) = \case - [] -> pure (acc, False) - (t, r) : rest -> case r of - Right cr -> do - !rks' <- enforceUnique rks (pact4RequestKeyToTransactionHash $ Pact4._crReqKey cr) - -- Decrement actual gas used from block limit - let !g' = g - fromIntegral (Pact4._crGas cr) - liftIO $ Vec.push successes (t, cr) - go (BlockFill g' rks' i) rest - Left (CommandInvalidGasPurchaseFailure (Pact4GasPurchaseFailure h _)) -> do - !rks' <- enforceUnique rks h - -- Gas buy failure adds failed request key to fail list only - liftIO $ Vec.push failures h - go (BlockFill g rks' i) rest - Left (CommandInvalidTxTimeout (TxTimeout h)) -> do - liftIO $ Vec.push failures h - liftPactServiceM $ logErrorPact $ "timed out on " <> sshow h - return (acc, True) - - enforceUnique rks rk - | S.member rk rks = - throwM $ MempoolFillFailure $ "Duplicate transaction: " <> sshow rk - | otherwise = return $ S.insert rk rks - --- | This timeout variant returns Nothing if the timeout elapsed, regardless of whether or not it was actually able to interrupt its argument. --- This is more robust in the face of scheduler behavior than the standard 'System.Timeout.timeout', with small timeouts. -newTimeout :: Int -> IO a -> IO (Maybe a) -newTimeout n f = do - (timeSpan, a) <- Chronos.stopwatch (timeout n f) - if Chronos.getTimespan timeSpan > fromIntegral (n * 1000) - then return Nothing - else return a + expectedPayloadHash = checkablePayloadExpectedHash payload diff --git a/src/Chainweb/Pact/PactService/Pact5/ExecBlock.hs b/src/Chainweb/Pact/PactService/Pact5/ExecBlock.hs deleted file mode 100644 index 567da7aa93..0000000000 --- a/src/Chainweb/Pact/PactService/Pact5/ExecBlock.hs +++ /dev/null @@ -1,685 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE ImportQualifiedPost #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE MultiWayIf #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PackageImports #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE ViewPatterns #-} - -module Chainweb.Pact.PactService.Pact5.ExecBlock - ( runCoinbase - , continueBlock - , execExistingBlock - , validateRawChainwebTx - , validateParsedChainwebTx - - ) where - -import Chainweb.BlockHeader -import Chainweb.BlockHeight -import Chainweb.Logger -import Chainweb.Mempool.Mempool(BlockFill (..), pact5RequestKeyToTransactionHash, InsertError (..)) -import Chainweb.MinerReward -import Chainweb.Miner.Pact -import Chainweb.Pact5.Backend.ChainwebPactDb (Pact5Db(doPact5DbTransaction)) -import Chainweb.Pact5.SPV qualified as Pact5 -import Chainweb.Pact.Types -import Chainweb.Pact5.Transaction -import Chainweb.Pact5.TransactionExec -import Chainweb.Pact5.Types -import Chainweb.Payload -import Chainweb.Payload.PayloadStore -import Chainweb.Time -import Chainweb.Utils -import Chainweb.Version -import Chainweb.Version.Guards -import Chronos qualified -import Control.DeepSeq -import Control.Exception (evaluate) -import Control.Lens -import Control.Monad -import Control.Monad.Except -import Control.Monad.IO.Class -import Control.Monad.Reader -import Control.Monad.State.Strict -import Data.ByteString (ByteString) -import Data.Coerce -import Data.Decimal -import Data.Either (partitionEithers) -import Data.Foldable -import Data.Maybe -import Data.Text qualified as T -import Data.Vector (Vector) -import Data.Vector qualified as V -import Data.Void -import Pact.Core.ChainData hiding (ChainId) -import Pact.Core.Command.Types qualified as Pact5 -import Pact.Core.Persistence qualified as Pact5 -import Pact.Core.Hash -import Control.Exception.Safe -import qualified Pact.Core.Gas as Pact5 -import qualified Pact.JSON.Encode as J -import System.Timeout -import Utils.Logging.Trace -import qualified Data.Set as S -import qualified Pact.Types.Gas as Pact4 -import qualified Pact.Core.Gas as P -import qualified Data.Text.Encoding as T -import qualified Data.HashMap.Strict as HashMap -import qualified Chainweb.Pact5.Backend.ChainwebPactDb as Pact5 -import qualified Chainweb.Pact4.Transaction as Pact4 -import qualified Chainweb.Pact5.Transaction as Pact5 -import qualified Chainweb.Pact5.Validations as Pact5 -import Pact.Core.Pretty qualified as Pact5 -import qualified Data.ByteString.Short as SB -import qualified Pact.Core.Hash as Pact5 -import System.LogLevel -import qualified Data.Aeson as Aeson -import qualified Data.List.NonEmpty as NEL -import Chainweb.Pact5.NoCoinbase -import qualified Pact.Core.Errors as Pact5 -import qualified Pact.Core.Evaluate as Pact5 -import Chainweb.Pact.Backend.Types -import qualified Pact.Core.ChainData as Pact5 - --- | Calculate miner reward. We want this to error hard in the case where --- block times have finally exceeded the 120-year range. Rewards are calculated --- at regular blockheight intervals. --- --- See: 'rewards/miner_rewards.csv' --- -minerReward - :: ChainwebVersion - -> BlockHeight - -> Decimal -minerReward v = _kda . minerRewardKda . blockMinerReward v -{-# INLINE minerReward #-} - -runCoinbase - :: (Logger logger) - => Miner - -> PactBlockM logger tbl (Either Pact5CoinbaseError (Pact5.CommandResult [Pact5.TxLog ByteString] Void)) -runCoinbase miner = do - isGenesis <- view psIsGenesis - if isGenesis - then return $ Right noCoinbase - else do - logger <- view (psServiceEnv . psLogger) - v <- view chainwebVersion - txCtx <- TxContext <$> view psParentHeader <*> pure miner - - let !bh = ctxCurrentBlockHeight txCtx - let reward = minerReward v bh - - -- the coinbase request key is not passed here because TransactionIndex - -- does not contain coinbase transactions - pactTransaction Nothing $ \db -> - applyCoinbase logger db reward txCtx - -pact5TransactionsFromPayload - :: PayloadData - -> IO (Vector Pact5.Transaction) -pact5TransactionsFromPayload plData = do - vtrans <- mapM toCWTransaction $ - toList (view payloadDataTransactions plData) - let (theLefts, theRights) = partitionEithers vtrans - unless (null theLefts) $ do - let ls = map T.pack theLefts - throwM $ TransactionDecodeFailure $ "Failed to decode pact transactions: " - <> T.intercalate ". " ls - return $! V.fromList theRights - where - toCWTransaction bs = - evaluate (force (codecDecode payloadCodec $ _transactionBytes bs)) - --- | Continue adding transactions to an existing block. -continueBlock - :: forall logger tbl - . (Logger logger, CanReadablePayloadCas tbl) - => MemPoolAccess - -> BlockInProgress Pact5 - -> PactBlockM logger tbl (BlockInProgress Pact5) -continueBlock mpAccess blockInProgress = do - pbBlockHandle .= _blockInProgressHandle blockInProgress - -- update the mempool, ensuring that we reintroduce any transactions that - -- were removed due to being completed in a block on a different fork. - case maybeBlockParentHeader of - Just blockParentHeader -> do - liftIO $ do - mpaProcessFork mpAccess blockParentHeader - mpaSetLastHeader mpAccess $ blockParentHeader - liftPactServiceM $ - logInfoPact $ T.unwords - [ "(parent height = " <> sshow (view blockHeight blockParentHeader) <> ")" - , "(parent hash = " <> sshow (view blockHash blockParentHeader) <> ")" - ] - Nothing -> - liftPactServiceM $ logInfoPact "Continuing genesis block" - - blockGasLimit <- view (psServiceEnv . psBlockGasLimit) - mTxTimeLimit <- view (psServiceEnv . psTxTimeLimit) - let txTimeHeadroomFactor :: Double - txTimeHeadroomFactor = 5 - let txTimeLimit :: Micros - -- 2.5 us per unit gas - txTimeLimit = fromMaybe (round $ 2.5 * txTimeHeadroomFactor * fromIntegral blockGasLimit) mTxTimeLimit - liftPactServiceM $ do - logDebugPact $ T.unwords - [ "Block gas limit:" - , sshow blockGasLimit <> "," - , "Transaction time limit:" - , sshow txTimeLimit - ] - - let startTxs = _transactionPairs (_blockInProgressTransactions blockInProgress) - let startTxsRequestKeys = - foldMap' (S.singleton . pact5RequestKeyToTransactionHash . view Pact5.crReqKey . snd) startTxs - let initState = BlockFill - { _bfTxHashes = startTxsRequestKeys - , _bfGasLimit = _blockInProgressRemainingGasLimit blockInProgress - , _bfCount = 0 - } - - let fetchLimit = fromIntegral $ blockGasLimit `div` 1000 - - (BlockFill { _bfGasLimit = finalGasLimit }, valids, invalids) <- - refill fetchLimit txTimeLimit initState - - finalBlockHandle <- use pbBlockHandle - - liftIO $ mpaBadlistTx mpAccess - (V.fromList $ fmap pact5RequestKeyToTransactionHash $ concat invalids) - - liftPactServiceM $ logDebugPact $ "Order of completed transactions: " <> sshow (map (Pact5.unRequestKey . Pact5._crReqKey . snd) $ concat $ reverse valids) - let !blockInProgress' = blockInProgress - & blockInProgressHandle .~ - finalBlockHandle - & blockInProgressTransactions . transactionPairs .~ - startTxs <> V.fromList (concat valids) - & blockInProgressRemainingGasLimit .~ - finalGasLimit - - liftPactServiceM $ logDebugPact $ "Final block transaction order: " <> sshow (fmap (Pact5.unRequestKey . Pact5._crReqKey . snd) $ _transactionPairs (_blockInProgressTransactions blockInProgress')) - - return blockInProgress' - - where - maybeBlockParentHeader = _parentHeader <$> _blockInProgressParentHeader blockInProgress - refill fetchLimit txTimeLimit blockFillState = over _2 reverse <$> go [] [] blockFillState - where - go - :: [CompletedTransactions] - -> [InvalidTransactions] - -> BlockFill - -> PactBlockM logger tbl (BlockFill, [CompletedTransactions], [InvalidTransactions]) - go completedTransactions invalidTransactions prevBlockFillState@BlockFill - { _bfGasLimit = prevRemainingGas, _bfCount = prevFillCount, _bfTxHashes = prevTxHashes } - | prevFillCount > fetchLimit = liftPactServiceM $ do - logInfoPact $ "Refill fetch limit exceeded (" <> sshow fetchLimit <> ")" - pure stop - | prevRemainingGas < 0 = - throwM $ MempoolFillFailure $ "Internal error, negative gas limit: " <> sshow prevBlockFillState - | prevRemainingGas == 0 = - pure stop - | otherwise = do - newTxs <- getBlockTxs prevBlockFillState - liftPactServiceM $ logDebugPact $ "Refill: fetched transaction: " <> sshow (V.length newTxs) - if V.null newTxs - then do - liftPactServiceM $ logDebugPact $ "Refill: no new transactions" - pure stop - else do - (newCompletedTransactions, newInvalidTransactions, newBlockGasLimit, timedOut) <- - execNewTransactions (_blockInProgressMiner blockInProgress) prevRemainingGas txTimeLimit newTxs - - liftPactServiceM $ do - logDebugPact $ "Refill: included request keys: " <> sshow @[Hash] (fmap (Pact5.unRequestKey . Pact5._crReqKey . snd) newCompletedTransactions) - logDebugPact $ "Refill: badlisted request keys: " <> sshow @[Hash] (fmap Pact5.unRequestKey newInvalidTransactions) - - let newBlockFillState = BlockFill - { _bfCount = succ prevFillCount - , _bfGasLimit = newBlockGasLimit - , _bfTxHashes = - flip - (foldr (S.insert . pact5RequestKeyToTransactionHash . view (_2 . Pact5.crReqKey))) - newCompletedTransactions - $ flip - (foldr (S.insert . pact5RequestKeyToTransactionHash)) - newInvalidTransactions - $ prevTxHashes - } - let completedTransactions' = newCompletedTransactions : completedTransactions - let invalidTransactions' = newInvalidTransactions : invalidTransactions - if timedOut - then - -- stop; we've used so much time already that we should just return what we have - pure (newBlockFillState, completedTransactions', invalidTransactions') - else - go completedTransactions' invalidTransactions' newBlockFillState - - where - stop = (prevBlockFillState, completedTransactions, invalidTransactions) - - execNewTransactions - :: Miner - -> Pact4.GasLimit - -> Micros - -> Vector Pact5.Transaction - -> PactBlockM logger tbl (CompletedTransactions, InvalidTransactions, Pact4.GasLimit, Bool) - execNewTransactions miner remainingGas timeLimit txs = do - env <- ask - startBlockHandle <- use pbBlockHandle - let p5RemainingGas = Pact5.GasLimit $ Pact5.Gas $ fromIntegral remainingGas - logger' <- view (psServiceEnv . psLogger) - isGenesis <- view psIsGenesis - ((txResults, timedOut), (finalBlockHandle, Identity finalRemainingGas)) <- - liftIO $ flip runStateT (startBlockHandle, Identity p5RemainingGas) $ foldr - (\(txIdxInBlock, tx) rest -> StateT $ \s -> do - let logger = addLabel ("transactionHash", sshow (Pact5._cmdHash tx)) logger' - let env' = env & psServiceEnv . psLogger .~ logger - let timeoutFunc runTx = - if isGenesis - then do - logFunctionText logger Info $ "Running genesis command" - fmap Just runTx - else - newTimeout (fromIntegral @Micros @Int timeLimit) runTx - m <- liftIO $ timeoutFunc - $ runExceptT $ runStateT (applyPactCmd env' miner (TxBlockIdx txIdxInBlock) tx) s - case m of - Nothing -> do - logFunctionJson logger Warn $ Aeson.object - [ "type" Aeson..= Aeson.String "newblock timeout" - , "hash" Aeson..= Aeson.String (sshow (Pact5._cmdHash tx)) - , "payload" Aeson..= Aeson.String ( - T.decodeUtf8 $ SB.fromShort $ tx ^. Pact5.cmdPayload . Pact5.payloadBytes - ) - ] - return (([Left (Pact5._cmdHash tx)], True), s) - Just (Left err) -> do - logFunctionText logger Debug $ - "applyCmd failed to buy gas: " <> prettyPact5GasPurchaseFailure err - ((as, timedOut), s') <- runStateT rest s - return ((Left (Pact5._cmdHash tx):as, timedOut), s') - Just (Right (a, s')) -> do - logFunctionText logger Debug "applyCmd buy gas succeeded" - ((as, timedOut), s'') <- runStateT rest s' - return ((Right (tx, a):as, timedOut), s'') - ) - (return ([], False)) - (zip [0..] (V.toList txs)) - pbBlockHandle .= finalBlockHandle - let (invalidTxHashes, completedTxs) = partitionEithers txResults - let p4FinalRemainingGas = fromIntegral @Pact5.SatWord @Pact4.GasLimit $ finalRemainingGas ^. Pact5._GasLimit . to Pact5._gas - return (completedTxs, Pact5.RequestKey <$> invalidTxHashes, p4FinalRemainingGas, timedOut) - - getBlockTxs :: BlockFill -> PactBlockM logger tbl (Vector Pact5.Transaction) - getBlockTxs blockFillState = do - liftPactServiceM $ logDebugPact "Refill: fetching transactions" - v <- view chainwebVersion - cid <- view chainId - logger <- view (psServiceEnv . psLogger) - dbEnv <- view psBlockDbEnv - let (pHash, pHeight, parentTime) = blockInProgressParent blockInProgress - isGenesis <- view psIsGenesis - let validate bhi _bha txs = do - forM txs $ - runExceptT . validateRawChainwebTx logger v cid dbEnv (_blockInProgressHandle blockInProgress) (ParentCreationTime parentTime) bhi isGenesis - liftIO $ mpaGetBlock mpAccess blockFillState validate - (succ pHeight) - pHash - parentTime - -type CompletedTransactions = [(Pact5.Transaction, Pact5.CommandResult [Pact5.TxLog ByteString] (Pact5.PactError Pact5.Info))] -type InvalidTransactions = [Pact5.RequestKey] - --- Apply a Pact command in the current block. --- This function completely ignores timeouts! -applyPactCmd - :: (Traversable t, Logger logger) - => PactBlockEnv logger Pact5 tbl - -> Miner -> TxIdxInBlock -> Pact5.Transaction - -> StateT - (BlockHandle Pact5, t P.GasLimit) - (ExceptT Pact5GasPurchaseFailure IO) - (Pact5.CommandResult [Pact5.TxLog ByteString] (Pact5.PactError Pact5.Info)) -applyPactCmd env miner txIdxInBlock tx = StateT $ \(blockHandle, blockGasRemaining) -> do - -- we set the command gas limit to the minimum of its original value and the remaining gas in the block - -- this way Pact never uses more gas than remains in the block, and the tx fails otherwise - let alteredTx = (view payloadObj <$> tx) & Pact5.cmdPayload . Pact5.pMeta . pmGasLimit %~ maybe id min (blockGasRemaining ^? traversed) - resultOrGasError <- liftIO $ runReaderT - (unsafeApplyPactCmd blockHandle - (initialGasOf (_chainwebVersion env) (Chainweb.Version._chainId env) - (env ^. psParentHeader . parentHeader . blockHeight) - (env ^. psParentHeader . parentHeader . blockForkNumber) - tx) - alteredTx) - env - case resultOrGasError of - Left err -> throwError err - Right (result, nextHandle) - -- if there is a fixed remaining amount of gas in the block - | Just blockGas <- blockGasRemaining ^? traversed - -- and the transaction gas limit is more than that - , let txGasLimit = tx ^. Pact5.cmdPayload . payloadObj . Pact5.pMeta . pmGasLimit - , txGasLimit > blockGas - -- then the transaction is not allowed to fail, or it would consume more gas than remains in the block - , Pact5.PactResultErr _ <- Pact5._crResult result - -> throwM $ BlockGasLimitExceeded (fromIntegral $ txGasLimit ^. Pact5._GasLimit . to Pact5._gas) - | otherwise -> do - let subtractGasLimit limit subtrahend = - let limitGas = limit ^. Pact5._GasLimit - in if limitGas < subtrahend - -- this should be impossible. - -- we never allow a transaction to run with a gas limit higher than the block gas limit. - then internalError $ - "subtractGasLimit: transaction ran with higher gas limit than block gas limit: " <> - sshow subtrahend <> " > " <> sshow limit - else pure $ Pact5.GasLimit $ Pact5.Gas (Pact5._gas limitGas - Pact5._gas subtrahend) - blockGasRemaining' <- - traverse (`subtractGasLimit` (Pact5._crGas result)) blockGasRemaining - return (result, (nextHandle, blockGasRemaining')) - where - -- | Apply a Pact command in the current block. - -- This function completely ignores timeouts and the block gas limit! - unsafeApplyPactCmd - :: (Logger logger) - => BlockHandle Pact5 - -> Pact5.Gas - -> Pact5.Command (Pact5.Payload PublicMeta Pact5.ParsedCode) - -> ReaderT - (PactBlockEnv logger Pact5 tbl) - IO - (Either Pact5GasPurchaseFailure - (Pact5.CommandResult [Pact5.TxLog ByteString] (Pact5.PactError Pact5.Info), BlockHandle Pact5)) - unsafeApplyPactCmd blockHandle initialGas cmd = do - _txFailuresCounter <- view (psServiceEnv . psTxFailuresCounter) - logger <- view (psServiceEnv . psLogger) - gasLogger <- view (psServiceEnv . psGasLogger) - dbEnv <- view psBlockDbEnv - bhdb <- view (psServiceEnv . psBlockHeaderDb) - parent <- view psParentHeader - let spv = Pact5.pactSPV bhdb (_parentHeader parent) - let txCtx = TxContext parent miner - -- TODO: trace more info? - let rk = Pact5.RequestKey $ Pact5._cmdHash cmd - (resultOrError, blockHandle') <- - liftIO $ trace' (logFunction logger) "applyCmd" computeTrace (\_ -> 0) $ - doPact5DbTransaction dbEnv blockHandle (Just rk) $ \pactDb -> - if _psIsGenesis env - then do - logFunctionText logger Debug "running genesis command!" - r <- runGenesisPayload logger pactDb spv txCtx cmd - case r of - Left genesisError -> throwM $ Pact5GenesisCommandFailed (Pact5._cmdHash cmd) (sshow genesisError) - -- pretend that genesis commands can throw non-fatal errors, - -- to make types line up - Right res -> return (Right (absurd <$> res)) - else applyCmd logger gasLogger pactDb txCtx txIdxInBlock spv initialGas cmd - liftIO $ case resultOrError of - -- unknown exceptions are logged specially, because they indicate bugs in Pact or chainweb - Right - Pact5.CommandResult - { - _crResult = - Pact5.PactResultErr (Pact5.PEExecutionError (Pact5.UnknownException unknownExceptionMessage) _ _) - } -> logFunctionText logger Error $ "Unknown exception encountered " <> unknownExceptionMessage - Left gasBuyError -> - liftIO $ logFunction logger Debug - -- TODO: replace with better print function for gas buy errors - (Pact5TxFailureLog rk (sshow gasBuyError)) - Right Pact5.CommandResult - { _crResult = Pact5.PactResultErr err - } -> - liftIO $ logFunction logger Debug - (Pact5TxFailureLog rk (sshow err)) - _ -> - return () - return $ (,blockHandle') <$> resultOrError - where - computeTrace (Left gasPurchaseFailure, _) = Aeson.object - [ "result" Aeson..= Aeson.String "gas purchase failure" - , "hash" Aeson..= J.toJsonViaEncode (Pact5._cmdHash cmd) - , "error" Aeson..= Aeson.String (sshow gasPurchaseFailure) - ] - computeTrace (Right result, _) = Aeson.object - [ "gas" Aeson..= Pact5._gas (Pact5._crGas result) - , "result" Aeson..= Aeson.String (case Pact5._crResult result of - Pact5.PactResultOk _ -> - "success" - Pact5.PactResultErr _ -> - "failure" - ) - , "hash" Aeson..= J.toJsonViaEncode (Pact5._cmdHash cmd) - ] - --- | The principal validation logic for groups of Pact Transactions. --- This is used by the mempool to estimate tx validity --- before inclusion into blocks, but it's also used by ExecBlock to check --- if all of the txs in a block are valid. --- --- Skips validation for genesis transactions, since gas accounts, etc. don't --- exist yet. --- -validateParsedChainwebTx - :: (Logger logger) - => logger - -> ChainwebVersion - -> ChainId - -> Pact5Db - -> BlockHandle Pact5 - -> ParentCreationTime - -- ^ reference time for tx validation. - -> BlockHeight - -- ^ Current block height - -> Bool - -- ^ Genesis? - -> Pact5.Transaction - -> ExceptT InsertError IO () -validateParsedChainwebTx _logger v cid db _blockHandle txValidationTime bh isGenesis tx - | isGenesis = pure () - | otherwise = do - checkUnique tx - checkTxHash tx - checkChain - checkTxSigs tx - checkTimes tx - return () - where - - checkChain :: ExceptT InsertError IO () - checkChain = unless (Pact5.assertChainId cid txCid) $ - throwError $ InsertErrorWrongChain (chainIdToText cid) (Pact5._chainId txCid) - where - txCid = view (Pact5.cmdPayload . Pact5.payloadObj . Pact5.pMeta . Pact5.pmChainId) tx - - checkUnique :: Pact5.Transaction -> ExceptT InsertError IO () - checkUnique t = do - found <- liftIO $ - HashMap.lookup (coerce $ Pact5._cmdHash t) <$> - Pact5.lookupPactTransactions db - (V.singleton $ coerce $ Pact5._cmdHash t) - case found of - Nothing -> pure () - Just _ -> throwError InsertErrorDuplicate - - checkTimes :: Pact5.Transaction -> ExceptT InsertError IO () - checkTimes t = do - if | skipTxTimingValidation v cid bh -> pure () - | not (Pact5.assertTxNotInFuture txValidationTime (view Pact5.payloadObj <$> t)) -> do - throwError InsertErrorTimeInFuture - | not (Pact5.assertTxTimeRelativeToParent txValidationTime (view Pact5.payloadObj <$> t)) -> do - throwError InsertErrorTTLExpired - | otherwise -> do - pure () - - checkTxHash :: Pact5.Transaction -> ExceptT InsertError IO () - checkTxHash t = do - case Pact5.verifyHash (Pact5._cmdHash t) (SB.fromShort $ view Pact5.payloadBytes $ Pact5._cmdPayload t) of - Left _ - | doCheckTxHash v cid bh -> throwError InsertErrorInvalidHash - | otherwise -> pure () - Right _ -> pure () - - - checkTxSigs :: Pact5.Transaction -> ExceptT InsertError IO () - checkTxSigs t = do - case Pact5.assertValidateSigs hsh signers sigs of - Right _ -> do - pure () - Left err -> do - throwError $ InsertErrorInvalidSigs (displayAssertValidateSigsError err) - where - hsh = Pact5._cmdHash t - sigs = Pact5._cmdSigs t - signers = Pact5._pSigners $ view Pact5.payloadObj $ Pact5._cmdPayload t - --- | The validation logic for Pact Transactions that have not had their --- code parsed yet. This is used by the mempool to estimate tx validity --- before inclusion into blocks, but it's also used by ExecBlock to check --- if all of the txs in a block are valid. --- --- Skips validation for genesis transactions, since gas accounts, etc. don't --- exist yet. --- -validateRawChainwebTx - :: (Logger logger) - => logger - -> ChainwebVersion - -> ChainId - -> Pact5Db - -> BlockHandle Pact5 - -> ParentCreationTime - -- ^ reference time for tx validation. - -> BlockHeight - -- ^ Current block height - -> Bool - -- ^ Genesis? - -> Pact4.UnparsedTransaction - -> ExceptT InsertError IO Pact5.Transaction -validateRawChainwebTx logger v cid db blockHandle parentTime bh isGenesis tx = do - tx' <- either (throwError . InsertErrorPactParseError . either id Pact5.renderText) return $ Pact5.parsePact4Command tx - liftIO $ do - logDebug_ logger $ "validateRawChainwebTx: parse succeeded" - validateParsedChainwebTx logger v cid db blockHandle parentTime bh isGenesis tx' - return $! tx' - -execExistingBlock - :: (CanReadablePayloadCas tbl, Logger logger) - => BlockHeader - -> CheckablePayload - -> PactBlockM logger tbl (P.Gas, PayloadWithOutputs) -execExistingBlock currHeader payload = do - parentBlockHeader <- _parentHeader <$> view psParentHeader - let plData = checkablePayloadToPayloadData payload - miner :: Miner <- decodeStrictOrThrow (_minerData $ view payloadDataMiner plData) - txs <- liftIO $ pact5TransactionsFromPayload plData - logger <- view (psServiceEnv . psLogger) - -- TODO: Pact5: ACTUALLY log gas - _gasLogger <- view (psServiceEnv . psGasLogger) - v <- view chainwebVersion - cid <- view chainId - db <- view psBlockDbEnv - isGenesis <- view psIsGenesis - blockHandlePreCoinbase <- use pbBlockHandle - let - txValidationTime = ParentCreationTime (parentBlockHeader ^. blockCreationTime) - errors <- liftIO $ flip foldMap txs $ \tx -> do - errorOrSuccess <- runExceptT $ - validateParsedChainwebTx logger v cid db blockHandlePreCoinbase txValidationTime - (view blockHeight currHeader) - isGenesis - tx - case errorOrSuccess of - Right () -> return [] - Left err -> return [(Pact5._cmdHash tx, sshow err)] - case NEL.nonEmpty errors of - Nothing -> return () - Just errorsNel -> throwM $ Pact5TransactionValidationException errorsNel - - coinbaseResult <- runCoinbase miner >>= \case - Left err -> throwM $ CoinbaseFailure (Pact5CoinbaseFailure err) - Right r -> return (absurd <$> r) - - -- TODO pact 5: make this less nasty? - postCoinbaseBlockHandle <- use pbBlockHandle - - let blockGasLimit = - Pact5.GasLimit . Pact5.Gas . fromIntegral <$> maxBlockGasLimit v (parentBlockHeader ^. blockForkNumber) (currHeader ^. blockHeight) - - env <- ask - (V.fromList -> results, (finalHandle, _finalBlockGasLimit)) <- - liftIO $ flip runStateT (postCoinbaseBlockHandle, blockGasLimit) $ - forM (zip [0..] (V.toList txs)) $ \(txIdxInBlock, tx) -> - (tx,) <$> mapStateT - (either (throwM . Pact5BuyGasFailure) return <=< runExceptT) - (applyPactCmd env miner (TxBlockIdx txIdxInBlock) tx) - -- incorporate the final state of the transactions into the block state - pbBlockHandle .= finalHandle - - let !totalGasUsed = foldOf (folded . _2 . to Pact5._crGas) results - - pwo <- either throwM return $ - validateHashes currHeader payload miner (Transactions results coinbaseResult) - return (totalGasUsed, pwo) - --- | Check that the two payloads agree. If we have access to the outputs, we --- check those too. -validateHashes - :: BlockHeader - -> CheckablePayload - -> Miner - -> Transactions Pact5 (Pact5.CommandResult [Pact5.TxLog ByteString] (Pact5.PactError Pact5.Info)) - -> Either PactException PayloadWithOutputs -validateHashes bHeader payload miner transactions = - if newHash == prevHash - then do - Right actualPwo - else do - let jsonText = - J.encodeText $ J.object - [ "header" J..= J.encodeWithAeson (ObjectEncoded bHeader) - , "actual" J..= J.encodeWithAeson actualPwo - , "expected" J..?= case payload of - CheckablePayload _ -> Nothing - CheckablePayloadWithOutputs pwo -> Just $ J.encodeWithAeson pwo - ] - - Left (BlockValidationFailure $ BlockValidationFailureMsg jsonText) - where - - actualPwo = toPayloadWithOutputs Pact5T miner transactions - - newHash = _payloadWithOutputsPayloadHash actualPwo - prevHash = view blockPayloadHash bHeader - - -- The following JSON encodings are used in the BlockValidationFailure message - -data CRLogPair = CRLogPair Hash [Pact5.TxLog ByteString] - -instance J.Encode CRLogPair where - build (CRLogPair h logs) = J.object - [ "hash" J..= h - , "rawLogs" J..= J.Array - [ J.text (_txDomain <> ": " <> _txKey <> " -> " <> T.decodeUtf8 _txValue) - | Pact5.TxLog {..} <- logs - ] - ] - {-# INLINE build #-} - --- | This timeout variant returns Nothing if the timeout elapsed, regardless of whether or not it was actually able to interrupt its argument. --- This is more robust in the face of scheduler behavior than the standard 'System.Timeout.timeout', with small timeouts. -newTimeout :: Int -> IO a -> IO (Maybe a) -newTimeout n f = do - (timeSpan, a) <- Chronos.stopwatch (timeout n f) - if Chronos.getTimespan timeSpan > fromIntegral (n * 1000) - then return Nothing - else return a diff --git a/src/Chainweb/Payload.hs b/src/Chainweb/Pact/Payload.hs similarity index 93% rename from src/Chainweb/Payload.hs rename to src/Chainweb/Pact/Payload.hs index 0bb33152f8..a0911dac5c 100644 --- a/src/Chainweb/Payload.hs +++ b/src/Chainweb/Pact/Payload.hs @@ -14,9 +14,12 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE UndecidableInstances #-} -- | --- Module: Chainweb.Payload +-- Module: Chainweb.Pact.Payload -- Copyright: Copyright © 2018 - 2020 Kadena LLC. -- License: MIT -- Maintainer: Lars Kuhtz @@ -28,7 +31,7 @@ -- depend on any Pact data structure. The reason for this is to allow changes to -- Pact without breaking the Merkle tree. -- -module Chainweb.Payload +module Chainweb.Pact.Payload ( -- * Block Chain Data @@ -139,6 +142,7 @@ module Chainweb.Payload , CheckablePayload(..) , checkablePayloadToPayloadData +, checkablePayloadExpectedHash ) where import Control.DeepSeq @@ -148,14 +152,15 @@ import Control.Monad.Catch import Data.Aeson import Data.Aeson.Encoding (encodingToLazyByteString, pair) -import qualified Data.Aeson.Types as A -import qualified Data.ByteArray as BA -import qualified Data.ByteString as B -import qualified Data.ByteString.Lazy as BL +import Data.Aeson.Types qualified as A +import Data.ByteArray qualified as BA +import Data.ByteString qualified as B +import Data.ByteString.Lazy qualified as BL import Data.Hashable import Data.MerkleLog -import qualified Data.Text as T -import qualified Data.Vector as V +import Data.MerkleLog.V1 qualified as V1 +import Data.Text qualified as T +import Data.Vector qualified as V import Data.Void import GHC.Generics (Generic) @@ -172,7 +177,6 @@ import Chainweb.Storage.Table import Chainweb.Utils import Chainweb.Utils.Serialization -import Crypto.Hash.Algorithms -- -------------------------------------------------------------------------- -- -- Block Transactions Hash @@ -182,10 +186,10 @@ type BlockTransactionsHash = BlockTransactionsHash_ ChainwebMerkleHashAlgorithm newtype BlockTransactionsHash_ a = BlockTransactionsHash (MerkleLogHash a) deriving (Show, Eq, Ord, Generic) deriving anyclass (NFData) - deriving newtype (BA.ByteArrayAccess) - deriving newtype (Hashable, ToJSON, FromJSON) + deriving newtype (Hashable, ToJSON, FromJSON, HasTextRepresentation) + deriving (IsMerkleLogEntry a ChainwebHashTag) via MerkleRootLogEntry a 'BlockTransactionsHashTag -encodeBlockTransactionsHash :: BlockTransactionsHash_ a -> Put +encodeBlockTransactionsHash :: MerkleHashAlgorithm a => BlockTransactionsHash_ a -> Put encodeBlockTransactionsHash (BlockTransactionsHash w) = encodeMerkleLogHash w decodeBlockTransactionsHash @@ -193,19 +197,6 @@ decodeBlockTransactionsHash => Get (BlockTransactionsHash_ a) decodeBlockTransactionsHash = BlockTransactionsHash <$!> decodeMerkleLogHash -instance MerkleHashAlgorithm a => IsMerkleLogEntry a ChainwebHashTag (BlockTransactionsHash_ a) where - type Tag (BlockTransactionsHash_ a) = 'BlockTransactionsHashTag - toMerkleNode = encodeMerkleTreeNode - fromMerkleNode = decodeMerkleTreeNode - {-# INLINE toMerkleNode #-} - {-# INLINE fromMerkleNode #-} - -instance HasTextRepresentation BlockTransactionsHash where - toText (BlockTransactionsHash h) = toText h - fromText = fmap BlockTransactionsHash . fromText - {-# INLINE toText #-} - {-# INLINE fromText #-} - -- -------------------------------------------------------------------------- -- -- Block Outputs Hash @@ -214,10 +205,9 @@ type BlockOutputsHash = BlockOutputsHash_ ChainwebMerkleHashAlgorithm newtype BlockOutputsHash_ a = BlockOutputsHash (MerkleLogHash a) deriving (Show, Eq, Ord, Generic) deriving anyclass (NFData) - deriving newtype (BA.ByteArrayAccess) - deriving newtype (Hashable, ToJSON, FromJSON) + deriving newtype (Hashable, ToJSON, FromJSON, HasTextRepresentation) -encodeBlockOutputsHash :: BlockOutputsHash_ a -> Put +encodeBlockOutputsHash :: MerkleHashAlgorithm a => BlockOutputsHash_ a -> Put encodeBlockOutputsHash (BlockOutputsHash w) = encodeMerkleLogHash w decodeBlockOutputsHash @@ -232,12 +222,6 @@ instance MerkleHashAlgorithm a => IsMerkleLogEntry a ChainwebHashTag (BlockOutpu {-# INLINE toMerkleNode #-} {-# INLINE fromMerkleNode #-} -instance HasTextRepresentation BlockOutputsHash where - toText (BlockOutputsHash h) = toText h - fromText = fmap BlockOutputsHash . fromText - {-# INLINE toText #-} - {-# INLINE fromText #-} - -- -------------------------------------------------------------------------- -- -- Transaction @@ -499,7 +483,7 @@ newtype PayloadWithOutputsList = PayloadWithOutputsList { _payloadWithOutputsLis -- -------------------------------------------------------------------------- -- -encodeBlockPayloads :: BlockPayload_ a -> B.ByteString +encodeBlockPayloads :: MerkleHashAlgorithm a => BlockPayload_ a -> B.ByteString encodeBlockPayloads BlockPayload{..} = runPutS $ do encodeBlockPayloadHash _blockPayloadPayloadHash encodeBlockTransactionsHash _blockPayloadTransactionsHash @@ -511,7 +495,7 @@ decodeBlockPayloads = runGetS $ BlockPayload <*> decodeBlockTransactionsHash <*> decodeBlockOutputsHash -encodeBlockTransactions :: BlockTransactions_ a -> B.ByteString +encodeBlockTransactions :: MerkleHashAlgorithm a => BlockTransactions_ a -> B.ByteString encodeBlockTransactions txs = runPutS $ do encodeBlockTransactionsHash (_blockTransactionsHash txs) putWord64be (fromIntegral $ V.length (_blockTransactions txs)) @@ -521,7 +505,7 @@ encodeBlockTransactions txs = runPutS $ do putWord64be (fromIntegral $ B.length $ _minerData $ _blockMinerData txs) putByteString (_minerData $ _blockMinerData txs) -decodeBlockTransactions :: (MonadThrow m, HashAlgorithm a) => B.ByteString -> m (BlockTransactions_ a) +decodeBlockTransactions :: (MonadThrow m, MerkleHashAlgorithm a) => B.ByteString -> m (BlockTransactions_ a) decodeBlockTransactions = runGetS $ do hsh <- decodeBlockTransactionsHash txsCount <- fromIntegral <$> getWord64be @@ -537,7 +521,7 @@ decodeBlockTransactions = runGetS $ do , _blockMinerData = minerData } -encodeBlockOutputs :: BlockOutputs_ a -> B.ByteString +encodeBlockOutputs :: MerkleHashAlgorithm a => BlockOutputs_ a -> B.ByteString encodeBlockOutputs bo = runPutS $ do encodeBlockOutputsHash (_blockOutputsHash bo) putWord64be (fromIntegral $ V.length (_blockOutputs bo)) @@ -547,7 +531,7 @@ encodeBlockOutputs bo = runPutS $ do putWord64be (fromIntegral $ B.length $ _coinbaseOutput $ _blockCoinbaseOutput bo) putByteString $ _coinbaseOutput $ _blockCoinbaseOutput bo -decodeBlockOutputs :: (MonadThrow m, HashAlgorithm a) => B.ByteString -> m (BlockOutputs_ a) +decodeBlockOutputs :: (MonadThrow m, MerkleHashAlgorithm a) => B.ByteString -> m (BlockOutputs_ a) decodeBlockOutputs = runGetS $ do hsh <- decodeBlockOutputsHash txsCount <- fromIntegral <$> getWord64be @@ -563,37 +547,37 @@ decodeBlockOutputs = runGetS $ do , _blockCoinbaseOutput = CoinbaseOutput coinbaseData } -encodeTransactionTree :: TransactionTree_ a -> B.ByteString +encodeTransactionTree :: MerkleHashAlgorithm a => TransactionTree_ a -> B.ByteString encodeTransactionTree tt = runPutS $ do encodeBlockTransactionsHash (_transactionTreeHash tt) - let bs = encodeMerkleTree (_transactionTree tt) + let bs = V1.encodeMerkleTree (_transactionTree tt) putWord64be (fromIntegral $ B.length bs) putByteString bs -decodeTransactionTree :: (MonadThrow m, HashAlgorithm a) => B.ByteString -> m (TransactionTree_ a) +decodeTransactionTree :: (MonadThrow m, MerkleHashAlgorithm a) => B.ByteString -> m (TransactionTree_ a) decodeTransactionTree = runGetS $ do hsh <- decodeBlockTransactionsHash sz <- fromIntegral <$> getWord64be bs <- getByteString sz - mt <- decodeMerkleTree bs + mt <- V1.decodeMerkleTree bs return TransactionTree { _transactionTreeHash = hsh , _transactionTree = mt } -encodeOutputTree :: OutputTree_ a -> B.ByteString +encodeOutputTree :: MerkleHashAlgorithm a => OutputTree_ a -> B.ByteString encodeOutputTree ot = runPutS $ do encodeBlockOutputsHash (_outputTreeHash ot) - let bs = encodeMerkleTree (_outputTree ot) + let bs = V1.encodeMerkleTree (_outputTree ot) putWord64be (fromIntegral $ B.length bs) putByteString bs -decodeOutputTree :: (MonadThrow m, HashAlgorithm a) => B.ByteString -> m (OutputTree_ a) +decodeOutputTree :: (MonadThrow m, MerkleHashAlgorithm a) => B.ByteString -> m (OutputTree_ a) decodeOutputTree = runGetS $ do hsh <- decodeBlockOutputsHash sz <- fromIntegral <$> getWord64be bs <- getByteString sz - mt <- decodeMerkleTree bs + mt <- V1.decodeMerkleTree bs return OutputTree { _outputTreeHash = hsh , _outputTree = mt @@ -609,7 +593,7 @@ decodeMinerData = do sz <- fromIntegral <$> getWord64be MinerData <$> getByteString sz -putPayloadData :: PayloadData_ a -> Put +putPayloadData :: MerkleHashAlgorithm a => PayloadData_ a -> Put putPayloadData pd = do -- first encode _payloadDataTransactions: Vector Transaction putWord64be (fromIntegral $ V.length (_payloadDataTransactions pd)) @@ -621,7 +605,7 @@ putPayloadData pd = do encodeBlockTransactionsHash (_payloadDataTransactionsHash pd) encodeBlockOutputsHash (_payloadDataOutputsHash pd) -getPayloadData :: HashAlgorithm a => Get (PayloadData_ a) +getPayloadData :: MerkleHashAlgorithm a => Get (PayloadData_ a) getPayloadData = do txsCount <- fromIntegral <$> getWord64be txs <- replicateM txsCount $ do @@ -640,10 +624,10 @@ getPayloadData = do , _payloadDataOutputsHash = outHash } -decodePayloadData :: (MonadThrow m, HashAlgorithm a) => B.ByteString -> m (PayloadData_ a) +decodePayloadData :: (MonadThrow m, MerkleHashAlgorithm a) => B.ByteString -> m (PayloadData_ a) decodePayloadData = runGetS getPayloadData -encodePayloadData :: PayloadData_ a -> B.ByteString +encodePayloadData :: MerkleHashAlgorithm a => PayloadData_ a -> B.ByteString encodePayloadData = runPutS . putPayloadData encodeCoinbaseOutput :: CoinbaseOutput -> Put @@ -656,7 +640,7 @@ decodeCoinbaseOutput = do sz <- fromIntegral <$> getWord64be CoinbaseOutput <$> getByteString sz -putPayloadWithOutputs :: PayloadWithOutputs_ a -> Put +putPayloadWithOutputs :: MerkleHashAlgorithm a => PayloadWithOutputs_ a -> Put putPayloadWithOutputs pwo = do putWord64be (fromIntegral $ V.length (_payloadWithOutputsTransactions pwo)) forM_ (_payloadWithOutputsTransactions pwo) $ \(tx, txo) -> do @@ -670,10 +654,10 @@ putPayloadWithOutputs pwo = do encodeBlockTransactionsHash (_payloadWithOutputsTransactionsHash pwo) encodeBlockOutputsHash (_payloadWithOutputsOutputsHash pwo) -encodePayloadWithOutputs :: PayloadWithOutputs_ a -> B.ByteString +encodePayloadWithOutputs :: MerkleHashAlgorithm a => PayloadWithOutputs_ a -> B.ByteString encodePayloadWithOutputs = runPutS . putPayloadWithOutputs -getPayloadWithOutputs :: HashAlgorithm a => Get (PayloadWithOutputs_ a) +getPayloadWithOutputs :: MerkleHashAlgorithm a => Get (PayloadWithOutputs_ a) getPayloadWithOutputs = do txsCount <- fromIntegral <$> getWord64be txs <- replicateM txsCount $ do @@ -696,7 +680,7 @@ getPayloadWithOutputs = do , _payloadWithOutputsOutputsHash = outHash } -decodePayloadWithOutputs :: (MonadThrow m, HashAlgorithm a) => B.ByteString -> m (PayloadWithOutputs_ a) +decodePayloadWithOutputs :: (MonadThrow m, MerkleHashAlgorithm a) => B.ByteString -> m (PayloadWithOutputs_ a) decodePayloadWithOutputs = runGetS getPayloadWithOutputs encodePayloadDataList :: PayloadDataList -> B.ByteString @@ -934,7 +918,7 @@ data TransactionTree_ a = TransactionTree -- ^ Root of '_transactionTree'. Primary key of 'TransactionTreeStore. -- Foreign key into 'BlockTransactionsStore'. - , _transactionTree :: !(MerkleTree a) + , _transactionTree :: !(V1.MerkleTree a) } deriving (Show, Eq) @@ -964,12 +948,12 @@ instance MerkleHashAlgorithm a => FromJSON (TransactionTree_ a) where <$!> o .: "hash" <*> (o .: "tree" >>= merkleTreeFromJson) -merkleTreeToJson :: MerkleTree a -> Value -merkleTreeToJson = toJSON . encodeB64UrlNoPaddingText . encodeMerkleTree +merkleTreeToJson :: V1.MerkleTree a -> Value +merkleTreeToJson = toJSON . encodeB64UrlNoPaddingText . V1.encodeMerkleTree -merkleTreeFromJson :: MerkleHashAlgorithm a => Value -> A.Parser (MerkleTree a) +merkleTreeFromJson :: MerkleHashAlgorithm a => Value -> A.Parser (V1.MerkleTree a) merkleTreeFromJson = withText "MerkleTree" $ \t -> either (fail . sshow) return - $ decodeB64UrlNoPaddingText t >>= decodeMerkleTree + $ decodeB64UrlNoPaddingText t >>= V1.decodeMerkleTree -- | Verify the consistency of the MerkleTree of a 'TransactionTree' value. -- @@ -978,7 +962,7 @@ merkleTreeFromJson = withText "MerkleTree" $ \t -> either (fail . sshow) return -- verifyTransactionTree :: MerkleHashAlgorithm a => TransactionTree_ a -> Bool verifyTransactionTree p = _transactionTreeHash p - == BlockTransactionsHash (MerkleLogHash $ merkleRoot $ _transactionTree p) + == BlockTransactionsHash (MerkleLogHash $ V1.merkleTreeRoot $ _transactionTree p) -- -------------------------------------------------------------------------- -- -- Output Merkle Tree @@ -992,7 +976,7 @@ data OutputTree_ a = OutputTree -- ^ Root of '_outputTree'. Primary key of 'OutputTreeStore. Foreign key -- into 'BlockOutputsStore'. - , _outputTree :: !(MerkleTree a) + , _outputTree :: !(V1.MerkleTree a) } deriving (Show, Eq) @@ -1029,7 +1013,7 @@ instance MerkleHashAlgorithm a => FromJSON (OutputTree_ a) where -- verifyOutputTree :: MerkleHashAlgorithm a => OutputTree_ a -> Bool verifyOutputTree p = _outputTreeHash p - == BlockOutputsHash (MerkleLogHash $ merkleRoot $ _outputTree p) + == BlockOutputsHash (MerkleLogHash $ V1.merkleTreeRoot $ _outputTree p) -- -------------------------------------------------------------------------- -- -- Data Creation @@ -1076,8 +1060,7 @@ transactionLog -> TransactionTree_ a -> BlockTransactionsLog a transactionLog txs tree - | _blockTransactionsHash txs == _transactionTreeHash tree - = (toLog txs) { _merkleLogTree = _transactionTree tree } + | _blockTransactionsHash txs == _transactionTreeHash tree = toLog txs | otherwise = error "Transaction tree and block transactions don't match" -- | This forces the 'MerkleTree' which can be an expensive operation. @@ -1118,8 +1101,7 @@ blockOutputLog -> OutputTree_ a -> BlockOutputsLog a blockOutputLog outs tree - | _blockOutputsHash outs == _outputTreeHash tree - = (toLog outs) { _merkleLogTree = _outputTree tree } + | _blockOutputsHash outs == _outputTreeHash tree = toLog outs | otherwise = error "Output tree and block outputs don't match" -- | Create a BlockPayload from 'BlockTransactions' and 'BlockOutputs' @@ -1425,11 +1407,16 @@ verifyPayloadWithOutputs p -- to run the payload to check if it's a valid block - but they are great -- for comparative error messages if the block is invalid. data CheckablePayload - = CheckablePayloadWithOutputs !PayloadWithOutputs - | CheckablePayload !PayloadData - deriving (Show) + = CheckablePayloadWithOutputs !PayloadWithOutputs + | CheckablePayload !BlockPayloadHash !PayloadData + deriving (Show, Generic, ToJSON) checkablePayloadToPayloadData :: CheckablePayload -> PayloadData checkablePayloadToPayloadData = \case - CheckablePayload pd -> pd - CheckablePayloadWithOutputs pwo -> payloadWithOutputsToPayloadData pwo + CheckablePayload _ pd -> pd + CheckablePayloadWithOutputs pwo -> payloadWithOutputsToPayloadData pwo + +checkablePayloadExpectedHash :: CheckablePayload -> BlockPayloadHash +checkablePayloadExpectedHash = \case + CheckablePayload h _ -> h + CheckablePayloadWithOutputs pwo -> _payloadWithOutputsPayloadHash pwo diff --git a/src/Chainweb/Payload/PayloadStore.hs b/src/Chainweb/Pact/Payload/PayloadStore.hs similarity index 93% rename from src/Chainweb/Payload/PayloadStore.hs rename to src/Chainweb/Pact/Payload/PayloadStore.hs index 3ff57ca078..3b04697278 100644 --- a/src/Chainweb/Payload/PayloadStore.hs +++ b/src/Chainweb/Pact/Payload/PayloadStore.hs @@ -5,6 +5,7 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE InstanceSigs #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE PolyKinds #-} @@ -16,13 +17,13 @@ {-# LANGUAGE UndecidableInstances #-} -- | --- Module: Chainweb.Payload.PayloadStore +-- Module: Chainweb.Pact.Payload.PayloadStore -- Copyright: Copyright © 2018 - 2020 Kadena LLC. -- License: MIT -- Maintainer: Lars Kuhtz -- Stability: experimental -- -module Chainweb.Payload.PayloadStore +module Chainweb.Pact.Payload.PayloadStore ( -- * Exceptions PayloadNotFoundException @@ -63,9 +64,6 @@ module Chainweb.Payload.PayloadStore , lookupPayloadDataWithHeight , lookupPayloadDataWithHeightBatch --- ** Initialize Payload Database with Genesis Payloads -, initializePayloadDb - -- ** insert new payload , addPayload , addNewPayload @@ -74,28 +72,21 @@ module Chainweb.Payload.PayloadStore ) where import Control.Applicative +import Chainweb.BlockHeight +import Chainweb.Crypto.MerkleLog +import Chainweb.MerkleUniverse +import Chainweb.Pact.Payload +import Chainweb.Ranked +import Chainweb.Storage.Table import Control.DeepSeq import Control.Exception import Control.Lens import Control.Monad.IO.Class import Control.Monad.Trans.Maybe - import Data.Hashable -import Data.Foldable - +import Data.Maybe (isJust) import GHC.Generics --- internal modules - -import Chainweb.ChainId -import Chainweb.Crypto.MerkleLog -import Chainweb.MerkleUniverse -import Chainweb.Payload -import Chainweb.Version - -import Chainweb.Storage.Table -import Chainweb.BlockHeight - -- -------------------------------------------------------------------------- -- -- Exceptions @@ -198,6 +189,16 @@ data PayloadDb_ a tbl = PayloadDb , _payloadCache :: !(PayloadCache_ a tbl) } +instance CanReadablePayloadCas_ a tbl => ReadableTable (PayloadDb_ a tbl) (Ranked (BlockPayloadHash_ a)) (PayloadData_ a) where + tableLookup :: PayloadDb_ a tbl -> Ranked (BlockPayloadHash_ a) -> IO (Maybe (PayloadData_ a)) + tableLookup pdb (Ranked hei hsh) = + lookupPayloadDataWithHeight pdb (Just hei) hsh + tableLookupBatch' :: PayloadDb_ a tbl -> Traversal s r (Ranked (BlockPayloadHash_ a)) (Maybe (PayloadData_ a)) -> s -> IO r + tableLookupBatch' pdb t s = traverseOf t (tableLookup pdb) s + -- TODO: optimize to stop decoding when we just do a membership check + tableMember :: PayloadDb_ a tbl -> Ranked (BlockPayloadHash_ a) -> IO Bool + tableMember pdb rhsh = isJust <$> tableLookup pdb rhsh + type HeightedCas c t v = c (t (BlockHeight, CasKeyType v) v) (BlockHeight, CasKeyType v) v type CanReadablePayloadCas tbl = CanReadablePayloadCas_ ChainwebMerkleHashAlgorithm tbl type CanReadablePayloadCas_ a tbl = @@ -318,22 +319,6 @@ lookupPayloadWithHeightBatch db = traverse (uncurry $ lookupPayloadWithHeight db instance (pk ~ CasKeyType (PayloadData_ a), CanReadableTransactionDbCas_ a tbl) => ReadableTable (TransactionDb_ a tbl) pk (PayloadData_ a) where tableLookup db = lookupPayloadDataWithHeight' db Nothing --- -------------------------------------------------------------------------- -- --- Initialize a PayloadDb with Genesis Payloads - --- | Initialize a PayloadDb with genesis payloads for the given chainweb --- version. --- -initializePayloadDb - :: CanPayloadCas tbl - => ChainwebVersion - -> PayloadDb tbl - -> IO () -initializePayloadDb v db = traverse_ initForChain $ chainIds v - where - initForChain cid = - addNewPayload db (genesisBlockHeight v cid) $ v ^?! versionGenesis . genesisBlockPayload . atChain cid - -- -------------------------------------------------------------------------- -- -- Insert new Payload diff --git a/src/Chainweb/Payload/PayloadStore/InMemory.hs b/src/Chainweb/Pact/Payload/PayloadStore/InMemory.hs similarity index 93% rename from src/Chainweb/Payload/PayloadStore/InMemory.hs rename to src/Chainweb/Pact/Payload/PayloadStore/InMemory.hs index df3b3753f6..9589365316 100644 --- a/src/Chainweb/Payload/PayloadStore/InMemory.hs +++ b/src/Chainweb/Pact/Payload/PayloadStore/InMemory.hs @@ -1,7 +1,7 @@ {-# LANGUAGE ScopedTypeVariables #-} -- | --- Module: Chainweb.Payload.PayloadStore.InMemory +-- Module: Chainweb.Pact.Payload.PayloadStore.InMemory -- Copyright: Copyright © 2018 - 2020 Kadena LLC. -- License: MIT -- Maintainer: Lars Kuhtz @@ -10,7 +10,7 @@ -- An in-memory block payload store. -- -- TODO: move to tests -module Chainweb.Payload.PayloadStore.InMemory +module Chainweb.Pact.Payload.PayloadStore.InMemory ( newTransactionDb , newPayloadDb ) where @@ -18,8 +18,8 @@ module Chainweb.Payload.PayloadStore.InMemory -- internal modules import Chainweb.BlockHeight -import Chainweb.Payload -import Chainweb.Payload.PayloadStore +import Chainweb.Pact.Payload +import Chainweb.Pact.Payload.PayloadStore import Chainweb.Storage.Table import Chainweb.Storage.Table.HashMap(HashMapTable) import qualified Chainweb.Storage.Table.HashMap as HashMapTable diff --git a/src/Chainweb/Payload/PayloadStore/RocksDB.hs b/src/Chainweb/Pact/Payload/PayloadStore/RocksDB.hs similarity index 96% rename from src/Chainweb/Payload/PayloadStore/RocksDB.hs rename to src/Chainweb/Pact/Payload/PayloadStore/RocksDB.hs index 252e51b6c8..6e6c94c0d7 100644 --- a/src/Chainweb/Payload/PayloadStore/RocksDB.hs +++ b/src/Chainweb/Pact/Payload/PayloadStore/RocksDB.hs @@ -2,7 +2,7 @@ {-# LANGUAGE ScopedTypeVariables #-} -- | --- Module: Chainweb.Payload.PayloadStore.RocksDB +-- Module: Chainweb.Pact.Payload.PayloadStore.RocksDB -- Copyright: Copyright © 2018 - 2020 Kadena LLC. -- License: MIT -- Maintainer: Lars Kuhtz @@ -10,7 +10,7 @@ -- -- Content addressable block payload store that uses RocksDB as storage backend. -- -module Chainweb.Payload.PayloadStore.RocksDB +module Chainweb.Pact.Payload.PayloadStore.RocksDB ( newTransactionDb , newPayloadDb ) where @@ -18,8 +18,8 @@ module Chainweb.Payload.PayloadStore.RocksDB -- internal modules import Chainweb.BlockHeight -import Chainweb.Payload -import Chainweb.Payload.PayloadStore +import Chainweb.Pact.Payload +import Chainweb.Pact.Payload.PayloadStore import Chainweb.Utils hiding (Codec) import Chainweb.Utils.Serialization diff --git a/src/Chainweb/Payload/RestAPI.hs b/src/Chainweb/Pact/Payload/RestAPI.hs similarity index 93% rename from src/Chainweb/Payload/RestAPI.hs rename to src/Chainweb/Pact/Payload/RestAPI.hs index 977d9957fb..dc5b6eec76 100644 --- a/src/Chainweb/Payload/RestAPI.hs +++ b/src/Chainweb/Pact/Payload/RestAPI.hs @@ -9,7 +9,7 @@ {-# LANGUAGE TypeOperators #-} -- | --- Module: Chainweb.Payload.RestAPI +-- Module: Chainweb.Pact.Payload.RestAPI -- Copyright: Copyright © 2018 - 2020 Kadena LLC. -- License: MIT -- Maintainer: Lars Kuhtz @@ -17,7 +17,7 @@ -- -- The Block Payload REST API -- -module Chainweb.Payload.RestAPI +module Chainweb.Pact.Payload.RestAPI ( -- * Batch size limits PayloadBatchLimit(..) @@ -69,8 +69,8 @@ import Servant.API import Chainweb.BlockHeader import Chainweb.ChainId -import Chainweb.Payload -import Chainweb.Payload.PayloadStore +import Chainweb.Pact.Payload +import Chainweb.Pact.Payload.PayloadStore import Chainweb.RestAPI.Orphans () import Chainweb.RestAPI.Utils import Chainweb.Version @@ -101,9 +101,12 @@ data SomePayloadDb tbl = forall v c . (KnownChainwebVersionSymbol v, KnownChainIdSymbol c) => SomePayloadDb (PayloadDb' tbl v c) -somePayloadDbVal :: forall tbl . ChainwebVersion -> ChainId -> PayloadDb tbl -> SomePayloadDb tbl -somePayloadDbVal v cid db = runIdentity $ do - SomeChainwebVersionT (Proxy :: Proxy vt) <- return $ someChainwebVersionVal v +somePayloadDbVal + :: forall tbl + . HasVersion + => ChainId -> PayloadDb tbl -> SomePayloadDb tbl +somePayloadDbVal cid db = runIdentity $ do + SomeChainwebVersionT (Proxy :: Proxy vt) <- return $ someChainwebVersionVal SomeChainIdT (Proxy :: Proxy cidt) <- return $ someChainIdVal cid return $! SomePayloadDb (PayloadDb' @tbl @vt @cidt db) @@ -233,11 +236,11 @@ payloadApi = Proxy -- -------------------------------------------------------------------------- -- -- Some Payload API -somePayloadApi :: ChainwebVersion -> ChainId -> SomeApi -somePayloadApi v c = runIdentity $ do - SomeChainwebVersionT (_ :: Proxy v') <- return $ someChainwebVersionVal v +somePayloadApi :: HasVersion => ChainId -> SomeApi +somePayloadApi c = runIdentity $ do + SomeChainwebVersionT (_ :: Proxy v') <- return $ someChainwebVersionVal SomeChainIdT (_ :: Proxy c') <- return $ someChainIdVal c return $! SomeApi (payloadApi @v' @c') -somePayloadApis :: ChainwebVersion -> [ChainId] -> SomeApi -somePayloadApis v = mconcat . fmap (somePayloadApi v) +somePayloadApis :: HasVersion => [ChainId] -> SomeApi +somePayloadApis = mconcat . fmap somePayloadApi diff --git a/src/Chainweb/Payload/RestAPI/Client.hs b/src/Chainweb/Pact/Payload/RestAPI/Client.hs similarity index 79% rename from src/Chainweb/Payload/RestAPI/Client.hs rename to src/Chainweb/Pact/Payload/RestAPI/Client.hs index 0ba7a9cdd5..d031f2f145 100644 --- a/src/Chainweb/Payload/RestAPI/Client.hs +++ b/src/Chainweb/Pact/Payload/RestAPI/Client.hs @@ -5,7 +5,7 @@ {-# LANGUAGE TypeApplications #-} -- | --- Module: Chainweb.Payload.RestAPI.Client +-- Module: Chainweb.Pact.Payload.RestAPI.Client -- Copyright: Copyright © 2018 - 2020 Kadena LLC. -- License: MIT -- Maintainer: Lars Kuhtz @@ -13,7 +13,7 @@ -- -- Client implementation of the block payload REST API -- -module Chainweb.Payload.RestAPI.Client +module Chainweb.Pact.Payload.RestAPI.Client ( payloadClient , payloadBatchClient , outputsClient @@ -30,8 +30,8 @@ import Servant.Client import Chainweb.BlockHeader import Chainweb.ChainId -import Chainweb.Payload -import Chainweb.Payload.RestAPI +import Chainweb.Pact.Payload +import Chainweb.Pact.Payload.RestAPI import Chainweb.RestAPI.Orphans () import Chainweb.Version import Chainweb.BlockHeight (BlockHeight) @@ -49,13 +49,13 @@ payloadClient_ payloadClient_ = client (payloadGetApi @v @c) payloadClient - :: ChainwebVersion - -> ChainId + :: HasVersion + => ChainId -> BlockPayloadHash -> Maybe BlockHeight -> ClientM PayloadData -payloadClient v c k h = runIdentity $ do - SomeChainwebVersionT (_ :: Proxy v) <- return $ someChainwebVersionVal v +payloadClient c k h = runIdentity $ do + SomeChainwebVersionT (_ :: Proxy v) <- return someChainwebVersionVal SomeChainIdT (_ :: Proxy c) <- return $ someChainIdVal c return $ payloadClient_ @v @c k h @@ -74,12 +74,12 @@ payloadBatchClient_ = client (payloadPostApi @v @c) -- data. Results are returned in any order. -- payloadBatchClient - :: ChainwebVersion - -> ChainId + :: HasVersion + => ChainId -> BatchBody -> ClientM PayloadDataList -payloadBatchClient v c k = runIdentity $ do - SomeChainwebVersionT (_ :: Proxy v) <- return $ someChainwebVersionVal v +payloadBatchClient c k = runIdentity $ do + SomeChainwebVersionT (_ :: Proxy v) <- return someChainwebVersionVal SomeChainIdT (_ :: Proxy c) <- return $ someChainIdVal c return $ payloadBatchClient_ @v @c k @@ -96,13 +96,13 @@ outputsClient_ outputsClient_ = client (outputsGetApi @v @c) outputsClient - :: ChainwebVersion - -> ChainId + :: HasVersion + => ChainId -> BlockPayloadHash -> Maybe BlockHeight -> ClientM PayloadWithOutputs -outputsClient v c k h = runIdentity $ do - SomeChainwebVersionT (_ :: Proxy v) <- return $ someChainwebVersionVal v +outputsClient c k h = runIdentity $ do + SomeChainwebVersionT (_ :: Proxy v) <- return someChainwebVersionVal SomeChainIdT (_ :: Proxy c) <- return $ someChainIdVal c return $ outputsClient_ @v @c k h @@ -118,11 +118,11 @@ outputsBatchClient_ outputsBatchClient_ = client (outputsPostApi @v @c) outputsBatchClient - :: ChainwebVersion - -> ChainId + :: HasVersion + => ChainId -> BatchBody -> ClientM PayloadWithOutputsList -outputsBatchClient v c k = runIdentity $ do - SomeChainwebVersionT (_ :: Proxy v) <- return $ someChainwebVersionVal v +outputsBatchClient c k = runIdentity $ do + SomeChainwebVersionT (_ :: Proxy v) <- return someChainwebVersionVal SomeChainIdT (_ :: Proxy c) <- return $ someChainIdVal c return $ outputsBatchClient_ @v @c k diff --git a/src/Chainweb/Payload/RestAPI/Server.hs b/src/Chainweb/Pact/Payload/RestAPI/Server.hs similarity index 93% rename from src/Chainweb/Payload/RestAPI/Server.hs rename to src/Chainweb/Pact/Payload/RestAPI/Server.hs index fff98a0182..68cc7d4965 100644 --- a/src/Chainweb/Payload/RestAPI/Server.hs +++ b/src/Chainweb/Pact/Payload/RestAPI/Server.hs @@ -9,7 +9,7 @@ {-# LANGUAGE TypeFamilies #-} -- | --- Module: Chainweb.Payload.RestAPI.Server +-- Module: Chainweb.Pact.Payload.RestAPI.Server -- Copyright: Copyright © 2018 - 2020 Kadena LLC. -- License: MIT -- Maintainer: Lars Kuhtz @@ -17,7 +17,7 @@ -- -- Server implementation of the block payload REST API -- -module Chainweb.Payload.RestAPI.Server +module Chainweb.Pact.Payload.RestAPI.Server ( somePayloadServer , somePayloadServers @@ -46,9 +46,9 @@ import Servant import Chainweb.BlockHeader import Chainweb.ChainId -import Chainweb.Payload -import Chainweb.Payload.PayloadStore -import Chainweb.Payload.RestAPI +import Chainweb.Pact.Payload +import Chainweb.Pact.Payload.PayloadStore +import Chainweb.Pact.Payload.RestAPI import Chainweb.RestAPI.Orphans () import Chainweb.RestAPI.Utils import Chainweb.Utils (int) @@ -173,6 +173,7 @@ payloadApiLayout _ = T.putStrLn $ layout (Proxy @(PayloadApi v c)) somePayloadServer :: CanReadablePayloadCas tbl + => HasVersion => PayloadBatchLimit -> SomePayloadDb tbl -> SomeServer @@ -181,9 +182,9 @@ somePayloadServer batchLimit (SomePayloadDb (db :: PayloadDb' tbl v c)) somePayloadServers :: CanReadablePayloadCas tbl - => ChainwebVersion - -> PayloadBatchLimit + => HasVersion + => PayloadBatchLimit -> [(ChainId, PayloadDb tbl)] -> SomeServer -somePayloadServers v batchLimit - = mconcat . fmap (somePayloadServer batchLimit . uncurry (somePayloadDbVal v)) +somePayloadServers batchLimit + = mconcat . fmap (somePayloadServer batchLimit . uncurry somePayloadDbVal) diff --git a/src/Chainweb/Pact/RestAPI.hs b/src/Chainweb/Pact/RestAPI.hs index 16a4ffff30..dc183697ac 100644 --- a/src/Chainweb/Pact/RestAPI.hs +++ b/src/Chainweb/Pact/RestAPI.hs @@ -22,16 +22,14 @@ module Chainweb.Pact.RestAPI , pactApi -- ** Pact APIs for Individual commands -, PactLocalApi +, ApiLocal , pactLocalApi -, PactListenApi +, ApiListen , pactListenApi -, PactSendApi +, ApiSend , pactSendApi -, PactLocalWithQueryApi -, pactLocalWithQueryApi -, PactPollWithQueryApi -, pactPollWithQueryApi +, ApiPoll +, pactPollApi -- * Pact Spv Api , PactSpvApi , pactSpvApi @@ -56,8 +54,6 @@ module Chainweb.Pact.RestAPI import Data.Text (Text) -import qualified Pact.Types.Command as Pact -import qualified Pact.Server.API as Pact4 import Pact.Utils.Servant import Servant @@ -71,7 +67,8 @@ import Chainweb.Pact.Types import Chainweb.RestAPI.Utils import Chainweb.SPV.PayloadProof import Chainweb.Version -import qualified Pact.Core.Command.Server as Pact5 +import qualified Pact.Core.Command.Server as Pact +import qualified Pact.Core.Command.Types as Pact -- -------------------------------------------------------------------------- -- -- @POST /chainweb///chain//pact/@ @@ -81,11 +78,12 @@ type PactApi_ = "pact" :> "api" :> "v1" - :> ( Pact4.ApiSend - :<|> PactPollWithQueryApi_ - :<|> ApiListen - :<|> PactLocalWithQueryApi_ - ) + :> + ( ApiSend + :<|> ApiPoll + :<|> ApiListen + :<|> ApiLocal + ) type PactApi (v :: ChainwebVersionT) (c :: ChainIdT) = 'ChainwebEndpoint v :> ChainEndpoint c :> Reassoc PactApi_ @@ -106,60 +104,43 @@ type PactV1ApiEndpoint (v :: ChainwebVersionT) (c :: ChainIdT) api :> "v1" :> api -type PactLocalApi v c = PactV1ApiEndpoint v c Pact4.ApiLocal -type PactSendApi v c = PactV1ApiEndpoint v c Pact4.ApiSend -type PactListenApi v c = PactV1ApiEndpoint v c ApiListen +type ApiPoll + = "poll" + :> QueryParam "confirmationDepth" ConfirmationDepth + :> ReqBody '[PactJson] Pact.PollRequest + :> Post '[PactJson] Pact.PollResponse + +type ApiSend = "send" :> ReqBody '[PactJson] Pact.SendRequest :> Post '[PactJson] Pact.SendResponse + +type ApiListen = "listen" :> ReqBody '[PactJson] Pact.ListenRequest :> Post '[PactJson] Pact.ListenResponse -type ApiListen = ("listen" :> ReqBody '[PactJson] Pact5.ListenRequest :> Post '[PactJson] Pact5.ListenResponse) +type ApiLocal + = "local" + :> QueryParam "preflight" LocalPreflightSimulation + :> QueryParam "signatureVerification" LocalSignatureVerification + :> QueryParam "rewindDepth" RewindDepth + :> ReqBody '[PactJson] (Pact.Command Text) + :> Post '[PactJson] LocalResult pactLocalApi :: forall (v :: ChainwebVersionT) (c :: ChainIdT) - . Proxy (PactLocalApi v c) + . Proxy (PactV1ApiEndpoint v c ApiLocal) pactLocalApi = Proxy pactSendApi :: forall (v :: ChainwebVersionT) (c :: ChainIdT) - . Proxy (PactSendApi v c) + . Proxy (PactV1ApiEndpoint v c ApiSend) pactSendApi = Proxy pactListenApi :: forall (v :: ChainwebVersionT) (c :: ChainIdT) - . Proxy (PactListenApi v c) + . Proxy (PactV1ApiEndpoint v c ApiListen) pactListenApi = Proxy --- -------------------------------------------------------------------------- -- --- POST Queries for Pact Local Pre-flight - -type PactLocalWithQueryApi_ - = "local" - :> QueryParam "preflight" LocalPreflightSimulation - :> QueryParam "signatureVerification" LocalSignatureVerification - :> QueryParam "rewindDepth" RewindDepth - :> ReqBody '[PactJson] (Pact.Command Text) - :> Post '[PactJson] LocalResult - -type PactLocalWithQueryApi v c = PactV1ApiEndpoint v c PactLocalWithQueryApi_ - -pactLocalWithQueryApi - :: forall (v :: ChainwebVersionT) (c :: ChainIdT) - . Proxy (PactLocalWithQueryApi v c) -pactLocalWithQueryApi = Proxy - --- -------------------------------------------------------------------------- -- --- POST Queries for Pact Poll - -type PactPollWithQueryApi_ - = "poll" - :> QueryParam "confirmationDepth" ConfirmationDepth - :> ReqBody '[PactJson] Pact5.PollRequest - :> Post '[PactJson] Pact5.PollResponse - -type PactPollWithQueryApi v c = PactV1ApiEndpoint v c PactPollWithQueryApi_ - -pactPollWithQueryApi +pactPollApi :: forall (v :: ChainwebVersionT) (c :: ChainIdT) - . Proxy (PactPollWithQueryApi v c) -pactPollWithQueryApi = Proxy + . Proxy (PactV1ApiEndpoint v c ApiPoll) +pactPollApi = Proxy -- -------------------------------------------------------------------------- -- -- POST Pact Spv Transaction Proof @@ -221,9 +202,9 @@ ethSpvApi = Proxy type PactServiceApi v c = PactApi v c - :<|> PactSpvApi v c - :<|> EthSpvApi v c - :<|> PactSpv2Api v c + -- :<|> PactSpvApi v c + -- :<|> EthSpvApi v c + -- :<|> PactSpv2Api v c pactServiceApi :: forall (v :: ChainwebVersionT) (c :: ChainIdT) @@ -233,11 +214,11 @@ pactServiceApi = Proxy -- -------------------------------------------------------------------------- -- -- Some Cut Api -somePactServiceApi :: ChainwebVersion -> ChainId -> SomeApi +somePactServiceApi :: HasVersion => ChainId -> SomeApi somePactServiceApi - (FromSingChainwebVersion (SChainwebVersion :: Sing v)) (FromSingChainId (SChainId :: Sing c)) - = SomeApi $ pactServiceApi @v @c + | (SomeChainwebVersionT (_ :: Proxy v)) <- someChainwebVersionVal + = SomeApi $ pactServiceApi @v @c -somePactServiceApis :: ChainwebVersion -> [ChainId] -> SomeApi -somePactServiceApis v = mconcat . fmap (somePactServiceApi v) +somePactServiceApis :: HasVersion => [ChainId] -> SomeApi +somePactServiceApis = mconcat . fmap somePactServiceApi diff --git a/src/Chainweb/Pact/RestAPI/Client.hs b/src/Chainweb/Pact/RestAPI/Client.hs index e416b0961d..f076199733 100644 --- a/src/Chainweb/Pact/RestAPI/Client.hs +++ b/src/Chainweb/Pact/RestAPI/Client.hs @@ -25,18 +25,14 @@ module Chainweb.Pact.RestAPI.Client , pactSendApiClient , pactLocalApiClient_ , pactLocalApiClient -, pactLocalWithQueryApiClient_ -, pactLocalWithQueryApiClient -, pactPollWithQueryApiClient_ -, pactPollWithQueryApiClient +, pactPollApiClient_ +, pactPollApiClient ) where import qualified Data.Text as T -import Pact.Types.API -import Pact.Types.Command -import Pact.Types.Hash +import Pact.Core.Command.Types hiding (ChainId) import Servant.Client @@ -49,7 +45,8 @@ import Chainweb.Pact.RestAPI.SPV import Chainweb.Pact.Types import Chainweb.SPV.PayloadProof import Chainweb.Version -import qualified Pact.Core.Command.Server as Pact5 +import qualified Pact.Core.Command.Server as Pact +import Data.Proxy (Proxy) -- -------------------------------------------------------------------------- -- -- Pact Spv Transaction Output Proof Client @@ -67,8 +64,8 @@ pactSpvApiClient_ pactSpvApiClient_ = client (pactSpvApi @v @c) pactSpvApiClient - :: ChainwebVersion - -> ChainId + :: HasVersion + => ChainId -- ^ the chain id of the source chain id used in the -- execution of a cross-chain-transfer. -> SpvRequest @@ -77,10 +74,9 @@ pactSpvApiClient -- Also contains the request key of of the cross-chain transfer -- tx request. -> ClientM TransactionOutputProofB64 -pactSpvApiClient - (FromSingChainwebVersion (SChainwebVersion :: Sing v)) - (FromSingChainId (SChainId :: Sing c)) - = pactSpvApiClient_ @v @c +pactSpvApiClient (FromSingChainId (SChainId :: Sing c)) r = do + SomeChainwebVersionT (_ :: Proxy v) <- return $ someChainwebVersionVal + pactSpvApiClient_ @v @c r -- -------------------------------------------------------------------------- -- -- Pact ETH Spv Transaction Output Proof Client @@ -94,16 +90,15 @@ ethSpvApiClient_ ethSpvApiClient_ = client (ethSpvApi @v @c) ethSpvApiClient - :: ChainwebVersion - -> ChainId + :: HasVersion + => ChainId -- ^ chain to which the request is submitted. The resuting proof does -- not depend on the chain and can be validated on any chain. -> EthSpvRequest -> ClientM EthSpvResponse -ethSpvApiClient - (FromSingChainwebVersion (SChainwebVersion :: Sing v)) - (FromSingChainId (SChainId :: Sing c)) - = ethSpvApiClient_ @v @c +ethSpvApiClient (FromSingChainId (SChainId :: Sing c)) = do + SomeChainwebVersionT (_ :: Proxy v) <- return $ someChainwebVersionVal + ethSpvApiClient_ @v @c -- -------------------------------------------------------------------------- -- -- Pact ETH Spv Transaction Output Proof Client @@ -121,38 +116,19 @@ pactSpv2ApiClient_ pactSpv2ApiClient_ = client (pactSpv2Api @v @c) pactSpv2ApiClient - :: ChainwebVersion - -> ChainId + :: HasVersion + => ChainId -- ^ the chain id of the target chain of the proof. -> Spv2Request -> ClientM SomePayloadProof -pactSpv2ApiClient - (FromSingChainwebVersion (SChainwebVersion :: Sing v)) - (FromSingChainId (SChainId :: Sing c)) - = pactSpv2ApiClient_ @v @c +pactSpv2ApiClient (FromSingChainId (SChainId :: Sing c)) = do + SomeChainwebVersionT (_ :: Proxy v) <- return $ someChainwebVersionVal + pactSpv2ApiClient_ @v @c -- -------------------------------------------------------------------------- -- -- Pact local pactLocalApiClient_ - :: forall (v :: ChainwebVersionT) (c :: ChainIdT) - . KnownChainwebVersionSymbol v - => KnownChainIdSymbol c - => Command T.Text - -> ClientM (CommandResult Hash) -pactLocalApiClient_ = client (pactLocalApi @v @c) - -pactLocalApiClient - :: ChainwebVersion - -> ChainId - -> Command T.Text - -> ClientM (CommandResult Hash) -pactLocalApiClient - (FromSingChainwebVersion (SChainwebVersion :: Sing v)) - (FromSingChainId (SChainId :: Sing c)) - = pactLocalApiClient_ @v @c - -pactLocalWithQueryApiClient_ :: forall (v :: ChainwebVersionT) (c :: ChainIdT) . KnownChainwebVersionSymbol v => KnownChainIdSymbol c @@ -161,20 +137,19 @@ pactLocalWithQueryApiClient_ -> Maybe RewindDepth -> Command T.Text -> ClientM LocalResult -pactLocalWithQueryApiClient_ = client (pactLocalWithQueryApi @v @c) +pactLocalApiClient_ = client (pactLocalApi @v @c) -pactLocalWithQueryApiClient - :: ChainwebVersion - -> ChainId +pactLocalApiClient + :: HasVersion + => ChainId -> Maybe LocalPreflightSimulation -> Maybe LocalSignatureVerification -> Maybe RewindDepth -> Command T.Text -> ClientM LocalResult -pactLocalWithQueryApiClient - (FromSingChainwebVersion (SChainwebVersion :: Sing v)) - (FromSingChainId (SChainId :: Sing c)) - = pactLocalWithQueryApiClient_ @v @c +pactLocalApiClient (FromSingChainId (SChainId :: Sing c)) = do + SomeChainwebVersionT (_ :: Proxy v) <- return $ someChainwebVersionVal + pactLocalApiClient_ @v @c -- -------------------------------------------------------------------------- -- -- Pact Listen @@ -183,19 +158,18 @@ pactListenApiClient_ :: forall (v :: ChainwebVersionT) (c :: ChainIdT) . KnownChainwebVersionSymbol v => KnownChainIdSymbol c - => Pact5.ListenRequest - -> ClientM Pact5.ListenResponse + => Pact.ListenRequest + -> ClientM Pact.ListenResponse pactListenApiClient_ = client (pactListenApi @v @c) pactListenApiClient - :: ChainwebVersion - -> ChainId - -> Pact5.ListenRequest - -> ClientM Pact5.ListenResponse -pactListenApiClient - (FromSingChainwebVersion (SChainwebVersion :: Sing v)) - (FromSingChainId (SChainId :: Sing c)) - = pactListenApiClient_ @v @c + :: HasVersion + => ChainId + -> Pact.ListenRequest + -> ClientM Pact.ListenResponse +pactListenApiClient (FromSingChainId (SChainId :: Sing c)) = do + SomeChainwebVersionT (_ :: Proxy v) <- return $ someChainwebVersionVal + pactListenApiClient_ @v @c -- -------------------------------------------------------------------------- -- -- Pact Send @@ -204,37 +178,37 @@ pactSendApiClient_ :: forall (v :: ChainwebVersionT) (c :: ChainIdT) . KnownChainwebVersionSymbol v => KnownChainIdSymbol c - => SubmitBatch - -> ClientM RequestKeys + => Pact.SendRequest + -> ClientM Pact.SendResponse pactSendApiClient_ = client (pactSendApi @v @c) pactSendApiClient - :: ChainwebVersion - -> ChainId - -> SubmitBatch - -> ClientM RequestKeys -pactSendApiClient - (FromSingChainwebVersion (SChainwebVersion :: Sing v)) - (FromSingChainId (SChainId :: Sing c)) - = pactSendApiClient_ @v @c + :: HasVersion + => ChainId + -> Pact.SendRequest + -> ClientM Pact.SendResponse +pactSendApiClient (FromSingChainId (SChainId :: Sing c)) = do + SomeChainwebVersionT (_ :: Proxy v) <- return $ someChainwebVersionVal + pactSendApiClient_ @v @c -- -------------------------------------------------------------------------- -- -- Pact Poll -pactPollWithQueryApiClient_ +pactPollApiClient_ :: forall (v :: ChainwebVersionT) (c :: ChainIdT) . KnownChainwebVersionSymbol v => KnownChainIdSymbol c => Maybe ConfirmationDepth - -> Pact5.PollRequest - -> ClientM Pact5.PollResponse -pactPollWithQueryApiClient_ = client (pactPollWithQueryApi @v @c) + -> Pact.PollRequest + -> ClientM Pact.PollResponse +pactPollApiClient_ = client (pactPollApi @v @c) -pactPollWithQueryApiClient - :: ChainwebVersion - -> ChainId +pactPollApiClient + :: HasVersion + => ChainId -> Maybe ConfirmationDepth - -> Pact5.PollRequest - -> ClientM Pact5.PollResponse -pactPollWithQueryApiClient (FromSingChainwebVersion (SChainwebVersion :: Sing v)) (FromSingChainId (SChainId :: Sing c)) confirmationDepth poll = do - pactPollWithQueryApiClient_ @v @c confirmationDepth poll + -> Pact.PollRequest + -> ClientM Pact.PollResponse +pactPollApiClient (FromSingChainId (SChainId :: Sing c)) = do + SomeChainwebVersionT (_ :: Proxy v) <- return $ someChainwebVersionVal + pactPollApiClient_ @v @c diff --git a/src/Chainweb/Pact/RestAPI/SPV.hs b/src/Chainweb/Pact/RestAPI/SPV.hs index bee0c09456..93a06625d2 100644 --- a/src/Chainweb/Pact/RestAPI/SPV.hs +++ b/src/Chainweb/Pact/RestAPI/SPV.hs @@ -27,7 +27,7 @@ import GHC.Generics import Numeric.Natural -import Pact.Types.Command +import Pact.Core.Command.Types hiding (ChainId) import Pact.JSON.Legacy.Value -- internal modules @@ -139,4 +139,3 @@ instance FromJSON Spv2Request where <$> o .: "subjectIdentifier" <*> o .:? "minimalProofDepth" .!= Nothing <*> o .: "algorithm" - diff --git a/src/Chainweb/Pact/RestAPI/Server.hs b/src/Chainweb/Pact/RestAPI/Server.hs index 80f7ea94ea..5a92c0bca8 100644 --- a/src/Chainweb/Pact/RestAPI/Server.hs +++ b/src/Chainweb/Pact/RestAPI/Server.hs @@ -14,6 +14,7 @@ {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE NumericUnderscores #-} module Chainweb.Pact.RestAPI.Server ( PactServerData(..) @@ -25,29 +26,23 @@ module Chainweb.Pact.RestAPI.Server , pollHandler , listenHandler , localHandler -, spvHandler +-- , spvHandler , somePactServer , somePactServers , validateCommand -, validatePact5Command ) where import Control.Applicative -import Control.Concurrent.STM (atomically) import Control.Concurrent.STM.TVar import Control.DeepSeq import Control.Lens hiding ((.=)) import Control.Monad -import Control.Monad.Catch hiding (Handler) import Control.Monad.Reader -import Control.Monad.State.Strict import Control.Monad.Trans.Except (ExceptT, runExceptT, except) -import Data.Aeson as Aeson +import Data.Aeson as Aeson hiding (Success) import Data.Bifunctor (second) -import Data.ByteString (ByteString) import qualified Data.ByteString.Lazy as BSL -import qualified Data.ByteString.Lazy.Char8 as BSL8 import qualified Data.ByteString.Short as SB import Data.Either (partitionEithers, isRight) import Data.Foldable @@ -58,95 +53,65 @@ import qualified Data.List as L import Data.List.NonEmpty (NonEmpty) import qualified Data.List.NonEmpty as NEL import Data.Maybe -import Data.Singletons import Data.Text (Text) import qualified Data.Text as T import Data.Text.Encoding +import Data.Validation import Data.Vector (Vector) import qualified Data.Vector as V -import Ethereum.Block -import Ethereum.Header hiding (blockHash) -import Ethereum.Misc (bytes) -import Ethereum.Receipt -import Ethereum.Receipt.ReceiptProof -import Ethereum.RLP (putRlpByteString) - import GHC.Generics import GHC.Stack -import Numeric.Natural - import Prelude hiding (init, lookup) import Servant -import qualified Streaming.Prelude as S - import System.LogLevel -- internal modules import Chainweb.BlockHash import Chainweb.BlockHeader -import Chainweb.BlockHeaderDB import Chainweb.BlockHeight import Chainweb.ChainId -import Chainweb.Crypto.MerkleLog -import Chainweb.Cut -import qualified Chainweb.CutDB as CutDB -import Chainweb.Graph import Chainweb.Logger -import Chainweb.Mempool.Mempool - (InsertError(..), InsertType(..), MempoolBackend(..), TransactionHash(..), pact5RequestKeyToTransactionHash) +import Chainweb.Pact.Mempool.Mempool + (InsertError(..), InsertType(..), MempoolBackend(..), TransactionHash(..), pactRequestKeyToTransactionHash) import Chainweb.Pact.RestAPI -import Chainweb.Pact.RestAPI.EthSpv -import Chainweb.Pact.RestAPI.SPV import Chainweb.Pact.Types -import Chainweb.Pact4.SPV qualified as Pact4 -import Pact.Types.ChainMeta qualified as Pact4 -import Chainweb.Payload -import Chainweb.Payload.PayloadStore +import Chainweb.Pact.Payload +import Chainweb.Pact.Payload.PayloadStore import Chainweb.RestAPI.Orphans () import Chainweb.RestAPI.Utils -import Chainweb.SPV (SpvException(..)) -import Chainweb.SPV.CreateProof -import Chainweb.SPV.EventProof -import Chainweb.SPV.OutputProof -import Chainweb.SPV.PayloadProof -import qualified Chainweb.Pact4.Transaction as Pact4 hiding (parsePact) -import qualified Chainweb.TreeDB as TreeDB +import Chainweb.Pact.Transaction qualified as Pact import Chainweb.Utils import Chainweb.Version -import qualified Chainweb.Pact4.Validations as Pact4 -import Chainweb.Version.Guards (isWebAuthnPrefixLegal, validPPKSchemes) -import Chainweb.WebPactExecutionService +import Chainweb.Pact.Validations qualified as Pact import qualified Pact.JSON.Encode as J -import qualified Pact.Parse as Pact4 -import qualified Pact.Types.API as Pact4 -import qualified Pact.Types.ChainId as Pact4 -import qualified Pact.Types.Command as Pact4 -import qualified Pact.Types.Hash as Pact4 - -import qualified Pact.Core.Command.Types as Pact5 -import qualified Pact.Core.Pretty as Pact5 -import qualified Chainweb.Pact5.Transaction as Pact5 -import qualified Chainweb.Pact5.Types as Pact5 -import qualified Chainweb.Pact5.Validations as Pact5 + +import qualified Pact.Core.Command.Types as Pact +import qualified Pact.Core.Pretty as Pact +import qualified Chainweb.Pact.Types as Pact import Data.Coerce -import qualified Pact.Core.Command.Server as Pact5 -import qualified Pact.Core.Errors as Pact5 -import qualified Pact.Core.Hash as Pact5 -import qualified Pact.Core.Gas as Pact5 +import qualified Pact.Core.Command.Server as Pact +import qualified Pact.Core.Errors as Pact +import qualified Pact.Core.Hash as Pact +import qualified Pact.Core.Gas as Pact +import qualified Pact.Core.Command.Client as Pact +import Chainweb.PayloadProvider.P2P +import Chainweb.Pact.PactService +import Chainweb.Pact.Backend.Types (Historical(..), throwIfNoHistory) +import qualified Pact.Core.Info as Pact +import Control.Concurrent (threadDelay) -- -------------------------------------------------------------------------- -- data PactServerData logger tbl = PactServerData - { _pactServerDataCutDb :: !(CutDB.CutDb tbl) - , _pactServerDataMempool :: !(MempoolBackend Pact4.UnparsedTransaction) + { _pactServerDataMempool :: !(MempoolBackend Pact.Transaction) , _pactServerDataLogger :: !logger - , _pactServerDataPact :: !PactExecutionService + , _pactServerDataPact :: !(ServiceEnv tbl) } newtype PactServerData_ (v :: ChainwebVersionT) (c :: ChainIdT) logger tbl @@ -159,70 +124,66 @@ data SomePactServerData = forall v c logger tbl Logger logger) => SomePactServerData (PactServerData_ v c logger tbl) - somePactServerData :: CanReadablePayloadCas tbl => Logger logger - => ChainwebVersion - -> ChainId + => HasVersion + => ChainId -> PactServerData logger tbl -> SomePactServerData -somePactServerData v cid db = - case someChainwebVersionVal v of +somePactServerData cid db = + case someChainwebVersionVal of (SomeChainwebVersionT (Proxy :: Proxy vt)) -> case someChainIdVal cid of (SomeChainIdT (Proxy :: Proxy cidt)) -> SomePactServerData (PactServerData_ @vt @cidt db) - pactServer :: forall v c tbl logger . KnownChainwebVersionSymbol v => KnownChainIdSymbol c => CanReadablePayloadCas tbl => Logger logger + => HasVersion => PactServerData logger tbl -> Server (PactServiceApi v c) pactServer d = pactApiHandlers - :<|> pactSpvHandler - :<|> ethSpvHandler - :<|> pactSpv2Handler + -- :<|> pactSpvHandler + -- :<|> ethSpvHandler + -- :<|> pactSpv2Handler where - cid = FromSing (SChainId :: Sing c) mempool = _pactServerDataMempool d logger = _pactServerDataLogger d pact = _pactServerDataPact d - cdb = _pactServerDataCutDb d pactApiHandlers = sendHandler logger mempool - :<|> pollHandler logger cdb cid pact mempool - :<|> listenHandler logger cdb cid pact mempool + :<|> pollHandler logger pact mempool + :<|> listenHandler logger pact mempool :<|> localHandler logger pact - pactSpvHandler = spvHandler logger cdb cid - pactSpv2Handler = spv2Handler logger cdb cid + -- pactSpvHandler = spvHandler logger cdb pdb pact cid + -- pactSpv2Handler = spv2Handler logger cdb pdb pact cid -somePactServer :: SomePactServerData -> SomeServer +somePactServer :: HasVersion => SomePactServerData -> SomeServer somePactServer (SomePactServerData (db :: PactServerData_ v c logger tbl)) = SomeServer (Proxy @(PactServiceApi v c)) (pactServer @v @c $ _unPactServerData db) - somePactServers :: CanReadablePayloadCas tbl => Logger logger - => ChainwebVersion - -> [(ChainId, PactServerData logger tbl)] + => HasVersion + => [(ChainId, PactServerData logger tbl)] -> SomeServer -somePactServers v = - mconcat . fmap (somePactServer . uncurry (somePactServerData v)) +somePactServers = + mconcat . fmap (somePactServer . uncurry somePactServerData) data PactCmdLog - = PactCmdLogSend (NonEmpty (Pact4.Command Text)) + = PactCmdLogSend (NonEmpty (Pact.Command Text)) | PactCmdLogPoll (NonEmpty Text) | PactCmdLogListen Text - | PactCmdLogLocal (Pact4.Command Text) + | PactCmdLogLocal (Pact.Command Text) | PactCmdLogSpv Text deriving (Show, Generic, NFData) @@ -256,22 +217,19 @@ instance ToJSON PactCmdLog where sendHandler :: Logger logger => logger - -> MempoolBackend Pact4.UnparsedTransaction - -> Pact4.SubmitBatch - -> Handler Pact4.RequestKeys -sendHandler logger mempool (Pact4.SubmitBatch cmds) = Handler $ do + -> MempoolBackend Pact.Transaction + -> Pact.SendRequest + -> Handler Pact.SendResponse +sendHandler logger mempool (Pact.SendRequest (Pact.SubmitBatch cmds)) = Handler $ do liftIO $ logg Info (PactCmdLogSend cmds) - let cmdPayloads :: Either String (NonEmpty (Pact4.Command (ByteString, Pact4.Payload Pact4.PublicMeta Text))) - cmdPayloads = traverse (traverse (\t -> (encodeUtf8 t,) <$> eitherDecodeStrictText t)) cmds - case cmdPayloads of - Right (fmap Pact4.mkPayloadWithText -> cmdsWithParsedPayloads) -> do - let cmdsWithParsedPayloadsV = V.fromList $ NEL.toList cmdsWithParsedPayloads - -- If any of the txs in the batch fail validation, we reject them all. - liftIO (mempoolInsertCheckVerbose mempool cmdsWithParsedPayloadsV) >>= checkResult - liftIO (mempoolInsert mempool UncheckedInsert cmdsWithParsedPayloadsV) - return $! Pact4.RequestKeys $ NEL.map Pact4.cmdToRequestKey cmdsWithParsedPayloads - Left err -> failWith $ "reading JSON for transaction failed: " <> T.pack err + cmdsWithParsedPayloads <- parsedCommands + let cmdsWithParsedPayloadsV = V.fromList $ NEL.toList cmdsWithParsedPayloads + -- If any of the txs in the batch fail validation, we reject them all. + liftIO (mempoolInsertCheckVerbose mempool cmdsWithParsedPayloadsV) >>= checkResult + liftIO (mempoolInsert mempool UncheckedInsert cmdsWithParsedPayloadsV) + return $! Pact.SendResponse $ Pact.RequestKeys $ fmap Pact.cmdToRequestKey cmdsWithParsedPayloads where + convertError = Pact._boundedText . Pact._peMsg . Pact.pactErrorToOnChainError . fmap Pact.spanInfoToLineInfo failWith :: Text -> ExceptT ServerError IO a failWith err = do liftIO $ logFunctionText logger Info err @@ -279,7 +237,25 @@ sendHandler logger mempool (Pact4.SubmitBatch cmds) = Handler $ do logg = logFunctionJson (setComponent "send-handler" logger) - checkResult :: Vector (T2 TransactionHash (Either InsertError Pact4.UnparsedTransaction)) -> ExceptT ServerError IO () + parsedCommands :: ExceptT ServerError IO (NonEmpty Pact.Transaction) + parsedCommands = do + let + parsedWithErrs = + flip traverse (NEL.zip (NEL.iterate succ (0 :: Word)) cmds) $ \(i, tx) -> + case Pact.parseCommand tx of + Left err -> + Failure $ NEL.singleton $ + "Transaction at index " <> sshow i <> + " has invalid Pact code: " <> convertError err + Right cmd -> + pure cmd + case parsedWithErrs of + Failure errs -> + failWith $ "One or more transactions has invalid Pact code: " <> T.intercalate ", " (toList errs) + Success parsedCmds -> + return parsedCmds + + checkResult :: Vector (T2 TransactionHash (Either InsertError Pact.Transaction)) -> ExceptT ServerError IO () checkResult vec | V.null vec = return () | otherwise = do @@ -299,20 +275,17 @@ sendHandler logger mempool (Pact4.SubmitBatch cmds) = Handler $ do -- TODO: convert to Pact 5? pollHandler :: (HasCallStack, CanReadablePayloadCas tbl, Logger logger) + => HasVersion => logger - -> CutDB.CutDb tbl - -> ChainId - -> PactExecutionService - -> MempoolBackend Pact4.UnparsedTransaction + -> ServiceEnv tbl + -> MempoolBackend Pact.Transaction -> Maybe ConfirmationDepth - -> Pact5.PollRequest - -> Handler Pact5.PollResponse -pollHandler logger cdb cid pact mem confDepth (Pact5.PollRequest request) = do - liftIO $! logg Info $ PactCmdLogPoll $ fmap Pact5.requestKeyToB64Text request - Pact5.PollResponse <$!> liftIO (internalPoll logger pdb bdb mem pact confDepth request) + -> Pact.PollRequest + -> Handler Pact.PollResponse +pollHandler logger pact mem confDepth (Pact.PollRequest request) = do + liftIO $! logg Info $ PactCmdLogPoll $ fmap Pact.requestKeyToB64Text request + Pact.PollResponse <$!> liftIO (internalPoll logger mem pact confDepth request) where - pdb = view CutDB.cutDbPayloadDb cdb - bdb = fromJuste $ preview (CutDB.cutDbBlockHeaderDb cid) cdb logg = logFunctionJson (setComponent "poll-handler" logger) -- -------------------------------------------------------------------------- -- @@ -321,49 +294,33 @@ pollHandler logger cdb cid pact mem confDepth (Pact5.PollRequest request) = do -- TODO: convert to Pact 5? listenHandler :: (CanReadablePayloadCas tbl, Logger logger) + => HasVersion => logger - -> CutDB.CutDb tbl - -> ChainId - -> PactExecutionService - -> MempoolBackend Pact4.UnparsedTransaction - -> Pact5.ListenRequest - -> Handler Pact5.ListenResponse -listenHandler logger cdb cid pact mem (Pact5.ListenRequest key) = do - liftIO $ logg Info $ PactCmdLogListen $ Pact5.requestKeyToB64Text key + -> ServiceEnv tbl + -> MempoolBackend Pact.Transaction + -> Pact.ListenRequest + -> Handler Pact.ListenResponse +listenHandler logger pact mem (Pact.ListenRequest key) = do + liftIO $ logg Info $ PactCmdLogListen $ Pact.requestKeyToB64Text key liftIO (registerDelay defaultTimeout) >>= runListen where - pdb = view CutDB.cutDbPayloadDb cdb - bdb = fromJuste $ preview (CutDB.cutDbBlockHeaderDb cid) cdb logg = logFunctionJson (setComponent "listen-handler" logger) - runListen :: TVar Bool -> Handler Pact5.ListenResponse - runListen timedOut = do - startCut <- liftIO $ CutDB._cut cdb - case HM.lookup cid (_cutMap startCut) of - Nothing -> throwError err504 - Just bh -> poll bh + runListen :: TVar Bool -> Handler Pact.ListenResponse + runListen timedOut = poll where - go :: BlockHeader -> Handler Pact5.ListenResponse - go !prevBlock = do - m <- liftIO $ waitForNewBlock prevBlock - case m of - Nothing -> throwError err504 - Just block -> poll block - - poll :: BlockHeader -> Handler Pact5.ListenResponse - poll bh = do - hm <- liftIO $ internalPoll logger pdb bdb mem pact Nothing (pure key) - if HM.null hm - then go bh - else pure $! Pact5.ListenResponse $ snd $ unsafeHead "Chainweb.Pact.RestAPI.Server.listenHandler.poll" $ HM.toList hm - - waitForNewBlock :: BlockHeader -> IO (Maybe BlockHeader) - waitForNewBlock lastBlockHeader = atomically $ do - isTimedOut <- readTVar timedOut + onMissing :: Handler Pact.ListenResponse + onMissing = do + isTimedOut <- liftIO $ readTVarIO timedOut if isTimedOut - then do - pure Nothing - else do - Just <$!> CutDB.awaitNewBlockStm cdb cid (view blockHash lastBlockHeader) + then throwError err504 + else liftIO (threadDelay 1_000_000) >> poll + + poll :: Handler Pact.ListenResponse + poll = do + hm <- liftIO $ internalPoll logger mem pact Nothing (pure key) + if HM.null hm + then onMissing + else pure $! Pact.ListenResponse $ snd $ unsafeHead "Chainweb.Pact.RestAPI.Server.listenHandler.poll" $ HM.toList hm -- TODO: make configurable defaultTimeout = 180 * 1000000 -- two minutes @@ -374,34 +331,35 @@ listenHandler logger cdb cid pact mem (Pact5.ListenRequest key) = do -- TODO: convert to Pact 5? localHandler :: Logger logger + => HasVersion + => CanReadablePayloadCas tbl => logger - -> PactExecutionService + -> ServiceEnv tbl -> Maybe LocalPreflightSimulation -- ^ Preflight flag -> Maybe LocalSignatureVerification -- ^ No sig verification flag -> Maybe RewindDepth -- ^ Rewind depth - -> Pact4.Command Text + -> Pact.Command Text -> Handler LocalResult localHandler logger pact preflight sigVerify rewindDepth cmd = do liftIO $ logg Info $ PactCmdLogLocal cmd - cmd' <- case validatedCommand of - Right c -> return c - Left err -> - throwError $ setErrText ("Validation failed: " <> T.pack err) err400 + cmd' <- validatedCommand - r <- liftIO $ try $ _pactLocal pact preflight sigVerify rewindDepth cmd' + r <- liftIO $ execLocal logger pact cmd' preflight sigVerify rewindDepth case r of - Left (err :: PactException) -> throwError $ setErrText - ("Execution failed: " <> T.pack (show err)) err400 - Right (preview _MetadataValidationFailure -> Just e) -> do + Historical (MetadataValidationFailure e) -> do throwError $ setErrText ("Metadata validation failed: " <> decodeUtf8 (BSL.toStrict (Aeson.encode e))) err400 - Right lr -> return $! lr + Historical lr -> return $! lr + NoHistory -> throwError $ setErrText + "No block exists at the given rewind depth" err500 where logg = logFunctionJson (setComponent "local-handler" logger) + mkParseError err = setErrJSONPact (Pact.pactErrorToOnChainError (Pact.spanInfoToLineInfo <$> err)) err400 + validatedCommand | Just NoVerify <- sigVerify = do -- @@ -411,218 +369,212 @@ localHandler logger pact preflight sigVerify rewindDepth cmd = do -- down in the 'execLocal' code, 'noSigVerify' triggers a nop on -- checking again if 'preflight' is set. -- - let payloadBS = encodeUtf8 (Pact4._cmdPayload cmd) - - void $ Pact4.verifyHash @'Pact4.Blake2b_256 (Pact4._cmdHash cmd) payloadBS - decoded <- eitherDecodeStrict' payloadBS - - let cmd' = cmd { Pact4._cmdPayload = (payloadBS, decoded) } - pure $ Pact4.mkPayloadWithText cmd' - | otherwise = Pact4.mkPayloadWithText <$> - traverse (\bs -> (encodeUtf8 bs,) <$> eitherDecodeStrictText bs) cmd + let command' = Pact.parseCommand cmd + case command' of + Left err -> throwError $ mkParseError err + Right cmd' -> pure cmd' + | otherwise = + either (throwError . mkParseError) return + $ Pact.parseCommand cmd -- -------------------------------------------------------------------------- -- -- Cross Chain SPV Handler -spvHandler - :: forall tbl l - . ( Logger l - , CanReadablePayloadCas tbl - ) - => l - -> CutDB.CutDb tbl - -- ^ cut db - -> ChainId - -- ^ the chain id of the source chain id used in the - -- execution of a cross-chain-transfer. - -> SpvRequest - -- ^ Contains the (pact) chain id of the target chain id used in the - -- 'target-chain' field of a cross-chain-transfer. - -- Also contains the request key of of the cross-chain transfer - -- tx request. - -> Handler TransactionOutputProofB64 -spvHandler l cdb cid (SpvRequest rk (Pact4.ChainId ptid)) = do - validateRequestKey rk - - liftIO $! logg (sshow ph) - - T2 bhe _bha <- liftIO (try $ _pactLookup pe cid Nothing (pure $ coerce $ Pact4.toUntypedHash ph)) >>= \case - Left (e :: PactException) -> - toErr $ "Internal error: transaction hash lookup failed: " <> sshow e - Right v -> case HM.lookup (coerce $ Pact4.toUntypedHash ph) v of - Nothing -> toErr $ "Transaction hash not found: " <> sshow ph - Just t -> return t - - idx <- liftIO (Pact4.getTxIdx bdb pdb bhe ph) >>= \case - Left e -> toErr - $ "Internal error: Index lookup for hash failed: " - <> sshow e - Right i -> return i - - tid <- chainIdFromText ptid - p <- liftIO (try $ createTransactionOutputProof cdb tid cid bhe idx) >>= \case - Left e@SpvExceptionTargetNotReachable{} -> - toErr $ "SPV target not reachable: " <> _spvExceptionMsg e - Left e@SpvExceptionVerificationFailed{} -> - toErr $ "SPV verification failed: " <> _spvExceptionMsg e - Left e -> - toErr $ "Internal error: SPV verification failed: " <> _spvExceptionMsg e - Right q -> return q - - return $! b64 p - where - pe = _webPactExecutionService $ view CutDB.cutDbPactService cdb - ph = Pact4.fromUntypedHash $ Pact4.unRequestKey rk - bdb = fromJuste $ preview (CutDB.cutDbBlockHeaderDb cid) cdb - pdb = view CutDB.cutDbPayloadDb cdb - b64 = TransactionOutputProofB64 - . encodeB64UrlNoPaddingText - . BSL8.toStrict - . Aeson.encode - - logg = logFunctionJson (setComponent "spv-handler" l) Info - . PactCmdLogSpv - - toErr e = throwError $ setErrText e err400 +-- spvHandler +-- :: forall tbl l +-- . Logger l +-- => CanReadablePayloadCas tbl +-- => l +-- -> CutDB.CutDb +-- -- ^ cut db +-- -> PayloadDb tbl +-- -> PactLookup +-- -> ChainId +-- -- ^ the chain id of the source chain id used in the +-- -- execution of a cross-chain-transfer. +-- -> SpvRequest +-- -- ^ Contains the (pact) chain id of the target chain id used in the +-- -- 'target-chain' field of a cross-chain-transfer. +-- -- Also contains the request key of of the cross-chain transfer +-- -- tx request. +-- -> Handler TransactionOutputProofB64 +-- spvHandler l cdb pdb pe cid (SpvRequest rk (Pact.ChainId ptid)) = do + +-- liftIO $! logg (sshow ph) + +-- T2 bhe _bha <- liftIO (pe cid Nothing (pure $ Pact.unHash ph)) >>= \v -> +-- -- Left (e :: PactException) -> +-- -- toErr $ "Internal error: transaction hash lookup failed: " <> sshow e +-- case HM.lookup (Pact.unHash ph) v of +-- Nothing -> toErr $ "Transaction hash not found: " <> sshow ph +-- Just t -> return t + +-- idx <- undefined >>= \case -- liftIO (Pact.getTxIdx bdb pdb bhe ph) >>= \case +-- Left e -> toErr +-- $ "Internal error: Index lookup for hash failed: " +-- <> sshow e +-- Right i -> return i + +-- tid <- chainIdFromText ptid +-- p <- liftIO (try $ createTransactionOutputProof cdb tid cid bhe idx) >>= \case +-- Left e@SpvExceptionTargetNotReachable{} -> +-- toErr $ "SPV target not reachable: " <> _spvExceptionMsg e +-- Left e@SpvExceptionVerificationFailed{} -> +-- toErr $ "SPV verification failed: " <> _spvExceptionMsg e +-- Left e -> +-- toErr $ "Internal error: SPV verification failed: " <> _spvExceptionMsg e +-- Right q -> return q + +-- return $! b64 p +-- where +-- ph = Pact.unRequestKey rk +-- bdb = fromJuste $ preview (CutDB.cutDbBlockHeaderDb cid) cdb +-- b64 = TransactionOutputProofB64 +-- . encodeB64UrlNoPaddingText +-- . BSL8.toStrict +-- . Aeson.encode + +-- logg = logFunctionJson (setComponent "spv-handler" l) Info +-- . PactCmdLogSpv + +-- toErr e = throwError $ setErrText e err400 -- -------------------------------------------------------------------------- -- -- SPV2 Handler -spv2Handler - :: forall tbl l - . ( Logger l - , CanReadablePayloadCas tbl - ) - => l - -> CutDB.CutDb tbl - -- ^ CutDb contains the cut, payload, and block db - -> ChainId - -- ^ ChainId of the target - -> Spv2Request - -- ^ Contains the (pact) chain id of the target chain id used in the - -- 'target-chain' field of a cross-chain-transfer. - -- Also contains the request key of of the cross-chain transfer - -- tx request. - -> Handler SomePayloadProof -spv2Handler l cdb cid r = case _spvSubjectIdType sid of - SpvSubjectResult - | _spv2ReqAlgorithm r /= SpvSHA512t_256 -> - toErr $ "Algorithm " <> sshow r <> " is not supported with SPV result proofs." - | otherwise -> proof createOutputProofDb - SpvSubjectEvents - | cid /= _spvSubjectIdChain sid -> - toErr "Cross chain SPV proofs for are not supported for Pact events" - | otherwise -> case _spv2ReqAlgorithm r of - SpvSHA512t_256 -> proof createEventsProofDb - SpvKeccak_256 -> proof createEventsProofDbKeccak256 - where - proof - :: forall a - . MerkleHashAlgorithm a - => MerkleHashAlgorithmName a - => (BlockHeaderDb -> PayloadDb tbl -> Natural -> BlockHash -> Pact4.RequestKey -> IO (PayloadProof a)) - -> Handler SomePayloadProof - proof f = SomePayloadProof <$> do - validateRequestKey rk - liftIO $! logg (sshow ph) - T2 bhe bha <- liftIO (try $ _pactLookup pe cid Nothing (pure $ coerce ph)) >>= \case - Left (e :: PactException) -> - toErr $ "Internal error: transaction hash lookup failed: " <> sshow e - Right v -> case HM.lookup (coerce ph) v of - Nothing -> toErr $ "Transaction hash not found: " <> sshow ph - Just t -> return t - - let confDepth = fromMaybe (diameter (chainGraphAt cdb bhe)) $ _spv2ReqMinimalProofDepth r - - liftIO (tryAllSynchronous $ f bdb pdb confDepth bha rk) >>= \case - Left e -> toErr $ "SPV proof creation failed:" <> sshow e - Right q -> return q - - sid = _spv2ReqSubjectIdentifier r - - rk = _spvSubjectIdReqKey sid - pe = _webPactExecutionService $ view CutDB.cutDbPactService cdb - ph = Pact4.unRequestKey rk - bdb = fromJuste $ preview (CutDB.cutDbBlockHeaderDb cid) cdb - pdb = view CutDB.cutDbPayloadDb cdb - - logg = logFunctionJson (setComponent "spv-handler" l) Info - . PactCmdLogSpv - - toErr e = throwError $ err400 { errBody = e } - --- -------------------------------------------------------------------------- -- --- Eth SPV Handler - -ethSpvHandler - :: EthSpvRequest - -> Handler EthSpvResponse -ethSpvHandler req = do - - -- find block with transaction - (block, rest) <- case evalState start Nothing of - Left () -> toErr $ "the transaction " <> sshow tx <> " is not contained in any of the provided blocks" - Right x -> return x - - -- select and order set of receipts in the block - -- - -- How big can blocks be? Should we create an index instead? - -- - rcs <- forM (_rpcBlockTransactions block) $ \t -> do - case L.find (\r -> _rpcReceiptTransactionHash r == t) receipts of - Nothing -> toErr $ "missing receipt for tx " <> sshow t - Just x -> return x - - -- select and order set of extra headers and create proof - case rpcReceiptProof (_rpcBlockHeader block) (hdrs block rest) rcs (TransactionIndex 28) of - Left e -> toErr $ "failed to create proof: " <> sshow e - Right proof -> return $ EthSpvResponse $ - encodeB64UrlNoPaddingText (putRlpByteString proof) - - where - receipts = _ethSpvReqReceipts req - blocks = _ethSpvReqBlocks req - orderedBlocks = L.sortOn (_hdrNumber . _rpcBlockHeader) blocks - tx = _ethSpvReqTransactionHash req - - start = S.each orderedBlocks - & S.dropWhile (notElem tx . _rpcBlockTransactions) - & S.next - - -- filter sequence consecutive headers - hdrs block rest = flip evalState (Just $ _rpcBlockHash block) $ rest - & S.filterM (\b -> do - c <- get - if Just (bytes $ _hdrParentHash $ _rpcBlockHeader b) == (bytes <$> c) - then True <$ put (Just $ _rpcBlockHash b) - else return False - ) - & S.map _rpcBlockHeader - & S.toList_ - - toErr e = throwError $ err400 { errBody = e } +-- spv2Handler +-- :: forall tbl l +-- . Logger l +-- => CanReadablePayloadCas tbl +-- => l +-- -> CutDB.CutDb +-- -- ^ CutDb contains the cut, payload, and block db +-- -> PayloadDb tbl +-- -> PactLookup +-- -> ChainId +-- -- ^ ChainId of the target +-- -> Spv2Request +-- -- ^ Contains the (pact) chain id of the target chain id used in the +-- -- 'target-chain' field of a cross-chain-transfer. +-- -- Also contains the request key of of the cross-chain transfer +-- -- tx request. +-- -> Handler SomePayloadProof +-- spv2Handler l cdb pdb pactLookup cid r = case _spvSubjectIdType sid of +-- SpvSubjectResult +-- | _spv2ReqAlgorithm r /= SpvSHA512t_256 -> +-- toErr $ "Algorithm " <> sshow r <> " is not supported with SPV result proofs." +-- | otherwise -> proof createOutputProofDb +-- SpvSubjectEvents +-- | cid /= _spvSubjectIdChain sid -> +-- toErr "Cross chain SPV proofs for are not supported for Pact events" +-- | otherwise -> case _spv2ReqAlgorithm r of +-- SpvSHA512t_256 -> proof createEventsProofDb +-- SpvKeccak_256 -> proof createEventsProofDbKeccak256 +-- where +-- proof +-- :: forall a +-- . MerkleHashAlgorithm a +-- => MerkleHashAlgorithmName a +-- => (BlockHeaderDb -> PayloadDb tbl -> Natural -> BlockHash -> Pact.RequestKey -> IO (PayloadProof a)) +-- -> Handler SomePayloadProof +-- proof f = SomePayloadProof <$> do +-- liftIO $! logg (sshow ph) +-- T2 bhe bha <- liftIO (pactLookup Nothing (pure $ coerce ph)) >>= +-- -- Left (e :: PactException) -> +-- -- toErr $ "Internal error: transaction hash lookup failed: " <> sshow e +-- \v -> case HM.lookup (coerce ph) v of +-- Nothing -> toErr $ "Transaction hash not found: " <> sshow ph +-- Just t -> return t + +-- let confDepth = fromMaybe (diameter (chainGraphAt cdb bhe)) $ _spv2ReqMinimalProofDepth r + +-- liftIO (tryAllSynchronous $ f bdb pdb confDepth bha rk) >>= \case +-- Left e -> toErr $ "SPV proof creation failed:" <> sshow e +-- Right q -> return q + +-- sid = _spv2ReqSubjectIdentifier r + +-- rk = _spvSubjectIdReqKey sid +-- ph = Pact.unRequestKey rk +-- bdb = fromJuste $ preview (CutDB.cutDbBlockHeaderDb cid) cdb + +-- logg = logFunctionJson (setComponent "spv-handler" l) Info +-- . PactCmdLogSpv + +-- toErr e = throwError $ err400 { errBody = e } + +-- -- -------------------------------------------------------------------------- -- +-- -- Eth SPV Handler + +-- ethSpvHandler +-- :: EthSpvRequest +-- -> Handler EthSpvResponse +-- ethSpvHandler req = do + +-- -- find block with transaction +-- (block, rest) <- case evalState start Nothing of +-- Left () -> toErr $ "the transaction " <> sshow tx <> " is not contained in any of the provided blocks" +-- Right x -> return x + +-- -- select and order set of receipts in the block +-- -- +-- -- How big can blocks be? Should we create an index instead? +-- -- +-- rcs <- forM (_rpcBlockTransactions block) $ \t -> do +-- case L.find (\r -> _rpcReceiptTransactionHash r == t) receipts of +-- Nothing -> toErr $ "missing receipt for tx " <> sshow t +-- Just x -> return x + +-- -- select and order set of extra headers and create proof +-- case rpcReceiptProof (_rpcBlockHeader block) (hdrs block rest) rcs (TransactionIndex 28) of +-- Left e -> toErr $ "failed to create proof: " <> sshow e +-- Right proof -> return $ EthSpvResponse $ +-- encodeB64UrlNoPaddingText (putRlpByteString proof) + +-- where +-- receipts = _ethSpvReqReceipts req +-- blocks = _ethSpvReqBlocks req +-- orderedBlocks = L.sortOn (_hdrNumber . _rpcBlockHeader) blocks +-- tx = _ethSpvReqTransactionHash req + +-- start = S.each orderedBlocks +-- & S.dropWhile (notElem tx . _rpcBlockTransactions) +-- & S.next + +-- -- filter sequence consecutive headers +-- hdrs block rest = flip evalState (Just $ _rpcBlockHash block) $ rest +-- & S.filterM (\b -> do +-- c <- get +-- if Just (bytes $ _hdrParentHash $ _rpcBlockHeader b) == (bytes <$> c) +-- then True <$ put (Just $ _rpcBlockHash b) +-- else return False +-- ) +-- & S.map _rpcBlockHeader +-- & S.toList_ + +-- toErr e = throwError $ err400 { errBody = e } -- --------------------------------------------------------------------------- -- -- Poll Helper internalPoll :: (CanReadablePayloadCas tbl, Logger logger) + => HasVersion => logger - -> PayloadDb tbl - -> BlockHeaderDb - -> MempoolBackend Pact4.UnparsedTransaction - -> PactExecutionService + -> MempoolBackend Pact.Transaction + -> ServiceEnv tbl -> Maybe ConfirmationDepth - -> NonEmpty Pact5.RequestKey - -> IO (HashMap Pact5.RequestKey (Pact5.CommandResult Pact5.Hash Pact5.PactOnChainError)) -internalPoll logger pdb bhdb mempool pactEx confDepth requestKeys0 = do + -> NonEmpty Pact.RequestKey + -> IO (HashMap Pact.RequestKey (Pact.CommandResult Pact.Hash Pact.PactOnChainError)) +internalPoll logger mempool pact confDepth requestKeys0 = do let dbg txt = logFunctionText logger Debug txt -- get leaf block header for our chain from current best cut - results0 <- _pactLookup pactEx cid confDepth (coerce requestKeys) + results0 <- throwIfNoHistory =<< execLookupPactTxs logger pact confDepth (coerce requestKeys) + dbg $ "internalPoll.results0: " <> sshow results0 -- TODO: are we sure that all of these are raised locally. This will cause the -- server to shut down the connection without returning a result to the user. - let results1 = V.map (\rk -> (rk, HM.lookup (coerce $ Pact5.unRequestKey rk) results0)) requestKeysV + let results1 = V.map (\rk -> (rk, HM.lookup (coerce rk) results0)) requestKeysV let (present0, missing) = V.unstablePartition (isJust . snd) results1 let present = V.map (second fromJuste) present0 badlisted <- V.toList <$> checkBadList (V.map fst missing) @@ -633,78 +585,74 @@ internalPoll logger pdb bhdb mempool pactEx confDepth requestKeys0 = do logFunctionJson logger Warn errs return $! HM.fromList (good ++ badlisted) where - cid = _chainId bhdb !requestKeysV = V.fromList $ NEL.toList requestKeys0 - !requestKeys = V.map Pact5.unRequestKey requestKeysV + !requestKeys = V.map Pact.unRequestKey requestKeysV lookup - :: (Pact5.RequestKey, T2 BlockHeight BlockHash) - -> IO (Either String (Maybe (Pact5.RequestKey, Pact5.CommandResult Pact5.Hash Pact5.PactOnChainError))) - lookup (key, T2 _ ha) = (fmap . fmap . fmap) (key,) $ lookupRequestKey key ha + :: (Pact.RequestKey, T3 BlockHeight BlockPayloadHash BlockHash) + -> IO (Either String (Maybe (Pact.RequestKey, Pact.CommandResult Pact.Hash Pact.PactOnChainError))) + lookup (key, T3 bh bph bhsh) = (fmap . fmap . fmap) (key,) $ lookupRequestKey key bph bhsh bh -- TODO: group by block for performance (not very important right now) lookupRequestKey - :: Pact5.RequestKey + :: Pact.RequestKey + -> BlockPayloadHash -> BlockHash - -> IO (Either String (Maybe (Pact5.CommandResult Pact5.Hash Pact5.PactOnChainError))) - lookupRequestKey key bHash = runExceptT $ do - let pactHash = Pact5.unRequestKey key - let matchingHash = (== pactHash) . Pact5._cmdHash . fst - blockHeader <- liftIO (TreeDB.lookup bhdb bHash) >>= \case - Nothing -> throwError $ "missing block header: " <> sshow key - Just x -> return x - - let payloadHash = view blockPayloadHash blockHeader + -> BlockHeight + -> IO (Either String (Maybe (Pact.CommandResult Pact.Hash Pact.PactOnChainError))) + lookupRequestKey key payloadHash bHash height = runExceptT $ do + let pactHash = Pact.unRequestKey key + let matchingHash = (== pactHash) . Pact._cmdHash . fst + let pdb = _payloadStoreTable (_psPdb pact) + (_payloadWithOutputsTransactions -> txsBs) <- barf - ("payload lookup failed: " <> T.unpack (blockHeaderShortDescription blockHeader) - <> " w/ payload hash " <> sshow (view blockPayloadHash blockHeader)) - =<< liftIO (lookupPayloadWithHeight pdb (Just $ view blockHeight blockHeader) payloadHash) + ("payload lookup failed w/ payload hash: " <> sshow payloadHash) + =<< liftIO (lookupPayloadWithHeight pdb (Just height) payloadHash) !txs <- mapM fromTx txsBs case find matchingHash txs of Just (_cmd, TransactionOutput output) -> do out <- case eitherDecodeStrict' output of Left err -> throwError $ - "error decoding tx output for command " <> sshow (Pact5._cmdHash _cmd) <> ": " <> err + "error decoding tx output for command " <> sshow (Pact._cmdHash _cmd) <> ": " <> err Right decodedOutput -> return decodedOutput - when (Pact5._crReqKey out /= key) $ + when (Pact._crReqKey out /= key) $ throwError "internal error: Transaction output doesn't match its hash!" - return $ Just $ enrichCR blockHeader out + return $ Just $ enrichCR payloadHash bHash height out Nothing -> return Nothing - fromTx :: (Transaction, TransactionOutput) -> ExceptT String IO (Pact5.Command Text, TransactionOutput) + fromTx :: (Transaction, TransactionOutput) -> ExceptT String IO (Pact.Command Text, TransactionOutput) fromTx (Transaction txBytes, !out) = do !tx' <- except $ eitherDecodeStrict' txBytes & _Left %~ (\decodeErr -> "Transaction failed to decode: " <> decodeErr) return (tx', out) - checkBadList :: Vector Pact5.RequestKey -> IO (Vector (Pact5.RequestKey, Pact5.CommandResult Pact5.Hash Pact5.PactOnChainError)) + checkBadList :: Vector Pact.RequestKey -> IO (Vector (Pact.RequestKey, Pact.CommandResult Pact.Hash Pact.PactOnChainError)) checkBadList rkeys = do - let !hashes = V.map pact5RequestKeyToTransactionHash rkeys + let !hashes = V.map pactRequestKeyToTransactionHash rkeys out <- mempoolCheckBadList mempool hashes - let bad = V.map (Pact5.RequestKey . Pact5.Hash . unTransactionHash . fst) $ + let bad = V.map (Pact.RequestKey . Pact.Hash . unTransactionHash . fst) $ V.filter snd $ V.zip hashes out return $! V.map hashIsOnBadList bad - hashIsOnBadList :: Pact5.RequestKey -> (Pact5.RequestKey, Pact5.CommandResult Pact5.Hash Pact5.PactOnChainError) + hashIsOnBadList :: Pact.RequestKey -> (Pact.RequestKey, Pact.CommandResult Pact.Hash Pact.PactOnChainError) hashIsOnBadList rk = - let res = Pact5.PactResultErr err - err = Pact5.PactOnChainError + let res = Pact.PactResultErr err + err = Pact.PactOnChainError -- the only legal error type, once chainweaver is really gone, we -- can use a real error type - (Pact5.ErrorType "TxFailure") - (Pact5.mkBoundedText "Transaction is badlisted because it previously failed to validate.") - (Pact5.LocatedErrorInfo Pact5.TopLevelErrorOrigin Pact5.noInfo) - !cr = Pact5.CommandResult rk Nothing res (mempty :: Pact5.Gas) Nothing Nothing Nothing [] + (Pact.ErrorType "EvalError") + (Pact.mkBoundedText "Transaction is badlisted because it previously failed to validate.") + (Pact.LocatedErrorInfo Pact.TopLevelErrorOrigin Pact.noInfo) + !cr = Pact.CommandResult rk Nothing res (mempty :: Pact.Gas) Nothing Nothing Nothing [] in (rk, cr) - enrichCR :: BlockHeader -> Pact5.CommandResult i e -> Pact5.CommandResult i e - enrichCR bh = set Pact5.crMetaData + enrichCR :: BlockPayloadHash -> BlockHash -> BlockHeight -> Pact.CommandResult i e -> Pact.CommandResult i e + enrichCR bph bhsh bh = set Pact.crMetaData (Just $ object - [ "blockHeight" .= view blockHeight bh - , "blockTime" .= view blockCreationTime bh - , "blockHash" .= view blockHash bh - , "prevBlockHash" .= view blockParent bh + [ "blockHeight" .= bh + , "blockHash" .= bhsh + , "blockPayloadHash" .= bph ]) -- -------------------------------------------------------------------------- -- @@ -715,51 +663,12 @@ barf e = maybe (throwError e) return -- TODO: all of the functions in this module can instead grab the current block height from consensus -- and pass it here to get a better estimate of what behavior is correct. -validateCommand :: ChainwebVersion -> ChainId -> Pact4.Command Text -> Either Text Pact4.Transaction -validateCommand v cid (fmap encodeUtf8 -> cmdBs) = case parsedCmd of - Right (commandParsed :: Pact4.Transaction) -> - case Pact4.assertCommand commandParsed (validPPKSchemes v cid bh) (isWebAuthnPrefixLegal v cid bh) of - Left err -> Left $ "Command failed validation: " <> Pact4.displayAssertCommandError err - Right () -> Right commandParsed - Left e -> Left $ "Pact parsing error: " <> T.pack e - where - bh = maxBound :: BlockHeight - decodeAndParse bs = - traverse (Pact4.parsePact) =<< Aeson.eitherDecodeStrict' bs - parsedCmd = Pact4.mkPayloadWithText <$> - Pact4.cmdPayload (\bs -> (bs,) <$> decodeAndParse bs) cmdBs - --- TODO: all of the functions in this module can instead grab the current block height from consensus --- and pass it here to get a better estimate of what behavior is correct. -validatePact5Command :: ChainwebVersion -> Pact5.Command Text -> Either String Pact5.Transaction -validatePact5Command _v cmdText = case parsedCmd of - Right (commandParsed :: Pact5.Transaction) -> - if isRight (Pact5.assertCommand commandParsed) +validateCommand :: HasVersion => Pact.Command Text -> Either String Pact.Transaction +validateCommand cmdText = case parsedCmd of + Right (commandParsed :: Pact.Transaction) -> + if isRight (Pact.assertCommand commandParsed) then Right commandParsed else Left "Command failed validation" - Left e -> Left $ "Pact parsing error: " ++ Pact5.renderCompactString e - where - parsedCmd = Pact5.parseCommand cmdText - --- | Validate the length of the request key's underlying hash. --- -validateRequestKey :: Pact4.RequestKey -> Handler () -validateRequestKey (Pact4.RequestKey h'@(Pact4.Hash h)) - | keyLength == blakeHashLength = return () - | otherwise = throwError $ setErrText - ( "Request Key " - <> Pact4.hashToText h' - <> " has incorrect hash of length " - <> sshow keyLength - ) err400 + Left e -> Left $ "Pact parsing error: " ++ Pact.renderCompactString e where - -- length of the encoded request key hash - -- - keyLength = SB.length h - - -- Blake hash length = 32 - the length of a - -- Blake2b_256 hash - -- - blakeHashLength :: Int - blakeHashLength = Pact4.hashLength Pact4.Blake2b_256 -{-# INLINE validateRequestKey #-} + parsedCmd = Pact.parseCommand cmdText diff --git a/src/Chainweb/Pact5/SPV.hs b/src/Chainweb/Pact/SPV.hs similarity index 65% rename from src/Chainweb/Pact5/SPV.hs rename to src/Chainweb/Pact/SPV.hs index f921cecfae..c232137426 100644 --- a/src/Chainweb/Pact5/SPV.hs +++ b/src/Chainweb/Pact/SPV.hs @@ -2,27 +2,17 @@ ImportQualifiedPost , LambdaCase , OverloadedStrings + , OverloadedRecordDot , ScopedTypeVariables , TypeApplications #-} +{-# LANGUAGE FlexibleContexts #-} -module Chainweb.Pact5.SPV (pactSPV) where +module Chainweb.Pact.SPV (pactSPV) where -import Chainweb.BlockHeader (BlockHeader, blockHeight) -import Chainweb.BlockHeaderDB (BlockHeaderDb) -import Chainweb.BlockHeaderDB.HeaderOracle qualified as Oracle -import Chainweb.Payload (TransactionOutput(..)) -import Chainweb.SPV (SpvException(..), TransactionOutputProof(..), outputProofChainId) -import Chainweb.SPV.VerifyProof (verifyTransactionOutputProof) -import Chainweb.Utils (decodeB64UrlNoPaddingText) -import Chainweb.Version qualified as CW -import Chainweb.Version.Guards qualified as CW import Control.Lens import Control.Monad (when) -import Control.Monad.Catch (catch, throwM) -import Control.Monad.Except (ExceptT, runExceptT, throwError) -import Control.Monad.IO.Class (liftIO) -import Crypto.Hash.Algorithms (SHA512t_256) +import Control.Monad.Except (runExceptT, throwError) import Data.Aeson qualified as Aeson import Data.Text (Text) import Data.Text.Encoding qualified as Text @@ -30,31 +20,36 @@ import Pact.Core.Command.Types (CommandResult(..), PactResult(..)) import Pact.Core.DefPacts.Types (DefPactExec(..)) import Pact.Core.Hash (Hash(..)) import Pact.Core.PactValue (ObjectData(..), PactValue(..)) -import Pact.Core.SPV (ContProof(..), SPVSupport(..)) +import Pact.Core.SPV (SPVSupport(..), ContProof (..)) import Pact.Core.StableEncoding (encodeStable) -pactSPV :: BlockHeaderDb -> BlockHeader -> SPVSupport -pactSPV bdb bh = SPVSupport - { _spvSupport = \proofType proof -> verifySPV bdb bh proofType proof - , _spvVerifyContinuation = \contProof -> verifyCont bdb bh contProof +import Chainweb.MerkleUniverse +import Chainweb.Pact.Backend.Types +import Chainweb.Pact.Payload(TransactionOutput(..)) +import Chainweb.SPV (TransactionOutputProof(..), outputProofChainId) +import Chainweb.SPV.VerifyProof (checkProofAndExtractOutput) +import Chainweb.Utils (decodeB64UrlNoPaddingText) +import Chainweb.Version qualified as CW + +pactSPV :: HeaderOracle -> SPVSupport +pactSPV oracle = SPVSupport + { _spvSupport = \proofType proof -> verifySPV oracle proofType proof + , _spvVerifyContinuation = \contProof -> verifyCont oracle contProof } -- | Attempt to verify an SPV proof of a continuation given -- a continuation payload object bytestring. On success, returns -- the 'DefPactExec' associated with the proof. verifyCont :: () - => BlockHeaderDb - -> BlockHeader + => HeaderOracle -> ContProof -> IO (Either Text DefPactExec) -verifyCont bdb bh (ContProof base64Proof) = runExceptT $ do - oracle <- liftIO $ Oracle.createSpv bdb bh - +verifyCont bdb (ContProof base64Proof) = runExceptT $ do proofBytes <- case decodeB64UrlNoPaddingText (Text.decodeUtf8 base64Proof) of Left _ -> throwError "verifyCont: Invalid base64-encoded transaction output proof" Right bs -> return bs - outputProof <- case Aeson.decodeStrict' @(TransactionOutputProof SHA512t_256) proofBytes of + outputProof <- case Aeson.decodeStrict' @(TransactionOutputProof ChainwebMerkleHashAlgorithm) proofBytes of Nothing -> throwError "verifyCont: Cannot decode transaction output proof" Just u -> return u @@ -67,7 +62,7 @@ verifyCont bdb bh (ContProof base64Proof) = runExceptT $ do -- 1. Verify SPV TransactionOutput proof via Chainweb SPV API -- 2. Decode tx outputs to 'CommandResult' 'Hash' _ -- 3. Extract continuation 'DefPactExec' from decoded result and return the cont exec object - TransactionOutput proof <- catchAndDisplaySPVError bh $ liftIO $ verifyTransactionOutputProof oracle outputProof + TransactionOutput proof <- checkProofAndExtractOutput bdb outputProof -- TODO: Do we care about the error type here? commandResult <- case Aeson.decodeStrict' @(CommandResult Hash Aeson.Value) proof of @@ -79,25 +74,20 @@ verifyCont bdb bh (ContProof base64Proof) = runExceptT $ do Just defpactExec -> return defpactExec verifySPV :: () - => BlockHeaderDb - -> BlockHeader + => HeaderOracle -> Text -- ^ ETH or TXOUT - defines the type of proof used in validation -> ObjectData PactValue -> IO (Either Text (ObjectData PactValue)) -verifySPV bdb bh proofType proof = runExceptT $ do - let cid = CW._chainId bdb - +verifySPV oracle proofType proof = runExceptT $ do case proofType of "ETH" -> do - throwError "verifySPV: ETH proof type is not yet supported in Pact5." + throwError "verifySPV: ETH proof type is not yet supported in Pact." "TXOUT" -> do - oracle <- liftIO $ Oracle.createSpv bdb bh - outputProof <- case pactObjectOutputProof proof of Left err -> throwError err Right u -> return u - when (view outputProofChainId outputProof /= cid) $ + when (view outputProofChainId outputProof /= oracle.chain) $ throwError "verifySPV: cannot redeem spv proof on wrong target chain" -- SPV proof verification is a 3-step process: @@ -105,7 +95,8 @@ verifySPV bdb bh proofType proof = runExceptT $ do -- 2. Decode tx outputs to 'CommandResult' 'Hash' _ -- 3. Extract tx outputs as a pact object and return the object - TransactionOutput rawCommandResult <- catchAndDisplaySPVError bh $ liftIO $ verifyTransactionOutputProof oracle outputProof + TransactionOutput rawCommandResult <- + checkProofAndExtractOutput oracle outputProof commandResult <- case Aeson.decodeStrict' @(CommandResult Hash Aeson.Value) rawCommandResult of Nothing -> throwError "verifySPV: Unable to decode SPV transaction output" @@ -123,16 +114,8 @@ verifySPV bdb bh proofType proof = runExceptT $ do _ -> do throwError $ "Unsupported SPV type: " <> proofType -pactObjectOutputProof :: ObjectData PactValue -> Either Text (TransactionOutputProof SHA512t_256) +pactObjectOutputProof :: ObjectData PactValue -> Either Text (TransactionOutputProof ChainwebMerkleHashAlgorithm) pactObjectOutputProof (ObjectData o) = do - case Aeson.decodeStrict' @(TransactionOutputProof SHA512t_256) $ encodeStable o of + case Aeson.decodeStrict' @(TransactionOutputProof ChainwebMerkleHashAlgorithm) $ encodeStable o of Nothing -> Left "pactObjectOutputProof: Failed to decode proof object" Just outputProof -> Right outputProof - -catchAndDisplaySPVError :: BlockHeader -> ExceptT Text IO a -> ExceptT Text IO a -catchAndDisplaySPVError bh eio = - if CW.chainweb219Pact (CW._chainwebVersion bh) (CW._chainId bh) (view blockHeight bh) - then catch eio $ \case - SpvExceptionVerificationFailed m -> throwError ("spv verification failed: " <> m) - spvErr -> throwM spvErr - else eio diff --git a/src/Chainweb/Pact/Service/BlockValidation.hs b/src/Chainweb/Pact/Service/BlockValidation.hs deleted file mode 100644 index 9137e762f1..0000000000 --- a/src/Chainweb/Pact/Service/BlockValidation.hs +++ /dev/null @@ -1,158 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} - --- | --- Module : Chainweb.Pact.Service.BlockValidation --- Copyright : Copyright © 2018 Kadena LLC. --- License : (see the file LICENSE) --- Maintainer : Emily Pillmore --- Stability : experimental --- --- The block validation logic for Pact Service --- --- This exists due to moving things around resolving --- chainweb dependencies. This should find a new home. --- -module Chainweb.Pact.Service.BlockValidation -( validateBlock -, newBlock -, continueBlock -, local -, lookupPactTxs -, pactPreInsertCheck -, pactBlockTxHistory -, pactHistoricalLookup -, pactSyncToBlock -, pactReadOnlyReplay -) where - - -import Data.Vector (Vector) -import Data.HashMap.Strict (HashMap) - -import qualified Pact.Core.Persistence as Pact5 - -import Chainweb.BlockHash -import Chainweb.BlockHeader -import Chainweb.BlockHeight -import Chainweb.Mempool.Mempool (InsertError) -import Chainweb.Miner.Pact -import Chainweb.Pact.Service.PactQueue -import Chainweb.Pact.Types -import Chainweb.Payload -import qualified Chainweb.Pact4.Transaction as Pact4 -import Chainweb.Utils -import Chainweb.Version -import Data.ByteString.Short (ShortByteString) -import qualified Pact.Core.Names as Pact5 -import qualified Pact.Core.Builtin as Pact5 -import qualified Pact.Core.Evaluate as Pact5 -import qualified Pact.Types.ChainMeta as Pact4 -import Data.Text (Text) -import qualified Pact.Types.Command as Pact4 - -newBlock :: Miner -> NewBlockFill -> ParentHeader -> PactQueue -> IO (Historical (ForSomePactVersion BlockInProgress)) -newBlock mi fill parent reqQ = do - let - !msg = NewBlockMsg NewBlockReq - { _newBlockMiner = mi - , _newBlockFill = fill - , _newBlockParent = parent - } - submitRequestAndWait reqQ msg - -continueBlock :: BlockInProgress pv -> PactQueue -> IO (Historical (BlockInProgress pv)) -continueBlock bip reqQ = do - let !msg = ContinueBlockMsg (ContinueBlockReq bip) - submitRequestAndWait reqQ msg - -validateBlock - :: BlockHeader - -> CheckablePayload - -> PactQueue - -> IO PayloadWithOutputs -validateBlock bHeader payload reqQ = do - let !msg = ValidateBlockMsg ValidateBlockReq - { _valBlockHeader = bHeader - , _valCheckablePayload = payload - } - submitRequestAndWait reqQ msg - -local - :: Maybe LocalPreflightSimulation - -> Maybe LocalSignatureVerification - -> Maybe RewindDepth - -> Pact4.UnparsedTransaction - -> PactQueue - -> IO LocalResult -local preflight sigVerify rd ct reqQ = do - let !msg = LocalMsg LocalReq - { _localRequest = ct - , _localPreflight = preflight - , _localSigVerification = sigVerify - , _localRewindDepth = rd - } - submitRequestAndWait reqQ msg - -lookupPactTxs - :: Maybe ConfirmationDepth - -> Vector ShortByteString - -> PactQueue - -> IO (HashMap ShortByteString (T2 BlockHeight BlockHash)) -lookupPactTxs confDepth txs reqQ = do - let !req = LookupPactTxsReq confDepth txs - let !msg = LookupPactTxsMsg req - submitRequestAndWait reqQ msg - -pactReadOnlyReplay - :: BlockHeader - -> Maybe BlockHeader - -> PactQueue - -> IO () -pactReadOnlyReplay l u reqQ = do - let !msg = ReadOnlyReplayMsg ReadOnlyReplayReq - { _readOnlyReplayLowerBound = l - , _readOnlyReplayUpperBound = u - } - submitRequestAndWait reqQ msg - -pactPreInsertCheck - :: Vector (Pact4.Command (Pact4.PayloadWithText Pact4.PublicMeta Text)) - -> PactQueue - -> IO (Vector (Maybe InsertError)) -pactPreInsertCheck txs reqQ = do - let !req = PreInsertCheckReq txs - let !msg = PreInsertCheckMsg req - submitRequestAndWait reqQ msg - -pactBlockTxHistory - :: BlockHeader - -> Pact5.Domain Pact5.RowKey Pact5.RowData Pact5.CoreBuiltin Pact5.Info - -> PactQueue - -> IO (Historical BlockTxHistory) -pactBlockTxHistory bh d reqQ = do - let !req = BlockTxHistoryReq bh d - let !msg = BlockTxHistoryMsg req - submitRequestAndWait reqQ msg - -pactHistoricalLookup - :: BlockHeader - -> Pact5.Domain Pact5.RowKey Pact5.RowData Pact5.CoreBuiltin Pact5.Info - -> Pact5.RowKey - -> PactQueue - -> IO (Historical (Maybe (Pact5.TxLog Pact5.RowData))) -pactHistoricalLookup bh d k reqQ = do - let !req = HistoricalLookupReq bh d k - let !msg = HistoricalLookupMsg req - submitRequestAndWait reqQ msg - -pactSyncToBlock - :: BlockHeader - -> PactQueue - -> IO () -pactSyncToBlock bh reqQ = do - let !msg = SyncToBlockMsg SyncToBlockReq - { _syncToBlockHeader = bh - } - submitRequestAndWait reqQ msg diff --git a/src/Chainweb/Pact/Service/PactInProcApi.hs b/src/Chainweb/Pact/Service/PactInProcApi.hs deleted file mode 100644 index 490b3e5fa9..0000000000 --- a/src/Chainweb/Pact/Service/PactInProcApi.hs +++ /dev/null @@ -1,176 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE NumericUnderscores #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeApplications #-} - --- | --- Module: Chainweb.Pact.Service.PactInProcApi --- Copyright: Copyright © 2018 Kadena LLC. --- License: See LICENSE file --- Maintainer: Mark Nichols --- Stability: experimental --- --- Pact execution (in-process) API for Chainweb - -module Chainweb.Pact.Service.PactInProcApi - ( withPactService - , withPactService' - , pactMemPoolAccess - ) where - -import Control.Concurrent.Async - -import Data.IORef -import Data.Vector (Vector) - -import System.LogLevel - -import Chainweb.BlockHash -import Chainweb.BlockHeader -import Chainweb.BlockHeaderDB -import Chainweb.BlockHeight -import Chainweb.ChainId -import Chainweb.Logger -import Chainweb.Mempool.Consensus -import Chainweb.Mempool.Mempool - -import Chainweb.Pact.Backend.Utils -import Chainweb.Pact.Types -import qualified Chainweb.Pact.PactService as PS -import Chainweb.Pact.Service.PactQueue -import Chainweb.Payload.PayloadStore -import qualified Chainweb.Pact4.Transaction as Pact4 -import Chainweb.Utils -import Chainweb.Version - -import Data.LogMessage - -import GHC.Stack (HasCallStack) -import Chainweb.Counter (Counter) -import Chainweb.BlockCreationTime -import Chainweb.Pact.Backend.Types - --- | Initialization for Pact (in process) Api -withPactService - :: CanReadablePayloadCas tbl - => Logger logger - => ChainwebVersion - -> ChainId - -> logger - -> Maybe (Counter "txFailures") - -> MempoolConsensus - -> BlockHeaderDb - -> PayloadDb tbl - -> FilePath - -> PactServiceConfig - -> (PactQueue -> IO a) - -> IO a -withPactService ver cid logger txFailuresCounter mpc bhdb pdb pactDbDir config action = - withSqliteDb cid logger pactDbDir (_pactResetDb config) $ \sqlenv -> - withPactService' ver cid logger txFailuresCounter mpa bhdb pdb sqlenv config action - where - mpa = pactMemPoolAccess mpc $ addLabel ("sub-component", "MempoolAccess") logger - --- | Alternate Initialization for Pact (in process) Api, only used directly in --- tests to provide memPool with test transactions -withPactService' - :: CanReadablePayloadCas tbl - => Logger logger - => HasCallStack - => ChainwebVersion - -> ChainId - -> logger - -> Maybe (Counter "txFailures") - -> MemPoolAccess - -> BlockHeaderDb - -> PayloadDb tbl - -> SQLiteEnv - -> PactServiceConfig - -> (PactQueue -> IO a) - -> IO a -withPactService' ver cid logger txFailuresCounter memPoolAccess bhDb pdb sqlenv config action = do - reqQ <- newPactQueue (_pactQueueSize config) - race (concurrently_ (monitor reqQ) (server reqQ)) (action reqQ) >>= \case - Left () -> error "Chainweb.Pact.Service.PactInProcApi: pact service terminated unexpectedly" - Right a -> return a - where - server reqQ = runForever logg "pact-service" - $ PS.runPactService ver cid logger txFailuresCounter reqQ memPoolAccess bhDb pdb sqlenv config - logg = logFunction logger - monitor = runPactServiceQueueMonitor $ addLabel ("sub-component", "PactQueue") logger - -runPactServiceQueueMonitor :: Logger logger => logger -> PactQueue -> IO () -runPactServiceQueueMonitor l pq = do - let lf = logFunction l - runForeverThrottled lf "Chainweb.Pact.Service.PactInProcApi.runPactServiceQueueMonitor" 10 (10 * mega) $ do - queueStats <- getPactQueueStats pq - logFunctionText l Debug "got latest set of stats from PactQueueMonitor" - logFunctionJson l Info queueStats - resetPactQueueStats pq - approximateThreadDelay 60_000_000 {- 1 minute -} - -pactMemPoolAccess - :: Logger logger - => MempoolConsensus - -> logger - -> MemPoolAccess -pactMemPoolAccess mpc logger = MemPoolAccess - { mpaGetBlock = pactMemPoolGetBlock mpc logger - , mpaSetLastHeader = pactMempoolSetLastHeader mpc logger - , mpaProcessFork = pactProcessFork mpc logger - , mpaBadlistTx = mempoolAddToBadList (mpcMempool mpc) - } - -pactMemPoolGetBlock - :: Logger logger - => MempoolConsensus - -> logger - -> BlockFill - -> (MempoolPreBlockCheck Pact4.UnparsedTransaction to - -> BlockHeight - -> BlockHash - -> BlockCreationTime - -> IO (Vector to)) -pactMemPoolGetBlock mpc theLogger bf validate height hash _btime = do - logFn theLogger Debug $! "pactMemPoolAccess - getting new block of transactions for " - <> "height = " <> sshow height <> ", hash = " <> sshow hash - mempoolGetBlock (mpcMempool mpc) bf validate height hash - where - logFn :: Logger l => l -> LogFunctionText -- just for giving GHC some type hints - logFn l = logFunction l - - -pactProcessFork - :: Logger logger - => MempoolConsensus - -> logger - -> (BlockHeader -> IO ()) -pactProcessFork mpc theLogger bHeader = do - let forkFunc = (mpcProcessFork mpc) (logFunction theLogger) - (reintroTxs, validatedTxs) <- forkFunc bHeader - logFn theLogger Debug $! - "pactMemPoolAccess - " <> sshow (length reintroTxs) <> " transactions to reintroduce" - -- No need to run pre-insert check here -- we know these are ok, and - -- calling the pre-check would block here (it calls back into pact service) - mempoolInsert (mpcMempool mpc) UncheckedInsert reintroTxs - mempoolMarkValidated (mpcMempool mpc) validatedTxs - - where - logFn :: Logger l => l -> LogFunctionText - logFn lg = logFunction lg - -pactMempoolSetLastHeader - :: Logger logger - => MempoolConsensus - -> logger - -> (BlockHeader -> IO ()) -pactMempoolSetLastHeader mpc _theLogger bHeader = do - let headerRef = mpcLastNewBlockParent mpc - atomicWriteIORef headerRef (Just bHeader) diff --git a/src/Chainweb/Pact/Service/PactQueue.hs b/src/Chainweb/Pact/Service/PactQueue.hs deleted file mode 100644 index a489973d6e..0000000000 --- a/src/Chainweb/Pact/Service/PactQueue.hs +++ /dev/null @@ -1,240 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE ViewPatterns #-} - --- | --- Module: Chainweb.Pact.Service.PactQueue --- Copyright: Copyright © 2022 Kadena LLC. --- License: See LICENSE file --- Maintainer: Mark Nichols --- Stability: experimental --- --- Pact execution service queue for Chainweb --- -module Chainweb.Pact.Service.PactQueue -( addRequest -, cancelSubmittedRequest -, waitForSubmittedRequest -, submitRequestAnd -, submitRequestAndWait -, getNextRequest -, getPactQueueStats -, newPactQueue -, resetPactQueueStats -, PactQueue -, PactQueueStats(..) -) where - -import Control.Applicative -import Control.Concurrent.Async -import Control.Concurrent.STM -import Control.DeepSeq (NFData) -import Control.Exception.Safe -import Control.Monad - -import Data.Aeson -import Data.IORef - -import GHC.Generics - -import Numeric.Natural - --- internal modules - -import Chainweb.Pact.Types -import Chainweb.Time -import Chainweb.Utils - --- -------------------------------------------------------------------------- -- --- Pact Queue - --- | A Pact Queue with different priorities for block validation, new block, and --- other requests. --- -data PactQueue = PactQueue - { _pactQueueValidateBlock :: !(TBQueue (T2 SubmittedRequestMsg (Time Micros))) - , _pactQueueNewBlock :: !(TBQueue (T2 SubmittedRequestMsg (Time Micros))) - , _pactQueueOtherMsg :: !(TBQueue (T2 SubmittedRequestMsg (Time Micros))) - , _pactQueuePactQueueValidateBlockMsgCounters :: !(IORef PactQueueCounters) - , _pactQueuePactQueueNewBlockMsgCounters :: !(IORef PactQueueCounters) - , _pactQueuePactQueueOtherMsgCounters :: !(IORef PactQueueCounters) - } - -initPactQueueCounters :: PactQueueCounters -initPactQueueCounters = PactQueueCounters - { _pactQueueCountersCount = 0 - , _pactQueueCountersSum = 0 - , _pactQueueCountersMin = maxBound - , _pactQueueCountersMax = 0 - } - -newPactQueue :: Natural -> IO PactQueue -newPactQueue sz = PactQueue - <$> newTBQueueIO sz - <*> newTBQueueIO sz - <*> newTBQueueIO sz - <*> newIORef initPactQueueCounters - <*> newIORef initPactQueueCounters - <*> newIORef initPactQueueCounters - --- | Add a request to the Pact execution queue --- -addRequest :: PactQueue -> RequestMsg r -> IO (TVar (RequestStatus r)) -addRequest q msg = do - statusRef <- newTVarIO RequestNotStarted - let submittedReq = SubmittedRequestMsg msg statusRef - entranceTime <- getCurrentTimeIntegral - atomically $ writeTBQueue priority (T2 submittedReq entranceTime) - return statusRef - where - priority = case msg of - ValidateBlockMsg {} -> _pactQueueValidateBlock q - NewBlockMsg {} -> _pactQueueNewBlock q - _ -> _pactQueueOtherMsg q - --- | Cancel a request that's already been submitted to the Pact queue. --- -cancelSubmittedRequest :: TVar (RequestStatus r) -> IO () -cancelSubmittedRequest statusRef = atomically $ do - status <- readTVar statusRef - case status of - RequestFailed _ -> return () - RequestInProgress -> writeTVar statusRef (RequestFailed (toException AsyncCancelled)) - RequestDone _ -> return () - RequestNotStarted -> writeTVar statusRef (RequestFailed (toException AsyncCancelled)) - --- | Block waiting for the result of a request that's already been submitted --- to the Pact queue. --- -waitForSubmittedRequest :: TVar (RequestStatus r) -> IO r -waitForSubmittedRequest statusRef = atomically $ do - status <- readTVar statusRef - case status of - RequestFailed e -> throwIO e - RequestInProgress -> retry - RequestDone r -> return r - RequestNotStarted -> retry - --- | Submit a request and give a handle on its status to the continuation. --- When the continuation terminates, *cancel the request*. --- -submitRequestAnd :: PactQueue -> RequestMsg r -> (TVar (RequestStatus r) -> IO a) -> IO a -submitRequestAnd q msg k = uninterruptibleMask $ \restore -> do - status <- addRequest q msg - restore (k status) `onException` - uninterruptibleMask_ (cancelSubmittedRequest status) - --- | Submit a request and wait for it to finish; if interrupted by an --- asynchronous exception, *cancel the request*. --- -submitRequestAndWait :: PactQueue -> RequestMsg r -> IO r -submitRequestAndWait q msg = submitRequestAnd q msg waitForSubmittedRequest - --- | Get the next available request from the Pact execution queue --- -getNextRequest :: PactQueue -> IO SubmittedRequestMsg -getNextRequest q = do - T2 req entranceTime <- atomically - $ tryReadTBQueueOrRetry (_pactQueueValidateBlock q) - <|> tryReadTBQueueOrRetry (_pactQueueNewBlock q) - <|> tryReadTBQueueOrRetry (_pactQueueOtherMsg q) - requestTime <- diff <$> getCurrentTimeIntegral <*> pure entranceTime - updatePactQueueCounters (counters req q) requestTime - return req - where - tryReadTBQueueOrRetry = tryReadTBQueue >=> \case - Nothing -> retry - Just msg -> return msg - - counters (SubmittedRequestMsg ValidateBlockMsg{} _) = _pactQueuePactQueueValidateBlockMsgCounters - counters (SubmittedRequestMsg NewBlockMsg{} _) = _pactQueuePactQueueNewBlockMsgCounters - counters _ = _pactQueuePactQueueOtherMsgCounters - --- -------------------------------------------------------------------------- -- --- Pact Queue Telemetry - --- | Counters for one Pact queue priority --- -data PactQueueCounters = PactQueueCounters - { _pactQueueCountersCount :: {-# UNPACK #-} !Int - , _pactQueueCountersSum :: {-# UNPACK #-} !Micros - , _pactQueueCountersMin :: {-# UNPACK #-} !Micros - , _pactQueueCountersMax :: {-# UNPACK #-} !Micros - } - deriving (Show, Generic) - deriving anyclass NFData - -instance ToJSON PactQueueCounters where - toJSON = object . pactQueueCountersProperties - toEncoding = pairs . mconcat . pactQueueCountersProperties - {-# INLINE toJSON #-} - {-# INLINE toEncoding #-} - -pactQueueCountersProperties :: KeyValue e kv => PactQueueCounters -> [kv] -pactQueueCountersProperties pqc = - [ "count" .= _pactQueueCountersCount pqc - , "sum" .= _pactQueueCountersSum pqc - , "min" .= _pactQueueCountersMin pqc - , "max" .= _pactQueueCountersMax pqc - , "avg" .= avg - ] - where - avg :: Maybe Double - avg = if _pactQueueCountersCount pqc == 0 - then Nothing - else Just $ fromIntegral (_pactQueueCountersSum pqc) / fromIntegral (_pactQueueCountersCount pqc) -{-# INLINE pactQueueCountersProperties #-} - -updatePactQueueCounters :: IORef PactQueueCounters -> TimeSpan Micros -> IO () -updatePactQueueCounters countersRef (timeSpanToMicros -> timespan) = do - atomicModifyIORef' countersRef $ \ctrs -> - ( PactQueueCounters - { _pactQueueCountersCount = _pactQueueCountersCount ctrs + 1 - , _pactQueueCountersSum = _pactQueueCountersSum ctrs + timespan - , _pactQueueCountersMin = _pactQueueCountersMin ctrs `min` timespan - , _pactQueueCountersMax = _pactQueueCountersMax ctrs `max` timespan - } - , () - ) - --- | Statistics for all Pact queue priorities --- -data PactQueueStats = PactQueueStats - { _validateblock :: !PactQueueCounters - , _newblock :: !PactQueueCounters - , _othermsg :: !PactQueueCounters - } - deriving (Generic, NFData) - -instance ToJSON PactQueueStats where - toJSON = object . pactQueueStatsProperties - toEncoding = pairs . mconcat . pactQueueStatsProperties - {-# INLINE toJSON #-} - {-# INLINE toEncoding #-} - -pactQueueStatsProperties :: KeyValue e kv => PactQueueStats -> [kv] -pactQueueStatsProperties o = - [ "validate" .= _validateblock o - , "newblock" .= _newblock o - , "other" .= _othermsg o - ] -{-# INLINE pactQueueStatsProperties #-} - -resetPactQueueStats :: PactQueue -> IO () -resetPactQueueStats q = do - reset (_pactQueuePactQueueValidateBlockMsgCounters q) - reset (_pactQueuePactQueueNewBlockMsgCounters q) - reset (_pactQueuePactQueueOtherMsgCounters q) - where - reset ref = atomicWriteIORef ref initPactQueueCounters - -getPactQueueStats :: PactQueue -> IO PactQueueStats -getPactQueueStats q = PactQueueStats - <$> readIORef (_pactQueuePactQueueValidateBlockMsgCounters q) - <*> readIORef (_pactQueuePactQueueNewBlockMsgCounters q) - <*> readIORef (_pactQueuePactQueueOtherMsgCounters q) diff --git a/src/Chainweb/Pact/Templates.hs b/src/Chainweb/Pact/Templates.hs new file mode 100644 index 0000000000..6aaa38c36f --- /dev/null +++ b/src/Chainweb/Pact/Templates.hs @@ -0,0 +1,138 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE ImportQualifiedPost #-} + +-- | +-- Module : Chainweb.Pact.Templates +-- Copyright : Copyright © 2010 Kadena LLC. +-- License : (see the file LICENSE) +-- Maintainer : Stuart Popejoy +-- Stability : experimental +-- +-- Prebuilt Term templates for automated operations (coinbase, gas buy) +-- +module Chainweb.Pact.Templates +( mkFundTxTerm +, mkBuyGasTerm +, mkRedeemGasTerm +, mkCoinbaseTerm +) where + +import Data.Decimal +import Data.Text (Text) + +-- internal modules + +import Chainweb.Miner.Pact + +import Pact.Core.Literal qualified as Pact +import Pact.Core.Names qualified as Pact +import Pact.Core.Syntax.ParseTree qualified as Pact +import Pact.Core.PactValue qualified as Pact +import Data.Map as Map +import Chainweb.Pact.Types + +fundTxTemplate :: Text -> Text -> Pact.Expr () +fundTxTemplate sender mid = + let senderTerm = strLit sender + midTerm = strLit mid + varApp = qn "fund-tx" "coin" + -- TODO PP: fork this so that guards are supported, by using read-msg instead. + -- instead of forking here, in theory we could detect the type of guard + -- and use different code if it's a keyset. + rks = app (bn "read-keyset") [strLit "miner-keyset"] + rds = app (bn "read-decimal") [strLit "total"] + in app varApp [senderTerm, midTerm, rks, rds] + +buyGasTemplate :: Text -> Pact.Expr () +buyGasTemplate sender = + let senderTerm = strLit sender + varApp = qn "buy-gas" "coin" + rds = app (bn "read-decimal") [strLit "total"] + in app varApp [senderTerm, rds] + +redeemGasTemplate :: Text -> Text -> Pact.Expr () +redeemGasTemplate mid sender = + let midTerm = strLit mid + senderTerm = strLit sender + varApp = qn "redeem-gas" "coin" + -- TODO PP: fork this so that guards are supported, by using read-msg instead + rks = app (bn "read-keyset") [strLit "miner-keyset"] + rds = app (bn "read-decimal") [strLit "total"] + in app varApp [midTerm, rks, senderTerm, rds] + +app :: Pact.Expr () -> [Pact.Expr ()] -> Pact.Expr () +app arg args = Pact.App arg args () + +strLit :: Text -> Pact.Expr () +strLit txt = Pact.Constant (Pact.LString txt) () + +qn :: Text -> Text -> Pact.Expr () +qn name modname = Pact.Var (Pact.QN (Pact.QualifiedName name (Pact.ModuleName modname Nothing))) () + +bn :: Text -> Pact.Expr () +bn name = Pact.Var (Pact.BN (Pact.BareName name)) () + +mkFundTxTerm + :: MinerId -- ^ Id of the miner to fund + -> MinerGuard + -> Text -- ^ Address of the sender from the command + -> GasSupply + -> (Pact.Expr (), Map.Map Pact.Field Pact.PactValue) +mkFundTxTerm (MinerId mid) (MinerGuard ks) sender total = + let + term = fundTxTemplate sender mid + buyGasData = Map.fromList + [ ("miner-keyset", Pact.PGuard ks) + , ("total", Pact.PDecimal $ _pact5GasSupply total) + ] + in (term, buyGasData) + +mkBuyGasTerm + :: Text -- ^ Address of the sender from the command + -> GasSupply + -> (Pact.Expr (), Map.Map Pact.Field Pact.PactValue) +mkBuyGasTerm sender total = (buyGasTemplate sender, buyGasData) + where + buyGasData = Map.fromList + [ ("total", Pact.PDecimal $ _pact5GasSupply total) ] +{-# INLINABLE mkBuyGasTerm #-} + +mkRedeemGasTerm + :: MinerId -- ^ Id of the miner to fund + -> MinerGuard -- ^ Miner guard + -> Text -- ^ Address of the sender from the command + -> GasSupply -- ^ The gas limit total * price + -> GasSupply -- ^ The gas used * price + -> (Pact.Expr (), Pact.PactValue) +mkRedeemGasTerm (MinerId mid) (MinerGuard g) sender total fee = + (redeemGasTemplate mid sender, redeemGasData) + where + redeemGasData = Pact.PObject $ Map.fromList + [ ("total", Pact.PDecimal $ _pact5GasSupply total) + , ("fee", Pact.PDecimal $ _pact5GasSupply fee) + , ("miner-keyset", Pact.PGuard g) + ] +{-# INLINABLE mkRedeemGasTerm #-} + +coinbaseTemplate :: Text -> Pact.Expr () +coinbaseTemplate mid = + let midTerm = strLit mid + varApp = qn "coinbase" "coin" + -- TODO PP: fork this so that guards are supported, by using read-msg instead + rks = app (bn "read-keyset") [strLit "miner-keyset"] + rds = app (bn "read-decimal") [strLit "reward"] + in app varApp [midTerm, rks, rds] + +mkCoinbaseTerm :: MinerId -> MinerGuard -> Decimal -> (Pact.Expr (), Pact.PactValue) +mkCoinbaseTerm (MinerId mid) (MinerGuard g) reward = (coinbaseTemplate mid, coinbaseData) + where + coinbaseData = Pact.PObject $ Map.fromList + [ ("miner-keyset", Pact.PGuard g) + , ("reward", Pact.PDecimal reward) + ] +{-# INLINABLE mkCoinbaseTerm #-} diff --git a/src/Chainweb/Pact5/Transaction.hs b/src/Chainweb/Pact/Transaction.hs similarity index 73% rename from src/Chainweb/Pact5/Transaction.hs rename to src/Chainweb/Pact/Transaction.hs index 4c264b1b6e..7849d5cb95 100644 --- a/src/Chainweb/Pact5/Transaction.hs +++ b/src/Chainweb/Pact/Transaction.hs @@ -10,15 +10,16 @@ {-# language ScopedTypeVariables #-} {-# language TypeApplications #-} -module Chainweb.Pact5.Transaction - ( Transaction - , PayloadWithText - , payloadBytes - , payloadObj - , payloadCodec - , parseCommand - , parsePact4Command - ) where +module Chainweb.Pact.Transaction + ( Transaction + , PayloadWithText + , unsafeMkPayloadWithText + , payloadBytes + , payloadObj + , commandCodec + , parseCommand + , HashableTransaction(..) + ) where import "aeson" Data.Aeson qualified as Aeson import "base" Data.Function @@ -33,11 +34,11 @@ import "pact-tng" Pact.Core.ChainData import "pact-tng" Pact.Core.Command.Types import "pact-tng" Pact.Core.Errors import "pact-tng" Pact.Core.Info -import "pact-tng" Pact.Core.Pretty qualified as Pact5 +import "pact-tng" Pact.Core.Pretty qualified as Pact import "text" Data.Text (Text) import "text" Data.Text.Encoding (decodeUtf8, encodeUtf8) -import Chainweb.Pact4.Transaction qualified as Pact4 import Chainweb.Utils +import Data.Hashable type Transaction = Command (PayloadWithText PublicMeta ParsedCode) @@ -58,6 +59,12 @@ instance (J.Encode meta, J.Encode code) => J.Encode (PayloadWithText meta code) , "payloadObject" J..= _payloadObj p ] +unsafeMkPayloadWithText :: Payload meta code -> ByteString -> PayloadWithText meta code +unsafeMkPayloadWithText payload bytes = UnsafePayloadWithText + { _payloadBytes = SB.toShort bytes + , _payloadObj = payload + } + payloadBytes :: Getter (PayloadWithText meta code) SB.ShortByteString payloadBytes = to _payloadBytes {-# inline conlike payloadBytes #-} @@ -68,36 +75,34 @@ payloadObj = to _payloadObj -- | A codec for Pact5's (Command PayloadWithText) transactions. -- -payloadCodec +commandCodec :: Codec (Command (PayloadWithText PublicMeta ParsedCode)) -payloadCodec = Codec enc dec +commandCodec = Codec enc dec where enc c = J.encodeStrict $ fmap (decodeUtf8 . encodePayload) c dec bs = case Aeson.decodeStrict' bs of -- Note: this can only ever emit a `ParseError`, which by default are quite small. -- Still, `pretty` instances are scary, but this cannot make it into block outputs so this should -- be okay - Just (cmd :: Command Text) -> over _Left Pact5.renderCompactString $ parseCommand cmd + Just (cmd :: Command Text) -> over _Left Pact.renderCompactString $ parseCommand cmd Nothing -> Left "decode PayloadWithText failed" -parseCommand :: Command Text -> Either (PactError SpanInfo) Transaction +parseCommand :: Command Text -> Either (PactError SpanInfo) (Command (PayloadWithText PublicMeta ParsedCode)) parseCommand cmd = do let cmd' = fmap encodeUtf8 cmd let code = SB.toShort (_cmdPayload cmd') parsedCmd <- over (_Right . cmdPayload . pMeta) _stableEncoding $ unsafeParseCommand cmd' - return (parsedCmd & cmdPayload %~ \obj -> UnsafePayloadWithText { _payloadBytes = code, _payloadObj = obj }) + return + (parsedCmd & cmdPayload %~ \obj -> UnsafePayloadWithText { _payloadBytes = code, _payloadObj = obj }) encodePayload :: PayloadWithText meta code -> ByteString encodePayload = SB.fromShort . _payloadBytes -parsePact4Command :: Pact4.UnparsedTransaction -> Either (Either Text (PactError SpanInfo)) Transaction -parsePact4Command bs = - case Aeson.decodeStrict' (codecEncode Pact4.rawCommandCodec bs) of - -- Note: this can only ever emit a `ParseError`, which by default are quite small. - -- Still, `pretty` instances are scary, but this cannot make it into block outputs so this should - -- be okay - Just (cmd :: Command Text) -> over _Left Right $ parseCommand cmd - Nothing -> Left $ Left "decode PayloadWithText failed" +newtype HashableTransaction = HashableTransaction Transaction + deriving Eq + +instance Hashable HashableTransaction where + hashWithSalt salt (HashableTransaction tx) = hashWithSalt salt (_cmdHash tx) -- decodePayload -- :: ByteString diff --git a/src/Chainweb/Pact5/TransactionExec.hs b/src/Chainweb/Pact/TransactionExec.hs similarity index 78% rename from src/Chainweb/Pact5/TransactionExec.hs rename to src/Chainweb/Pact/TransactionExec.hs index f88e8b3d7f..3401416a89 100644 --- a/src/Chainweb/Pact5/TransactionExec.hs +++ b/src/Chainweb/Pact/TransactionExec.hs @@ -26,7 +26,7 @@ -- -- Pact command execution and coin-contract transaction logic for Chainweb -- -module Chainweb.Pact5.TransactionExec +module Chainweb.Pact.TransactionExec ( -- * Public API TransactionM(..) , TransactionEnv(..) @@ -70,10 +70,8 @@ import qualified Data.Text.Encoding as T import qualified System.LogLevel as L -- internal Pact modules -import qualified Pact.JSON.Decode as J import qualified Pact.JSON.Encode as J - import Pact.Core.Builtin import Pact.Core.Capabilities import Pact.Core.Compile @@ -94,48 +92,44 @@ import Pact.Core.SPV import Pact.Core.Serialise.LegacyPact () import Pact.Core.Signer import Pact.Core.StableEncoding -import Pact.Core.Verifiers import Pact.Core.Syntax.ParseTree qualified as Lisp -import Pact.Core.Gas.Utils qualified as Pact5 +import Pact.Core.Gas.Utils qualified as Pact + +import Pact.Core.Command.Types +import Pact.Core.Command.RPC +import qualified Pact.Core.Errors as Pact +import qualified Pact.Core.Gas as Pact +import qualified Pact.Core.Evaluate as Pact -- internal Chainweb modules import Chainweb.BlockCreationTime import Chainweb.BlockHash -import Chainweb.BlockHeader import Chainweb.BlockHeight import Chainweb.ForkState import Chainweb.Logger import Chainweb.Miner.Pact +import Chainweb.Pact.InitialGasModel import Chainweb.Pact.Types -import Chainweb.Pact5.Templates -import Chainweb.Pact5.Types -import Chainweb.Pact5.InitialGasModel +import Chainweb.Pact.Templates +import Chainweb.Parent import Chainweb.Time -import Chainweb.Pact5.Transaction +import Chainweb.Pact.Transaction import Chainweb.VerifierPlugin hiding (chargeGas) import Chainweb.Utils import Chainweb.Version as V import Chainweb.Version.Guards as V import Chainweb.Version.Utils as V -import Pact.Core.Command.Types import Data.ByteString (ByteString) -import Pact.Core.Command.RPC -import qualified Pact.Types.Gas as Pact4 import qualified Data.Set as Set import qualified Data.Text as T import qualified Data.Vector as Vector import Data.Set (Set) import Data.Void import Control.Monad.Except -import Data.Int -import qualified Pact.Types.Verifier as Pact4 -import qualified Pact.Types.Capability as Pact4 -import qualified Pact.Types.Names as Pact4 -import qualified Pact.Types.Runtime as Pact4 -import qualified Pact.Core.Errors as Pact5 +import qualified Chainweb.MinerReward as MinerReward -- Note [Throw out verifier proofs eagerly] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -158,13 +152,15 @@ makeLenses ''TransactionEnv -- | TODO: document how TransactionM is just for the "paid-for" fragment of the transaction flow newtype TransactionM logger a - = TransactionM { runTransactionM :: ReaderT (TransactionEnv logger) (ExceptT (Pact5.PactError Info) IO) a } + = TransactionM + { runTransactionM :: ReaderT (TransactionEnv logger) (ExceptT (Pact.PactError Pact.Info) IO) a + } deriving newtype ( Functor , Applicative , Monad , MonadReader (TransactionEnv logger) - , MonadError (Pact5.PactError Info) + , MonadError (Pact.PactError Pact.Info) , MonadThrow , MonadIO ) @@ -176,63 +172,27 @@ chargeGas info gasArgs = do liftIO (chargeGasArgsM gasEnv info [] gasArgs) --- Create a Set of Flags from a list of default flags (unconditional) --- and a list of guarded flags (context-dependent). -aggregateFlags :: TxContext -> [ExecutionFlag] -> [TxContext -> Set ExecutionFlag] -> Set ExecutionFlag -aggregateFlags ctx defaultFlags guardedFlags = Set.fromList defaultFlags `Set.union` foldMap ($ ctx) guardedFlags - - -- run verifiers -- nasty... perhaps later convert verifier plugins to use GasM instead of tracking "gas remaining" -- TODO: Verifiers are also tied to Pact enough that this is going to be an annoying migration -runVerifiers :: Logger logger => TxContext -> Command (Payload PublicMeta ParsedCode) -> TransactionM logger () +runVerifiers :: (Logger logger, HasVersion) => BlockCtx -> Command (Payload PublicMeta ParsedCode) -> TransactionM logger () runVerifiers txCtx cmd = do logger <- view txEnvLogger - let v = _chainwebVersion txCtx let gasLimit = cmd ^. cmdPayload . pMeta . pmGasLimit gasUsed <- liftIO . readIORef . _geGasRef . _txEnvGasEnv =<< ask let initGasRemaining = MilliGas $ case (gasToMilliGas (gasLimit ^. _GasLimit), gasUsed) of (MilliGas gasLimitMilliGasWord, MilliGas gasUsedMilliGasWord) -> gasLimitMilliGasWord - gasUsedMilliGasWord - let allVerifiers = verifiersAt v (_chainId txCtx) (ctxParentForkNumber txCtx) (ctxCurrentBlockHeight txCtx) - let toModuleName m = - Pact4.ModuleName - { Pact4._mnName = _mnName m - , Pact4._mnNamespace = coerce <$> _mnNamespace m - } - let toQualifiedName qn = - Pact4.QualifiedName - { Pact4._qnQual = toModuleName $ _qnModName qn - , Pact4._qnName = _qnName qn - , Pact4._qnInfo = Pact4.Info Nothing - } - -- TODO: correct error handling here? we should probably charge the user - let convertPactValue pv = fromJuste $ J.decodeStrict $ encodeStable pv - let pact4TxVerifiers = - [ Pact4.Verifier - { Pact4._verifierName = case _verifierName pact5Verifier of - VerifierName n -> Pact4.VerifierName n - , Pact4._verifierProof = - -- TODO: correct error handling here? we should probably charge the user - Pact4.ParsedVerifierProof $ fromJuste $ - convertPactValue $ coerce @ParsedVerifierProof @PactValue $ _verifierProof pact5Verifier - , Pact4._verifierCaps = - [ Pact4.SigCapability (toQualifiedName n) (convertPactValue <$> args) - | SigCapability (CapToken n args) <- _verifierCaps pact5Verifier - ] - } - | pact5Verifier <- fromMaybe [] $ cmd ^. cmdPayload . pVerifiers - ] + let allVerifiers = verifiersAt (_chainId txCtx) (_bctxParentForkNumber txCtx) (_bctxCurrentBlockHeight txCtx) + let txVerifiers = fromMaybe [] $ cmd ^. cmdPayload . pVerifiers verifierResult <- liftIO $ runVerifierPlugins - (_chainwebVersion txCtx, _chainId txCtx, ctxCurrentBlockHeight txCtx) logger + (_chainId txCtx, _bctxCurrentBlockHeight txCtx) logger allVerifiers - (Pact4.Gas $ fromIntegral @SatWord @Int64 $ _gas $ milliGasToGas $ initGasRemaining) - pact4TxVerifiers + (milliGasToGas $ initGasRemaining) + txVerifiers case verifierResult of Left err -> do - throwError (Pact5.PEVerifierError err noInfo) - Right (Pact4.Gas pact4VerifierGasRemaining) -> do - -- TODO: crash properly on negative? - let verifierGasRemaining = fromIntegral @Int64 @SatWord pact4VerifierGasRemaining + throwError (Pact.PEVerifierError err noInfo) + Right (Pact.Gas verifierGasRemaining) -> do -- NB: this is not nice. -- TODO: better gas info here -- Explanation by cases: @@ -250,20 +210,20 @@ runVerifiers txCtx cmd = do chargeGas noInfo $ GAConstant $ MilliGas $ coerce initGasRemaining - coerce (gasToMilliGas (Gas verifierGasRemaining)) applyLocal - :: (Logger logger) + :: (Logger logger, HasVersion) => logger -- ^ Pact logger -> Maybe logger -- ^ Pact gas logger -> PactDb CoreBuiltin Info -- ^ Pact db environment - -> TxContext + -> BlockCtx -- ^ tx metadata and parent header -> SPVSupport -- ^ SPV support (validates cont proofs) -> Command (Payload PublicMeta ParsedCode) -- ^ command with payload to execute - -> IO (CommandResult [TxLog ByteString] (Pact5.PactError Info)) + -> IO (CommandResult [TxLog ByteString] (Pact.PactError Info)) applyLocal logger maybeGasLogger coreDb txCtx spvSupport cmd = do let gasLogsEnabled = maybe GasLogsDisabled (const GasLogsEnabled) maybeGasLogger let gasLimitGas :: Gas = cmd ^. cmdPayload . pMeta . pmGasLimit . _GasLimit @@ -306,21 +266,14 @@ applyLocal logger maybeGasLogger coreDb txCtx spvSupport cmd = do } where - localFlags = aggregateFlags txCtx - [ FlagDisableRuntimeRTC - , FlagEnforceKeyFormats + localFlags = S.fromList + [ FlagEnforceKeyFormats -- Note: this is currently not conditional -- in pact-5 exec. This may change if it breaks -- anyone's workflow , FlagAllowReadInLocal , FlagRequireKeysetNs - ] - - [ guardDisablePact51Flags - , guardDisablePact52And53Flags - , guardDisablePact54Flags - , guardDisablePact54FixFlags - ] + ] `Set.union` flagsFor txCtx -- | The main entry point to executing transactions. From here, -- 'applyCmd' assembles the command environment for a command, @@ -332,13 +285,16 @@ applyLocal logger maybeGasLogger coreDb txCtx spvSupport cmd = do -- applyCmd :: forall logger. (Logger logger) + => HasVersion => logger -- ^ Pact logger - -> Maybe logger + -> Maybe GasLogger -- ^ Pact gas logger -> PactDb CoreBuiltin Info -- ^ Pact db environment - -> TxContext + -> Miner + -- ^ miner + -> BlockCtx -- ^ tx metadata -> TxIdxInBlock -> SPVSupport @@ -347,24 +303,19 @@ applyCmd -- ^ initial gas cost -> Command (Payload PublicMeta ParsedCode) -- ^ command with payload to execute - -> IO (Either Pact5GasPurchaseFailure (CommandResult [TxLog ByteString] (Pact5.PactError Info))) -applyCmd logger maybeGasLogger db txCtx txIdxInBlock spv initialGas cmd = do - logDebug_ logger $ "applyCmd: " <> sshow (_cmdHash cmd) - let flags = aggregateFlags txCtx + -> IO (Either TxInvalidError (CommandResult [TxLog ByteString] (Pact.PactError Info))) +applyCmd logger maybeGasLogger db miner txCtx txIdxInBlock spv initialGas cmd = do + logDebug_ logger "applyCmd" + let flags = Set.fromList [ FlagDisableRuntimeRTC , FlagDisableHistoryInTransactionalMode , FlagEnforceKeyFormats , FlagRequireKeysetNs - ] - [ guardDisablePact51Flags - , guardDisablePact52And53Flags - , guardDisablePact54Flags - , guardDisablePact54FixFlags - ] - + ] `Set.union` guardDisablePact51Flags txCtx + `Set.union` guardDisablePact52And53Flags txCtx + `Set.union` guardDisablePact54Flags txCtx let gasLogsEnabled = maybe GasLogsDisabled (const GasLogsEnabled) maybeGasLogger gasEnv <- mkTableGasEnv (MilliGasLimit $ gasToMilliGas $ gasLimit ^. _GasLimit) gasLogsEnabled - let !requestKey = cmdToRequestKey cmd -- this process is "paid for", i.e. it's powered by a supply of gas that was -- purchased by a user already. any errors here will result in the entire gas -- supply being paid to the miner and the transaction failing, but still going @@ -377,19 +328,20 @@ applyCmd logger maybeGasLogger db txCtx txIdxInBlock spv initialGas cmd = do runVerifiers txCtx cmd - liftIO $ dumpGasLogs "applyCmd.paidFor.beforeRunPayload" (_cmdHash cmd) maybeGasLogger gasEnv + -- TODO: PP + -- liftIO $ dumpGasLogs "applyCmd.paidFor.beforeRunPayload" (_cmdHash cmd) maybeGasLogger gasEnv evalResult <- runPayload Transactional flags db spv [] managedNamespacePolicy gasEnv txCtx txIdxInBlock cmd - liftIO $ dumpGasLogs "applyCmd.paidFor.afterRunPayload" (_cmdHash cmd) maybeGasLogger gasEnv + -- liftIO $ dumpGasLogs "applyCmd.paidFor.afterRunPayload" (_cmdHash cmd) maybeGasLogger gasEnv return evalResult eBuyGasResult <- do if GasLimit initialGas > gasLimit then do - pure $ Left (PurchaseGasTxTooBigForGasLimit requestKey) + pure $ Left PurchaseGasTxTooBigForGasLimit else do - buyGas logger gasEnv db txCtx cmd >>= \case + buyGas logger gasEnv db miner txCtx cmd >>= \case Left buyGasError -> do - pure $ Left (BuyGasError requestKey buyGasError) + pure $ Left (BuyGasError buyGasError) Right buyGasResult -> do pure $ Right buyGasResult @@ -407,13 +359,13 @@ applyCmd logger maybeGasLogger db txCtx txIdxInBlock spv initialGas cmd = do -- and all of the gas is sent to the miner. only buying gas and sending it to the miner are recorded. -- the Pact transaction is cancelled, and events and logs from the command are not recorded. eRedeemGasResult <- redeemGas - logger db txCtx + logger db miner txCtx (gasLimit ^. _GasLimit) (_peDefPactId <$> _erExec buyGasResult) cmd case eRedeemGasResult of Left redeemGasError -> do - pure (Left (RedeemGasError requestKey redeemGasError)) + pure (Left (RedeemGasError redeemGasError)) Right redeemGasResult -> do return $ Right $ CommandResult { _crReqKey = RequestKey $ _cmdHash cmd @@ -431,14 +383,14 @@ applyCmd logger maybeGasLogger db txCtx txIdxInBlock spv initialGas cmd = do -- return all unused gas to the user and send all used -- gas to the miner. eRedeemGasResult <- redeemGas - logger db txCtx + logger db miner txCtx gasUsed (_peDefPactId <$> _erExec buyGasResult) cmd case eRedeemGasResult of Left redeemGasError -> do - pure (Left (RedeemGasError requestKey redeemGasError)) + pure (Left (RedeemGasError redeemGasError)) Right redeemGasResult -> do -- ensure we include the events and logs from buyGas and redeemGas in the result return $ Right $ CommandResult @@ -460,46 +412,46 @@ applyCmd logger maybeGasLogger db txCtx txIdxInBlock spv initialGas cmd = do -- current blockheight, referencing the parent header (not grandparent!) -- hash and blocktime data. -- -ctxToPublicData :: PublicMeta -> TxContext -> PublicData -ctxToPublicData pm (TxContext ph _) = PublicData +ctxToPublicData :: PublicMeta -> BlockCtx -> PublicData +ctxToPublicData pm ctx = PublicData { _pdPublicMeta = pm , _pdBlockHeight = bh , _pdBlockTime = bt , _pdPrevBlockHash = toText h } where - bheader = _parentHeader ph - BlockHeight !bh = succ $ view blockHeight bheader - BlockCreationTime (Time (TimeSpan (Micros !bt))) = - view blockCreationTime bheader - BlockHash h = view blockHash bheader + BlockHeight !bh = succ $ unwrapParent $ _bctxParentHeight ctx + Parent (BlockCreationTime (Time (TimeSpan (Micros !bt)))) = + _bctxParentCreationTime ctx + Parent (BlockHash h) = _bctxParentHash ctx -- | 'applyCoinbase' performs upgrade transactions and constructs and executes -- a transaction which pays miners their block reward. applyCoinbase :: (Logger logger) + => HasVersion => logger -- ^ Pact logger -> PactDb CoreBuiltin Info -- ^ Pact db environment - -> Decimal - -- ^ Miner reward - -> TxContext + -> Miner + -- ^ miner + -> BlockCtx -- ^ tx metadata and parent header - -> IO (Either Pact5CoinbaseError (CommandResult [TxLog ByteString] Void)) -applyCoinbase logger db reward txCtx = do + -> IO (Either (Pact.PactError Pact.Info) (CommandResult [TxLog ByteString] Void)) +applyCoinbase logger db (Miner mid mks) txCtx = do -- for some reason this is the base64-encoded hash, rather than the binary hash let coinbaseHash = Hash $ SB.toShort $ T.encodeUtf8 $ blockHashToText parentBlockHash -- applyCoinbase is when upgrades happen, so we call applyUpgrades first applyUpgrades logger db txCtx -- we construct the coinbase term and evaluate it freeGasEnv <- mkFreeGasEnv GasLogsDisabled + let MinerReward.Kda minerRewardKda = MinerReward.minerRewardKda $ _bctxMinerReward txCtx let - (coinbaseTerm, coinbaseData) = mkCoinbaseTerm mid mks reward - flags = aggregateFlags txCtx [FlagDisableRuntimeRTC] [guardDisablePact52And53Flags] + (coinbaseTerm, coinbaseData) = mkCoinbaseTerm mid mks minerRewardKda eCoinbaseTxResult <- evalExecTerm Transactional - db noSPVSupport freeGasEnv flags SimpleNamespacePolicy + db noSPVSupport freeGasEnv (flagsFor txCtx) SimpleNamespacePolicy (ctxToPublicData noPublicMeta txCtx) MsgData { mdHash = coinbaseHash @@ -513,7 +465,7 @@ applyCoinbase logger db reward txCtx = do (noSpanInfo <$ coinbaseTerm) case eCoinbaseTxResult of Left err -> do - pure $ Left $ CoinbasePactError err + pure $ Left err Right coinbaseTxResult -> do return $! Right $! CommandResult { _crReqKey = RequestKey coinbaseHash @@ -529,8 +481,7 @@ applyCoinbase logger db reward txCtx = do } where - parentBlockHash = view blockHash $ _parentHeader $ _tcParentHeader txCtx - Miner mid mks = _tcMiner txCtx + parentBlockHash = unwrapParent $ _bctxParentHash txCtx -- | Apply (forking) upgrade transactions and module cache updates -- at a particular blockheight. @@ -543,20 +494,18 @@ applyCoinbase logger db reward txCtx = do -- applyUpgrades :: (Logger logger) + => HasVersion => logger -> PactDb CoreBuiltin Info - -> TxContext + -> BlockCtx -> IO () applyUpgrades logger db txCtx - | Just Pact4Upgrade{} <- - v ^? versionUpgrades . atChain cid . ix currentHeight = error "Expected Pact 4 upgrade, got Pact 5" | Just Pact5Upgrade{_pact5UpgradeTransactions = upgradeTxs} <- - v ^? versionUpgrades . atChain cid . ix currentHeight = applyUpgrade upgradeTxs + implicitVersion ^? versionUpgrades . atChain cid . ix currentHeight = applyUpgrade upgradeTxs | guardCtx migratePlatformShare txCtx = doMigratePlatformShare db | otherwise = return () where - v = _chainwebVersion txCtx - currentHeight = ctxCurrentBlockHeight txCtx + currentHeight = _bctxCurrentBlockHeight txCtx cid = _chainId txCtx applyUpgrade :: [Transaction] -> IO () applyUpgrade upgradeTxs = do @@ -605,25 +554,25 @@ doMigratePlatformShare db = do -- * Any failures are fatal to PactService runGenesisPayload :: Logger logger + => HasVersion => logger -> PactDb CoreBuiltin Info -> SPVSupport - -> TxContext + -> BlockCtx -> Command (Payload PublicMeta ParsedCode) - -> IO (Either (Pact5.PactError Info) (CommandResult [TxLog ByteString] Void)) -runGenesisPayload logger db spv ctx cmd = do + -> IO (Either (Pact.PactError Info) (CommandResult [TxLog ByteString] Void)) +runGenesisPayload logger db spv txCtx cmd = do gasRef <- newIORef (MilliGas 0) let gasEnv = GasEnv gasRef Nothing freeGasModel let txEnv = TransactionEnv logger gasEnv -- Todo gas logs freeGasEnv <- mkFreeGasEnv GasLogsDisabled - let flags = aggregateFlags ctx [FlagDisableRuntimeRTC] [guardDisablePact52And53Flags, guardDisablePact54Flags] runExceptT (runReaderT (runTransactionM (runPayload Transactional - flags + (flagsFor txCtx) db spv [ CapToken (QualifiedName "GENESIS" (ModuleName "coin" Nothing)) [] @@ -632,7 +581,7 @@ runGenesisPayload logger db spv ctx cmd = do -- allow installing to root namespace SimpleNamespacePolicy freeGasEnv - ctx + txCtx (TxBlockIdx 0) cmd <&> \evalResult -> CommandResult @@ -651,6 +600,7 @@ runGenesisPayload logger db spv ctx cmd = do runPayload :: (Logger logger) + => HasVersion => ExecutionMode -> Set ExecutionFlag -> PactDb CoreBuiltin Info @@ -658,7 +608,7 @@ runPayload -> [CapToken QualifiedName PactValue] -> NamespacePolicy -> GasEnv CoreBuiltin Info - -> TxContext + -> BlockCtx -> TxIdxInBlock -> Command (Payload PublicMeta ParsedCode) -> TransactionM logger EvalResult @@ -707,38 +657,33 @@ runPayload execMode execFlags db spv specialCaps namespacePolicy gasEnv txCtx tx case maybeQuirkGasFee of Nothing -> return result Just quirkGasFee -> do - let convertedQuirkGasFee = Gas $ fromIntegral quirkGasFee - liftIO $ writeIORef (_geGasRef gasEnv) $ gasToMilliGas convertedQuirkGasFee - return result { _erGas = convertedQuirkGasFee } + liftIO $ writeIORef (_geGasRef gasEnv) $ gasToMilliGas quirkGasFee + return result { _erGas = quirkGasFee } where payload = cmd ^. cmdPayload verifiers = payload ^. pVerifiers . _Just signers = payload ^. pSigners publicMeta = cmd ^. cmdPayload . pMeta - v = _chainwebVersion txCtx cid = _chainId txCtx - maybeQuirkGasFee = v ^? versionQuirks . quirkGasFees . ixg cid . ix (ctxCurrentBlockHeight txCtx, txIdxInBlock) + maybeQuirkGasFee = implicitVersion ^? versionQuirks . quirkGasFees . ixg cid . ix (_bctxCurrentBlockHeight txCtx, txIdxInBlock) runUpgrade :: (Logger logger) + => HasVersion => logger -> PactDb CoreBuiltin Info - -> TxContext + -> BlockCtx -> Command (Payload PublicMeta ParsedCode) -> IO () -runUpgrade _logger db txContext cmd = case payload ^. pPayload of +runUpgrade _logger db txCtx cmd = case payload ^. pPayload of Exec pm -> do freeGasEnv <- mkFreeGasEnv GasLogsDisabled - let flags = Set.unions - [ Set.singleton FlagDisableRuntimeRTC - , guardDisablePact52And53Flags txContext - ] evalExec (RawCode (_pcCode (_pmCode pm))) Transactional - db noSPVSupport freeGasEnv flags + db noSPVSupport freeGasEnv (flagsFor txCtx) -- allow installing to root namespace SimpleNamespacePolicy - (ctxToPublicData publicMeta txContext) + (ctxToPublicData publicMeta txCtx) MsgData { mdHash = chash , mdData = PObject mempty @@ -749,7 +694,7 @@ runUpgrade _logger db txContext cmd = case payload ^. pPayload of & csSlots .~ [CapSlot (CapToken (QualifiedName "REMEDIATE" (ModuleName "coin" Nothing)) []) []] & csModuleAdmin .~ S.singleton (ModuleName "coin" Nothing)) (fmap (noSpanInfo <$) $ _pcExps $ _pmCode pm) >>= \case - Left err -> internalError $ "Pact5.runGenesis: internal error " <> sshow err + Left err -> error $ "Pact.runGenesis: internal error " <> sshow err -- TODO: we should probably put these events somewhere! Right _r -> return () Continuation _ -> error "runGenesisCore Continuation not supported" @@ -790,16 +735,17 @@ enrichedMsgBodyForGasPayer dat cmd = case (_pPayload $ _cmdPayload cmd) of -- buyGas :: (Logger logger) + => HasVersion => logger -> GasEnv CoreBuiltin Info -> PactDb CoreBuiltin Info - -> TxContext + -> Miner + -> BlockCtx -> Command (Payload PublicMeta ParsedCode) - -> IO (Either Pact5BuyGasError EvalResult) -buyGas logger origGasEnv db txCtx cmd = do + -> IO (Either BuyGasError EvalResult) +buyGas logger origGasEnv db (Miner mid mks) txCtx cmd = do let gasEnv = origGasEnv & geGasModel . gmGasLimit .~ Just (MilliGasLimit (MilliGas 1_500_000)) - logFunctionText logger L.Debug $ - "buying gas for " <> sshow (_cmdHash cmd) + logFunctionText logger L.Debug "buying gas" -- TODO: use quirked gas? let gasPayerCaps = [ cap @@ -813,7 +759,6 @@ buyGas logger origGasEnv db txCtx cmd = do if isChainweb224Pact then mkBuyGasTerm sender supply else mkFundTxTerm mid mks sender supply - flags = Set.unions [Set.singleton FlagDisableRuntimeRTC, guardDisablePact52And53Flags txCtx] runExceptT $ do gasPayerCap <- case gasPayerCaps of @@ -826,7 +771,7 @@ buyGas logger origGasEnv db txCtx cmd = do -- It's taking an `Expr Info` instead of `Expr SpanInfo` which is making this code not compile e <- liftIO $ case gasPayerCap of Just cap -> - evalGasPayerCap cap db noSPVSupport gasEnv flags SimpleNamespacePolicy + evalGasPayerCap cap db noSPVSupport gasEnv (flagsFor txCtx) SimpleNamespacePolicy (ctxToPublicData publicMeta txCtx) MsgData -- Note: in the case of gaspayer, buyGas is given extra metadata that comes from @@ -844,8 +789,7 @@ buyGas logger origGasEnv db txCtx cmd = do db noSPVSupport gasEnv - flags - SimpleNamespacePolicy + (flagsFor txCtx) SimpleNamespacePolicy (ctxToPublicData publicMeta txCtx) MsgData -- Note: in the case of gaspayer, buyGas is given extra metadata that comes from @@ -868,10 +812,10 @@ buyGas logger origGasEnv db txCtx cmd = do | otherwise -> -- should never occur pre-chainweb 2.24: -- would mean coin.fund-tx is not a pact - internalError "buyGas: Internal error - empty continuation before 2.24 fork" + error "buyGas: Internal error - empty continuation before 2.24 fork" Just _pe | isChainweb224Pact -> - internalError "buyGas: Internal error - continuation found after 2.24 fork" + error "buyGas: Internal error - continuation found after 2.24 fork" | otherwise -> return er' Left err -> do @@ -892,8 +836,6 @@ buyGas logger origGasEnv db txCtx cmd = do signersWithDebit = fmap addDebit signers - Miner mid mks = _tcMiner txCtx - Hash chash = _cmdHash cmd bgHash = Hash (chash <> "-buygas") @@ -901,25 +843,26 @@ buyGas logger origGasEnv db txCtx cmd = do -- command results (see 'TransactionExec.applyCmd') -- redeemGas :: (Logger logger) + => HasVersion => logger - -> PactDb CoreBuiltin Info -> TxContext + -> PactDb CoreBuiltin Info + -> Miner + -> BlockCtx -> Gas -> Maybe DefPactId -> Command (Payload PublicMeta ParsedCode) - -> IO (Either Pact5RedeemGasError EvalResult) -redeemGas logger db txCtx gasUsed maybeFundTxPactId cmd + -> IO (Either RedeemGasError EvalResult) +redeemGas logger db (Miner mid mks) txCtx gasUsed maybeFundTxPactId cmd | isChainweb224Pact, Nothing <- maybeFundTxPactId = do - logFunctionText logger L.Debug $ - "redeeming gas (post-2.24) for " <> sshow (_cmdHash cmd) + logFunctionText logger L.Debug "redeeming gas (post-2.24)" -- if we're past chainweb 2.24, we don't use defpacts for gas; see 'pact/coin-contract/coin.pact#redeem-gas' let (redeemGasTerm, redeemGasData) = mkRedeemGasTerm mid mks sender gasTotal gasFee - flags = Set.unions [Set.singleton FlagDisableRuntimeRTC, guardDisablePact52And53Flags txCtx] -- todo: gas logs freeGasEnv <- mkFreeGasEnv GasLogsDisabled evalExecTerm Transactional -- TODO: more execution flags? - db noSPVSupport freeGasEnv flags SimpleNamespacePolicy + db noSPVSupport freeGasEnv (flagsFor txCtx) SimpleNamespacePolicy (ctxToPublicData publicMeta txCtx) MsgData { mdData = redeemGasData @@ -936,14 +879,12 @@ redeemGas logger db txCtx gasUsed maybeFundTxPactId cmd | not isChainweb224Pact, Just fundTxPactId <- maybeFundTxPactId = do freeGasEnv <- mkFreeGasEnv GasLogsDisabled - logFunctionText logger L.Debug $ - "redeeming gas (pre-2.24) for " <> sshow (_cmdHash cmd) + logFunctionText logger L.Debug "redeeming gas (pre-2.24)" -- before chainweb 2.24, we use defpacts for gas; see: 'pact/coin-contract/coin.pact#fund-tx' let redeemGasData = PObject $ Map.singleton "fee" (PDecimal $ _pact5GasSupply gasFee) - flags = Set.unions [Set.singleton FlagDisableRuntimeRTC, guardDisablePact52And53Flags txCtx] evalContinuation Transactional - db noSPVSupport freeGasEnv flags SimpleNamespacePolicy + db noSPVSupport freeGasEnv (flagsFor txCtx) SimpleNamespacePolicy (ctxToPublicData publicMeta txCtx) MsgData { mdData = redeemGasData @@ -964,12 +905,11 @@ redeemGas logger db txCtx gasUsed maybeFundTxPactId cmd return $ Right evalResult | otherwise = - internalError "redeemGas: Internal error - defpact ID does not match chainweb224Pact flag" + error "redeemGas: Internal error - defpact ID does not match chainweb224Pact flag" where Hash chash = _cmdHash cmd rgHash = Hash (chash <> "-redeemgas") - Miner mid mks = _tcMiner txCtx isChainweb224Pact = guardCtx chainweb224Pact txCtx publicMeta = cmd ^. cmdPayload . pMeta signers = cmd ^. cmdPayload . pSigners @@ -989,7 +929,7 @@ redeemGas logger db txCtx gasUsed maybeFundTxPactId cmd initialGasOf :: ChainwebVersion -> V.ChainId -> BlockHeight -> ForkNumber -> Transaction -> Gas initialGasOf v cid bh fn tx = Gas $ ceiling $ sizeCost + sizePenaltyCost + sigsCost where - model = activeInitialGasModel v cid fn bh + model = withVersion v $ activeInitialGasModel cid fn bh proofSize = case tx ^. cmdPayload . payloadObj . pPayload of Continuation (ContMsg _ _ _ _ (Just (ContProof p))) -> B.length p _ -> 0 @@ -1029,38 +969,48 @@ toCoinUnit :: Decimal -> Decimal toCoinUnit = roundTo 12 {-# INLINE toCoinUnit #-} -dumpGasLogs :: (Logger logger) +_dumpGasLogs :: (Logger logger) => Text -- ^ context -> Hash -- ^ Command Hash -> Maybe logger -- ^ Gas logger -> GasEnv CoreBuiltin Info -> IO () -dumpGasLogs ctx txHash maybeGasLogger gasEnv = do +_dumpGasLogs ctx txHash maybeGasLogger gasEnv = do forM_ ((,) <$> _geGasLog gasEnv <*> maybeGasLogger) $ \(gasLogRef, gasLogger) -> do gasLogs <- reverse <$> readIORef gasLogRef - let prettyLogs = Pact5.prettyGasLogs (_geGasModel gasEnv) (_gleArgs <$> gasLogs) + let prettyLogs = Pact.prettyGasLogs (_geGasModel gasEnv) (_gleArgs <$> gasLogs) let logger = addLabel ("transactionExecContext", ctx) $ addLabel ("cmdHash", hashToText txHash) $ gasLogger logFunctionText logger L.Debug $ "gas logs: " <> prettyLogs -- After every dump, we clear the gas logs, so that each context only writes the gas logs it induced. writeIORef gasLogRef mempty -guardDisablePact51Flags :: TxContext -> Set ExecutionFlag +guardDisablePact51Flags :: HasVersion => BlockCtx -> Set ExecutionFlag guardDisablePact51Flags txCtx | guardCtx chainweb228Pact txCtx = Set.empty | otherwise = Set.singleton FlagDisablePact51 -guardDisablePact52And53Flags :: TxContext -> Set ExecutionFlag +guardDisablePact52And53Flags :: HasVersion => BlockCtx -> Set ExecutionFlag guardDisablePact52And53Flags txCtx | guardCtx chainweb230Pact txCtx = Set.empty | otherwise = Set.fromList [FlagDisablePact52, FlagDisablePact53, FlagDisableReentrancyCheck] -guardDisablePact54Flags :: TxContext -> Set ExecutionFlag +guardDisablePact54Flags :: HasVersion => BlockCtx -> Set ExecutionFlag guardDisablePact54Flags txCtx | guardCtx chainweb231Pact txCtx = Set.empty - | otherwise = Set.singleton FlagDisablePact54 - -guardDisablePact54FixFlags :: TxContext -> Set ExecutionFlag + | otherwise = Set.fromList [FlagDisablePact54] + +flagsFor :: HasVersion => BlockCtx -> Set ExecutionFlag +flagsFor txCtx = Set.unions + [ guardDisablePact51Flags txCtx + , guardDisablePact52And53Flags txCtx + , guardDisablePact54Flags txCtx + , guardDisablePact54FixFlags txCtx + , Set.singleton FlagDisableRuntimeRTC + , Set.singleton FlagEnforceKeyFormats + ] + +guardDisablePact54FixFlags :: HasVersion => BlockCtx -> Set ExecutionFlag guardDisablePact54FixFlags txCtx - | guardCtx' chainweb32 txCtx = Set.empty - | otherwise = Set.singleton FlagDisablePact54Fix \ No newline at end of file + | chainweb32 (_chainId txCtx) (_bctxParentForkNumber txCtx) = Set.empty + | otherwise = Set.singleton FlagDisablePact54Fix diff --git a/src/Chainweb/Pact/Types.hs b/src/Chainweb/Pact/Types.hs index 8dcb5f3d4f..247389a94a 100644 --- a/src/Chainweb/Pact/Types.hs +++ b/src/Chainweb/Pact/Types.hs @@ -1,523 +1,275 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DeriveTraversable #-} -{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE PartialTypeSignatures #-} -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE StrictData #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE TypeApplications #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE ViewPatterns #-} --- | --- Module: Chainweb.Pact.Types --- Copyright: Copyright © 2018 Kadena LLC. --- License: See LICENSE file --- Maintainer: Mark Nichols --- Stability: experimental --- --- Pact Types module for Chainweb --- +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE NumericUnderscores #-} + module Chainweb.Pact.Types - -- ( Pact4GasSupply(..) - -- , Pact5GasSupply(..) - -- , cleanModuleCache - - -- * Pact Service Env - ( PactServiceEnv(..) - , psMempoolAccess - , psCheckpointer - , psPdb - , psBlockHeaderDb - , psMinerRewards - , psReorgLimit - , psPreInsertCheckTimeout - , psOnFatalError - , psVersion - , psLogger - , psGasLogger - , psAllowReadsInLocal - , psBlockGasLimit - , psEnableLocalTimeout - , psTxFailuresCounter - , psTxTimeLimit - -- - -- * Pact Service State - , PactServiceState(..) - , psInitCache - , PactException(..) - , finalizeBlock - , RunnableBlock(..) - , BlockTxHistory(..) - , emptySQLitePendingData - , BlockInProgress(..) - , blockInProgressParent - , blockInProgressHandle - , blockInProgressModuleCache - , blockInProgressParentHeader - , blockInProgressRemainingGasLimit - , blockInProgressMiner - , blockInProgressTransactions - , blockInProgressPactVersion - , blockInProgressChainwebVersion - , blockInProgressChainId - , NewBlockFill(..) - , Historical(..) - , throwIfNoHistory - , NewBlockReq(..) - , ContinueBlockReq(..) - , SubmittedRequestMsg(..) - , ValidateBlockReq(..) - , RewindDepth(..) - , LocalResult(..) - , _MetadataValidationFailure - , _LocalResultWithWarns - , _LocalResultLegacy - , _LocalTimeout - , pattern Pact4LocalResultLegacy - , _Pact4LocalResultLegacy - , pattern Pact5LocalResultLegacy - , _Pact5LocalResultLegacy - , pattern Pact4LocalResultWithWarns - , _Pact4LocalResultWithWarns - , pattern Pact5LocalResultWithWarns - , _Pact5LocalResultWithWarns - , LocalReq(..) - , ReadOnlyReplayReq(..) - , ConfirmationDepth(..) - , LocalPreflightSimulation(..) - , SyncToBlockReq(..) - , RequestMsg(..) - , RewindLimit(..) - , LookupPactTxsReq(..) - , BlockTxHistoryReq(..) - , PreInsertCheckReq(..) - , SpvRequest(..) - , HistoricalLookupReq(..) - , TransactionOutputProofB64(..) - , RequestStatus(..) - , internalError - , LocalSignatureVerification(..) - , Pact4GasPurchaseFailure(..) - , CoinbaseFailure(..) - , Pact5CoinbaseError(..) - , Pact5BuyGasError(..) - , _BuyGasPactError - , Pact5RedeemGasError(..) - , _RedeemGasPactError - , Pact5GasPurchaseFailure(..) - , _BuyGasError - , _RedeemGasError - , _PurchaseGasTxTooBigForGasLimit - , prettyPact5GasPurchaseFailure - , Transactions(..) - , transactionPairs - , transactionCoinbase - , MemPoolAccess(..) - , ModuleCacheFor(..) - , BlockValidationFailureMsg(..) - , toPayloadWithOutputs - , hashPact4TxLogs - , hashPact5TxLogs - , PactServiceConfig(..) - , RequestCancelled(..) - , convertPact5Error - - - -- * Module cache - , ModuleInitCache - - -- * Pact Service Monad - , PactServiceM(..) - , runPactServiceM - , evalPactServiceM - , execPactServiceM - , PactDbFor - - , PactBlockEnv(..) - , psBlockDbEnv - , psParentHeader - , psIsGenesis - , psServiceEnv - - -- * Logging with Pact logger - - -- , tracePactBlockM - -- , tracePactBlockM' - , pactLoggers - , logg_ - , logInfo_ - , logWarn_ - , logError_ - , logDebug_ - , logPact - , logInfoPact - , logWarnPact - , logErrorPact - , logDebugPact - , logJsonTrace_ - , logJsonTracePact - , localLabelPact - - -- * types - , TxTimeout(..) - , ApplyCmdExecutionContext(..) - , Pact4TxFailureLog(..) - , Pact5TxFailureLog(..) - , AssertCommandError(..) - , displayAssertCommandError - , AssertValidateSigsError(..) - , displayAssertValidateSigsError - - -- * miscellaneous - , defaultOnFatalError - , defaultReorgLimit - , testPactServiceConfig - , testBlockGasLimit - , defaultModuleCacheLimit - , defaultPreInsertCheckTimeout - , withPactState - ) where + ( ServiceEnv(..) + , psChainId + , psGasLogger + , psReadWriteSql + , psReadSqlPool + , psPdb + , psCandidatePdb + , psMempoolAccess + , psPreInsertCheckTimeout + , psAllowReadsInLocal + , psEnableLocalTimeout + , psTxFailuresCounter + , psNewPayloadTxTimeLimit + , psMiner + , psMiningPayloadVar + , psNewBlockGasLimit + , psGenesisPayload + , psBlockRefreshInterval + , psModuleInitCacheVar + + , BlockCtx(..) + , blockCtxOfEvaluationCtx + , evaluationCtxOfBlockCtx + , guardCtx + , _bctxParentRankedBlockHash + , _bctxIsGenesis + , _bctxCurrentBlockHeight + , genesisEvaluationCtx + , bctxParentCreationTime + , bctxParentHash + , bctxParentHeight + , bctxChainId + , bctxMinerReward + + , PactServiceConfig(..) + , defaultPactServiceConfig + , BlockEnv(..) + , psBlockDbEnv + , psBlockCtx + + , Transactions(..) + , transactionPairs + , transactionCoinbase + , OffChainCommandResult + , OnChainCommandResult + , BlockInProgress(..) + , blockInProgressHandle + , blockInProgressBlockCtx + , blockInProgressRemainingGasLimit + , blockInProgressTransactions + , blockInProgressNumber + , toPayloadWithOutputs + , commandToBytes + , hashPactTxLogs + + , MemPoolAccess(..) + + , GasLogger + , GasSupply(..) + , RewindLimit(..) + , defaultReorgLimit + , defaultPreInsertCheckTimeout + + -- * default values + , noInfo + , noPublicMeta + , noSpanInfo + , emptyCapState + + , AssertValidateSigsError(..) + , displayAssertValidateSigsError + , AssertCommandError(..) + , displayAssertCommandError + + , LocalSignatureVerification(..) + , LocalPreflightSimulation(..) + , RewindDepth(..) + , ConfirmationDepth(..) + , LocalResult(..) + , _MetadataValidationFailure + , _LocalResultLegacy + , _LocalResultWithWarns + , _LocalTimeout + + , SpvRequest(..) + , TransactionOutputProofB64(..) + + , TxInvalidError(..) + , txInvalidErrorToOnChainPactError + , _BuyGasError + , _RedeemGasError + , _PurchaseGasTxTooBigForGasLimit + , _TxExceedsBlockGasLimit + , BlockInvalidError(..) + , BlockOutputMismatchError(..) + , BuyGasError(..) + , _BuyGasPactError + , _BuyGasMultipleGasPayerCaps + , RedeemGasError(..) + , _RedeemGasPactError + + , logg_ + , logDebug_ + , logInfo_ + , logWarn_ + , logError_ + + , PactTxFailureLog(..) + , GenesisConfig(..) + ) + where +import Control.Applicative ((<|>)) import Control.DeepSeq -import Control.Exception (asyncExceptionFromException, asyncExceptionToException) -import Control.Exception.Safe import Control.Lens -import Control.Monad -import Control.Monad.Reader -import Control.Monad.State.Strict - -import Data.Aeson hiding (Error,(.=)) -import Data.IORef +import Control.Monad.IO.Class +import Data.Aeson hiding (Error, (.=)) +import Data.Bool +import Data.ByteString (ByteString) +import Data.ByteString.Short qualified as SB +import Data.Decimal +import Data.List.NonEmpty qualified as NE import Data.LogMessage -import qualified Data.Map.Strict as M +import Data.Pool(Pool) import Data.Text (Text) -import qualified Data.Text as T -import qualified Data.Text.Encoding as T - +import Data.Text qualified as T +import Data.Text.Encoding qualified as T +import Data.Vector (Vector) +import Data.Word import GHC.Generics (Generic) - +import Language.Haskell.TH (mkName, nameBase) +import Pact.Core.Builtin qualified as Pact +import Pact.Core.Capabilities qualified as Pact +import Pact.Core.ChainData qualified as Pact +import Pact.Core.Errors qualified as Pact +import Pact.Core.Evaluate qualified as Pact +import Pact.Core.Gas.Types qualified as Pact +import Pact.Core.Hash qualified as Pact +import Pact.Core.Info qualified as Pact +import Pact.Core.Literal qualified as Pact +import Pact.Core.StableEncoding qualified as Pact +import Pact.JSON.Encode qualified as J import System.LogLevel --- internal pact modules - -import qualified Pact.Core.Builtin as Pact5 -import qualified Pact.Core.Errors as Pact5 -import qualified Pact.Core.Evaluate as Pact5 -import qualified Pact.Core.Pretty as Pact5 - --- internal chainweb modules - -import Chainweb.BlockHash import Chainweb.BlockHeader -import Chainweb.BlockHeight -import Chainweb.BlockHeaderDB -import Chainweb.ChainId +import Chainweb.BlockPayloadHash import Chainweb.Counter -import Chainweb.Mempool.Mempool (TransactionHash, BlockFill, MempoolPreBlockCheck, InsertError) -import Chainweb.Miner.Pact +import Chainweb.ForkState (ForkNumber, pact4ForkNumber) import Chainweb.Logger -import Chainweb.Pact.Backend.DbCache +import Chainweb.Pact.Mempool.Mempool +import Chainweb.Miner.Pact (Miner, toMinerData, noMiner) +import Chainweb.Pact.Backend.ChainwebPactDb import Chainweb.Pact.Backend.Types - -import Chainweb.Payload.PayloadStore +import Chainweb.Pact.Transaction qualified as Pact +import Chainweb.Pact4.ModuleCache +import Chainweb.Pact.Payload qualified as Chainweb +import Chainweb.Pact.Payload.PayloadStore +import Chainweb.PayloadProvider.P2P +import Chainweb.Storage.Table.Map import Chainweb.Time import Chainweb.Utils import Chainweb.Version -import Data.Word -import qualified Chainweb.Pact4.Transaction as Pact4 -import qualified Chainweb.Pact4.ModuleCache as Pact4 -import Data.Vector (Vector) -import qualified Chainweb.Pact5.Transaction as Pact5 -import Data.ByteString (ByteString) -import qualified Pact.Types.Persistence as Pact4 -import Data.Map (Map) -import qualified Pact.Core.Persistence as Pact5 -import Data.HashMap.Strict (HashMap) + +import Pact.Core.Command.Types qualified as Pact +import Pact.Core.Persistence qualified as Pact +import Servant.API import Data.List.NonEmpty (NonEmpty) -import qualified Pact.Core.Names as Pact5 -import GHC.Stack -import Streaming -import qualified Pact.Core.Command.Types as Pact5 -import qualified Pact.Types.Runtime as Pact4 -import qualified Pact.JSON.Encode as J -import Numeric.Natural -import qualified Pact.Types.Command as Pact4 -import qualified Pact.Types.Logger as Pact4 -import qualified Data.List.NonEmpty as NE +import Chainweb.PayloadProvider import Control.Concurrent.STM -import Chainweb.Payload -import Data.ByteString.Short (ShortByteString) -import qualified Data.ByteString.Short as SB -import qualified Data.Vector as V -import Data.Maybe +import Chainweb.BlockHeight +import Chainweb.BlockHash +import Chainweb.Parent +import Chainweb.MinerReward import Chainweb.BlockCreationTime -import qualified Data.Aeson as Aeson -import qualified Data.Text.Lazy as TL -import qualified Data.Text.Lazy.Encoding as TL +import Control.Concurrent.Async +import qualified Data.Aeson as A +import Control.Concurrent.MVar (MVar) - --- | Gather tx logs for a block, along with last tx for each --- key in history, if any --- Not intended for public API use; ToJSONs are for logging output. -data BlockTxHistory = BlockTxHistory - { _blockTxHistory :: !(Map Pact4.TxId [Pact5.TxLog Pact5.RowData]) - , _blockPrevHistory :: !(Map Pact4.RowKey (Pact5.TxLog Pact5.RowData)) - } - deriving (Eq,Generic) -instance Show BlockTxHistory where - show = show . fmap (show) . _blockTxHistory --- instance NFData BlockTxHistory -- TODO: add NFData for RowData - --- | A callback which writes a block's data to the input database snapshot, --- and knows its parent header (Nothing if it's a genesis block). --- Reports back its own header and some extra value. -data RunnableBlock logger a - = Pact4RunnableBlock (PactDbFor logger Pact4 -> Maybe ParentHeader -> IO (a, BlockHeader)) - | Pact5RunnableBlock (PactDbFor logger Pact5 -> Maybe ParentHeader -> BlockHandle Pact5 -> IO ((a, BlockHeader), BlockHandle Pact5)) - --- -------------------------------------------------------------------------- -- --- Coinbase output utils - --- -------------------------------------------------------------------- -- --- Local vs. Send execution context flag - -data ApplyCmdExecutionContext = ApplyLocal | ApplySend - -newtype BlockValidationFailureMsg = BlockValidationFailureMsg Text - deriving (Eq, Ord, Generic) - deriving newtype (Show, J.Encode) - -data CoinbaseFailure - = Pact4CoinbaseFailure !Text - | Pact5CoinbaseFailure !Pact5CoinbaseError - deriving stock (Eq, Show) - -instance J.Encode CoinbaseFailure where - build = \case - Pact4CoinbaseFailure e -> J.build e - Pact5CoinbaseFailure e -> J.build e - -data Pact5CoinbaseError - = CoinbasePactError !(Pact5.PactError Pact5.Info) - deriving stock (Eq, Show) - -instance J.Encode Pact5CoinbaseError where - build = \case - CoinbasePactError e -> J.object - [ "tag" J..= J.text "CoinbasePactError" - , "contents" J..= J.text (sshow e) - ] - -data Pact5RedeemGasError - = RedeemGasPactError !(Pact5.PactError Pact5.Info) - -- ^ Expected pact error - deriving stock (Eq, Show) -makePrisms ''Pact5RedeemGasError - -data Pact5BuyGasError - = BuyGasPactError !(Pact5.PactError Pact5.Info) - | BuyGasMultipleGasPayerCaps - deriving stock (Eq, Show) -makePrisms ''Pact5BuyGasError - -data Pact5GasPurchaseFailure - = BuyGasError !Pact5.RequestKey !Pact5BuyGasError - | RedeemGasError !Pact5.RequestKey !Pact5RedeemGasError - | PurchaseGasTxTooBigForGasLimit !Pact5.RequestKey - deriving stock (Eq, Show) -makePrisms ''Pact5GasPurchaseFailure - -prettyPact5GasPurchaseFailure :: Pact5GasPurchaseFailure -> Text -prettyPact5GasPurchaseFailure = \case - BuyGasError rk e -> sshow rk <> " Failed to buy gas: " <> case e of - BuyGasPactError err -> Pact5.renderText err - BuyGasMultipleGasPayerCaps -> "Multiple gas payer capabilities" - RedeemGasError rk e -> sshow rk <> " Failed to redeem gas: " <> case e of - RedeemGasPactError err -> Pact5.renderText err - PurchaseGasTxTooBigForGasLimit rk -> sshow rk <> " Failed to purchas gas: tx too big for gas limit" - -data Pact4GasPurchaseFailure = Pact4GasPurchaseFailure !TransactionHash !Pact4.PactError - deriving (Eq, Show) - -instance J.Encode Pact4GasPurchaseFailure where - build (Pact4GasPurchaseFailure h e) = J.build (J.Array (h, e)) - --- | Exceptions thrown by PactService components that --- are _not_ recorded in blockchain record. --- -data PactException - = BlockValidationFailure !BlockValidationFailureMsg - -- TODO: use this CallStack in the Show instance somehow, or the displayException impl. - | PactInternalError !CallStack !Text - | PactTransactionExecError !Pact4.PactHash !Text - | CoinbaseFailure !CoinbaseFailure - | NoBlockValidatedYet - | Pact4TransactionValidationException !(NonEmpty (Pact4.PactHash, Text)) - | Pact5TransactionValidationException !(NonEmpty (Pact5.Hash, Text)) - | Pact5GenesisCommandFailed !Pact5.Hash !Text - | Pact5GenesisCommandsInvalid ![InsertError] - | PactDuplicateTableError !Text - | TransactionDecodeFailure !Text - | RewindLimitExceeded - { _rewindExceededLimit :: !RewindLimit - -- ^ Rewind limit - , _rewindExceededLast :: !(Maybe BlockHeader) - -- ^ current header - , _rewindExceededTarget :: !(Maybe BlockHeader) - -- ^ target header - } - | BlockHeaderLookupFailure !Text - | Pact4BuyGasFailure !Pact4GasPurchaseFailure - | Pact5BuyGasFailure !Pact5GasPurchaseFailure - | MempoolFillFailure !Text - | BlockGasLimitExceeded !Pact4.Gas - | FullHistoryRequired - { _earliestBlockHeight :: !BlockHeight - , _genesisHeight :: !BlockHeight +data Transactions t r = Transactions + { _transactionPairs :: !(Vector (T2 t r)) + , _transactionCoinbase :: !r } - deriving stock (Generic) - deriving anyclass (Exception) - -instance Show PactException where - show = T.unpack . J.encodeText - -instance J.Encode PactException where - build (BlockValidationFailure msg) = tagged "BlockValidationFailure" msg - build (PactInternalError _stack msg) = tagged "PactInternalError" msg - build (PactTransactionExecError h msg) = tagged "PactTransactionExecError" (J.Array (h, msg)) - build (CoinbaseFailure msg) = tagged "CoinbaseFailure" msg - build NoBlockValidatedYet = tagged "NoBlockValidatedYet" J.null - build (Pact4TransactionValidationException l) = tagged "TransactionValidationException" (J.Array $ J.Array <$> l) - build (Pact5TransactionValidationException l) = tagged "TransactionValidationException" (J.Array $ J.Array <$> l) - build (PactDuplicateTableError msg) = tagged "PactDuplicateTableError" msg - build (TransactionDecodeFailure msg) = tagged "TransactionDecodeFailure" msg - build o@(RewindLimitExceeded{}) = tagged "RewindLimitExceeded" $ J.object - [ "_rewindExceededLimit" J..= J.Aeson (_rewindLimit $ _rewindExceededLimit o) - , "_rewindExceededLast" J..= J.encodeWithAeson (ObjectEncoded <$> _rewindExceededLast o) - , "_rewindExceededTarget" J..= J.encodeWithAeson (ObjectEncoded <$> _rewindExceededTarget o) - ] - build (BlockHeaderLookupFailure msg) = tagged "BlockHeaderLookupFailure" msg - build (Pact4BuyGasFailure failure) = tagged "BuyGasFailure" failure - build (Pact5BuyGasFailure failure) = tagged "BuyGasFailure" (sshow @_ @Text failure) - build (MempoolFillFailure msg) = tagged "MempoolFillFailure" msg - build (Pact5GenesisCommandFailed hash text) = tagged "BlockGasLimitExceeded" (J.Array $ [sshow @_ @Text hash, text]) - build (Pact5GenesisCommandsInvalid errs) = tagged "BlockGasLimitExceeded" (J.Array $ sshow @_ @Text <$> errs) - build (BlockGasLimitExceeded gas) = tagged "BlockGasLimitExceeded" gas - build o@(FullHistoryRequired{}) = tagged "FullHistoryRequired" $ J.object - [ "_fullHistoryRequiredEarliestBlockHeight" J..= J.Aeson @Int (fromIntegral $ _earliestBlockHeight o) - , "_fullHistoryRequiredGenesisHeight" J..= J.Aeson @Int (fromIntegral $ _genesisHeight o) - ] + deriving stock (Eq, Show, Functor, Foldable, Traversable, Generic) + deriving anyclass NFData -tagged :: J.Encode v => Text -> v -> J.Builder -tagged t v = J.object - [ "tag" J..= t - , "contents" J..= v - ] +makeLenses 'Transactions -instance Eq PactException where - BlockValidationFailure m == BlockValidationFailure m' = m == m' - PactInternalError _ m == PactInternalError _ m' = m == m' - PactTransactionExecError h m == PactTransactionExecError h' m' = - h == h' && m == m' - CoinbaseFailure e == CoinbaseFailure e' = e == e' - NoBlockValidatedYet == NoBlockValidatedYet = True - Pact4TransactionValidationException txs == Pact4TransactionValidationException txs' = - txs == txs' - Pact5TransactionValidationException txs == Pact5TransactionValidationException txs' = - txs == txs' - Pact5GenesisCommandFailed txHash err == Pact5GenesisCommandFailed txHash' err' = - txHash == txHash' && err == err' - Pact5GenesisCommandsInvalid errs == Pact5GenesisCommandsInvalid errs' = - errs == errs' - PactDuplicateTableError m == PactDuplicateTableError m' = - m == m' - TransactionDecodeFailure m == TransactionDecodeFailure m' = - m == m' - RewindLimitExceeded l lt t == RewindLimitExceeded l' lt' t' = - l == l' && lt == lt' && t == t' - BlockHeaderLookupFailure m == BlockHeaderLookupFailure m' = - m == m' - Pact4BuyGasFailure f == Pact4BuyGasFailure f' = f == f' - MempoolFillFailure m == MempoolFillFailure m' = m == m' - BlockGasLimitExceeded g == BlockGasLimitExceeded g' = g == g' - FullHistoryRequired e g == FullHistoryRequired e' g' = - e == e' && g == g' - _ == _ = False +data AssertValidateSigsError + = SignersAndSignaturesLengthMismatch + { _signersLength :: !Int + , _signaturesLength :: !Int + } + | InvalidSignerScheme + { _position :: !Int + } + | InvalidSignerWebAuthnPrefix + { _position :: !Int + } + | InvalidUserSig + { _position :: !Int + , _errMsg :: Text + } --- | Value that represents a limitation for rewinding. -newtype RewindLimit = RewindLimit { _rewindLimit :: Word64 } - deriving (Eq, Ord) - deriving newtype (Show, FromJSON, ToJSON, Enum, Bounded) +displayAssertValidateSigsError :: AssertValidateSigsError -> Text +displayAssertValidateSigsError = \case + SignersAndSignaturesLengthMismatch signersLength sigsLength -> + "The number of signers and signatures do not match. Number of signers: " <> sshow signersLength <> ". Number of signatures: " <> sshow sigsLength <> "." + InvalidSignerScheme pos -> + "The signer at position " <> sshow pos <> " has an invalid signature scheme." + InvalidSignerWebAuthnPrefix pos -> + "The signer at position " <> sshow pos <> " has an invalid WebAuthn prefix." + InvalidUserSig pos errMsg -> + "The signature at position " <> sshow pos <> " is invalid: " <> errMsg <> "." --- TODO: get rid of this shim, it's probably not necessary -data MemPoolAccess = MemPoolAccess - { mpaGetBlock - :: !(forall to. BlockFill - -> MempoolPreBlockCheck Pact4.UnparsedTransaction to - -> BlockHeight - -> BlockHash - -> BlockCreationTime - -> IO (Vector to) - ) - , mpaSetLastHeader :: !(BlockHeader -> IO ()) - , mpaProcessFork :: !(BlockHeader -> IO ()) - , mpaBadlistTx :: !(Vector TransactionHash -> IO ()) - } +data AssertCommandError + = InvalidPayloadHash + | AssertValidateSigsError AssertValidateSigsError -instance Semigroup MemPoolAccess where - MemPoolAccess f g h i <> MemPoolAccess t u v w = - MemPoolAccess (f <> t) (g <> u) (h <> v) (i <> w) +displayAssertCommandError :: AssertCommandError -> Text +displayAssertCommandError = \case + InvalidPayloadHash -> "The hash of the payload was invalid." + AssertValidateSigsError err -> displayAssertValidateSigsError err -instance Monoid MemPoolAccess where - mempty = MemPoolAccess mempty mempty mempty mempty +data SpvRequest = SpvRequest + { _spvRequestKey :: !Pact.RequestKey + , _spvTargetChainId :: !Pact.ChainId + } deriving (Eq, Show, Generic) +instance J.Encode SpvRequest where + build r = J.object + [ "requestKey" J..= _spvRequestKey r + , "targetChainId" J..= Pact._chainId (_spvTargetChainId r) + ] + {-# INLINE build #-} -data PactServiceEnv logger tbl = PactServiceEnv - { _psMempoolAccess :: !(Maybe MemPoolAccess) - , _psCheckpointer :: !(Checkpointer logger) - , _psPdb :: !(PayloadDb tbl) - , _psBlockHeaderDb :: !BlockHeaderDb - , _psMinerRewards :: !MinerRewards - , _psPreInsertCheckTimeout :: !Micros - -- ^ Maximum allowed execution time for the transactions validation. - , _psReorgLimit :: !RewindLimit - -- ^ The limit of checkpointer's rewind in the `execValidationBlock` command. - , _psOnFatalError :: !(forall a. PactException -> Text -> IO a) - , _psVersion :: !ChainwebVersion - , _psAllowReadsInLocal :: !Bool - , _psLogger :: !logger - , _psGasLogger :: !(Maybe logger) - - , _psBlockGasLimit :: !Pact4.GasLimit - - , _psEnableLocalTimeout :: !Bool - , _psTxFailuresCounter :: !(Maybe (Counter "txFailures")) - , _psTxTimeLimit :: !(Maybe Micros) - } -makeLenses ''PactServiceEnv +instance FromJSON SpvRequest where + parseJSON = withObject "SpvRequest" $ \o -> SpvRequest + <$> o .: "requestKey" + <*> fmap Pact.ChainId (o .: "targetChainId") + {-# INLINE parseJSON #-} -instance HasChainwebVersion (PactServiceEnv logger c) where - _chainwebVersion = _chainwebVersion . _psBlockHeaderDb - {-# INLINE _chainwebVersion #-} +newtype TransactionOutputProofB64 = TransactionOutputProofB64 Text + deriving stock (Eq, Show, Generic) + deriving newtype (ToJSON, FromJSON) -instance HasChainId (PactServiceEnv logger c) where - _chainId = _chainId . _psBlockHeaderDb - {-# INLINE _chainId #-} +-- | Value that represents a limitation for rewinding. +newtype RewindLimit = RewindLimit { _rewindLimit :: Word64 } + deriving (Eq, Ord) + deriving newtype (Show, FromJSON, ToJSON, Enum, Bounded) defaultReorgLimit :: RewindLimit defaultReorgLimit = RewindLimit 480 @@ -525,290 +277,6 @@ defaultReorgLimit = RewindLimit 480 defaultPreInsertCheckTimeout :: Micros defaultPreInsertCheckTimeout = 1000000 -- 1 second --- | Default limit for the per chain size of the decoded module cache. --- --- default limit: 60 MiB per chain --- -defaultModuleCacheLimit :: DbCacheLimitBytes -defaultModuleCacheLimit = DbCacheLimitBytes (60 * mebi) - --- | Externally-injected PactService properties. --- -data PactServiceConfig = PactServiceConfig - { _pactReorgLimit :: !RewindLimit - -- ^ Maximum allowed reorg depth, implemented as a rewind limit in validate. New block - -- hardcodes this to 8 currently. - , _pactPreInsertCheckTimeout :: !Micros - -- ^ Maximum allowed execution time for the transactions validation. - , _pactAllowReadsInLocal :: !Bool - -- ^ Allow direct database reads in local mode - , _pactQueueSize :: !Natural - -- ^ max size of pact internal queue. - , _pactResetDb :: !Bool - -- ^ blow away pact dbs - , _pactUnlimitedInitialRewind :: !Bool - -- ^ disable initial rewind limit - , _pactNewBlockGasLimit :: !Pact4.GasLimit - -- ^ the gas limit for new block creation, not for validation - , _pactLogGas :: !Bool - -- ^ whether to write transaction gas logs at INFO - , _pactModuleCacheLimit :: !DbCacheLimitBytes - -- ^ limit of the database module cache in bytes of corresponding row data - , _pactFullHistoryRequired :: !Bool - -- ^ Whether or not the node requires that the full Pact history be - -- available. Compaction can remove history. - , _pactEnableLocalTimeout :: !Bool - -- ^ Whether to enable the local timeout to prevent long-running transactions - , _pactPersistIntraBlockWrites :: !IntraBlockPersistence - -- ^ Whether or not the node requires that all writes made in a block - -- are persisted. Useful if you want to use PactService BlockTxHistory. - , _pactTxTimeLimit :: !(Maybe Micros) - -- ^ *Only affects Pact5* - -- Maximum allowed execution time for a single transaction. - -- If 'Nothing', it's a function of the BlockGasLimit. - } deriving (Eq,Show) - - --- | NOTE this is only used for tests/benchmarks. DO NOT USE IN PROD -testPactServiceConfig :: PactServiceConfig -testPactServiceConfig = PactServiceConfig - { _pactReorgLimit = defaultReorgLimit - , _pactPreInsertCheckTimeout = defaultPreInsertCheckTimeout - , _pactQueueSize = 1000 - , _pactResetDb = True - , _pactAllowReadsInLocal = False - , _pactUnlimitedInitialRewind = False - , _pactNewBlockGasLimit = testBlockGasLimit - , _pactLogGas = False - , _pactModuleCacheLimit = defaultModuleCacheLimit - , _pactFullHistoryRequired = False - , _pactEnableLocalTimeout = False - , _pactPersistIntraBlockWrites = DoNotPersistIntraBlockWrites - , _pactTxTimeLimit = Nothing - } - --- | This default value is only relevant for testing. In a chainweb-node the @GasLimit@ --- is initialized from the @_configBlockGasLimit@ value of @ChainwebConfiguration@. --- -testBlockGasLimit :: Pact4.GasLimit -testBlockGasLimit = 100000 - -newtype ReorgLimitExceeded = ReorgLimitExceeded Text - -instance Show ReorgLimitExceeded where - show (ReorgLimitExceeded t) = "reorg limit exceeded: \n" <> T.unpack t - -instance Exception ReorgLimitExceeded where - fromException = asyncExceptionFromException - toException = asyncExceptionToException - -newtype TxTimeout = TxTimeout TransactionHash - deriving Show -instance Exception TxTimeout - -data Pact4TxFailureLog = Pact4TxFailureLog !Pact4.RequestKey !Pact4.PactError !Text - deriving stock (Generic) - deriving anyclass (NFData, Typeable) -instance LogMessage Pact4TxFailureLog where - logText (Pact4TxFailureLog rk err msg) = - msg <> ": " <> sshow rk <> ": " <> sshow err -instance Show Pact4TxFailureLog where - show m = T.unpack (logText m) - -data Pact5TxFailureLog = Pact5TxFailureLog !Pact5.RequestKey !Text - deriving stock (Generic) - deriving anyclass (NFData, Typeable) -instance LogMessage Pact5TxFailureLog where - logText (Pact5TxFailureLog rk msg) = - "Failed tx " <> sshow rk <> ": " <> msg -instance Show Pact5TxFailureLog where - show m = T.unpack (logText m) - -defaultOnFatalError :: forall a. (LogLevel -> Text -> IO ()) -> PactException -> Text -> IO a -defaultOnFatalError lf pex t = do - lf Error errMsg - throw $ ReorgLimitExceeded errMsg - where - errMsg = T.pack (show pex) <> "\n" <> t - -type ModuleInitCache = M.Map BlockHeight Pact4.ModuleCache - -data PactServiceState = PactServiceState - { _psInitCache :: !ModuleInitCache - } - -makeLenses ''PactServiceState - -data PactBlockEnv logger pv tbl = PactBlockEnv - { _psServiceEnv :: !(PactServiceEnv logger tbl) - , _psParentHeader :: !ParentHeader - , _psIsGenesis :: !Bool - , _psBlockDbEnv :: !(PactDbFor logger pv) - } - -makeLenses ''PactBlockEnv - -instance HasChainwebVersion (PactBlockEnv logger db tbl) where - chainwebVersion = psServiceEnv . chainwebVersion -instance HasChainId (PactBlockEnv logger db tbl) where - chainId = psServiceEnv . chainId - --- | The top level monad of PactService, notably allowing access to a --- checkpointer and module init cache and some configuration parameters. -newtype PactServiceM logger tbl a = PactServiceM - { _unPactServiceM :: - ReaderT (PactServiceEnv logger tbl) (StateT PactServiceState IO) a - } deriving newtype - ( Functor, Applicative, Monad - , MonadReader (PactServiceEnv logger tbl) - , MonadState PactServiceState - , MonadThrow, MonadCatch, MonadMask - , MonadIO - ) - --- | Support lifting bracket style continuations in 'IO' into 'PactServiceM' by --- providing a function that allows unwrapping pact actions in IO while --- threading through the pact service state. --- --- /NOTE:/ This must not be used to access the pact service state from another --- thread. --- -withPactState - :: forall logger tbl b - . (Logger logger) - => ((forall a . PactServiceM logger tbl a -> IO a) -> IO b) - -> PactServiceM logger tbl b -withPactState inner = bracket captureState releaseState $ \ref -> do - e <- ask - liftIO $ inner $ \act -> mask $ \umask -> do - s <- readIORef ref - T2 r s' <- umask $ runPactServiceM s e act - writeIORef ref s' - return r - where - captureState = liftIO . newIORef =<< get - releaseState = liftIO . readIORef >=> put - --- | Run a 'PactServiceM' computation given some initial --- reader and state values, returning final value and --- final program state --- -runPactServiceM - :: PactServiceState - -> PactServiceEnv logger tbl - -> PactServiceM logger tbl a - -> IO (T2 a PactServiceState) -runPactServiceM st env act - = view (from _T2) - <$> runStateT (runReaderT (_unPactServiceM act) env) st - --- | Run a 'PactServiceM' computation given some initial --- reader and state values, discarding final state --- -evalPactServiceM - :: PactServiceState - -> PactServiceEnv logger tbl - -> PactServiceM logger tbl a - -> IO a -evalPactServiceM st env act - = evalStateT (runReaderT (_unPactServiceM act) env) st - --- | Run a 'PactServiceM' computation given some initial --- reader and state values, discarding final state --- -execPactServiceM - :: PactServiceState - -> PactServiceEnv logger tbl - -> PactServiceM logger tbl a - -> IO PactServiceState -execPactServiceM st env act - = execStateT (runReaderT (_unPactServiceM act) env) st - --- -------------------------------------------------------------------------- -- --- Pact Logger - -pactLogLevel :: String -> LogLevel -pactLogLevel "INFO" = Info -pactLogLevel "ERROR" = Error -pactLogLevel "DEBUG" = Debug -pactLogLevel "WARN" = Warn -pactLogLevel _ = Info - --- | Create Pact Loggers that use the the chainweb logging system as backend. --- -pactLoggers :: Logger logger => logger -> Pact4.Loggers -pactLoggers logger = Pact4.Loggers $ Pact4.mkLogger (error "ignored") fun (Pact4.LogRules mempty) - where - fun :: Pact4.LoggerLogFun - fun _ (Pact4.LogName n) cat msg = do - let namedLogger = addLabel ("logger", T.pack n) logger - logFunctionText namedLogger (pactLogLevel cat) $ T.pack msg - --- | Write log message --- -logg_ :: (MonadIO m, Logger logger) => logger -> LogLevel -> Text -> m () -logg_ logger level msg = liftIO $ logFunction logger level msg - --- | Write log message using the logger in Checkpointer environment - -logInfo_ :: (MonadIO m, Logger logger) => logger -> Text -> m () -logInfo_ l = logg_ l Info - -logWarn_ :: (MonadIO m, Logger logger) => logger -> Text -> m () -logWarn_ l = logg_ l Warn - -logError_ :: (MonadIO m, Logger logger) => logger -> Text -> m () -logError_ l = logg_ l Error - -logDebug_ :: (MonadIO m, Logger logger) => logger -> Text -> m () -logDebug_ l = logg_ l Debug - -logJsonTrace_ :: (MonadIO m, ToJSON a, Typeable a, NFData a, Logger logger) => logger -> LogLevel -> JsonLog a -> m () -logJsonTrace_ logger level msg = liftIO $ logFunction logger level msg - --- | Write log message using the logger in Checkpointer environment --- -logPact :: (Logger logger) => LogLevel -> Text -> PactServiceM logger tbl () -logPact level msg = view psLogger >>= \l -> logg_ l level msg - -logInfoPact :: (Logger logger) => Text -> PactServiceM logger tbl () -logInfoPact msg = view psLogger >>= \l -> logInfo_ l msg - -logWarnPact :: (Logger logger) => Text -> PactServiceM logger tbl () -logWarnPact msg = view psLogger >>= \l -> logWarn_ l msg - -logErrorPact :: (Logger logger) => Text -> PactServiceM logger tbl () -logErrorPact msg = view psLogger >>= \l -> logError_ l msg - -logDebugPact :: (Logger logger) => Text -> PactServiceM logger tbl () -logDebugPact msg = view psLogger >>= \l -> logDebug_ l msg - -logJsonTracePact :: (ToJSON a, Typeable a, NFData a, Logger logger) => LogLevel -> JsonLog a -> PactServiceM logger tbl () -logJsonTracePact level msg = view psLogger >>= \l -> logJsonTrace_ l level msg - -localLabelPact :: (Logger logger) => (Text, Text) -> PactServiceM logger tbl x -> PactServiceM logger tbl x -localLabelPact lbl x = do - locally psLogger (addLabel lbl) x - - -data PactServiceException = PactServiceIllegalRewind - { _attemptedRewindTo :: !(Maybe (BlockHeight, BlockHash)) - , _latestBlock :: !(Maybe (BlockHeight, BlockHash)) - } deriving (Generic) - -instance Show PactServiceException where - show (PactServiceIllegalRewind att l) - = concat - [ "illegal rewind attempt to block " - , show att - , ", latest was " - , show l - ] - -instance Exception PactServiceException - -makePrisms ''Historical - -- | Value that represents how far to go backwards while rewinding. newtype RewindDepth = RewindDepth { _rewindDepth :: Word64 } deriving (Eq, Ord) @@ -832,68 +300,16 @@ data LocalPreflightSimulation | LegacySimulation deriving stock (Eq, Show, Generic) + -- | The type of local results (used in /local endpoint) --- Internally contains a JsonText instead of a CommandResult for compatibility across Pact versions, --- but the constructors are hidden. --- This can be undone in the 2.28 release. -- data LocalResult = MetadataValidationFailure !(NE.NonEmpty Text) - | LocalResultLegacy !J.JsonText - | LocalResultWithWarns !J.JsonText ![Text] + | LocalResultLegacy !(Pact.CommandResult Pact.Hash Pact.PactOnChainError) + | LocalResultWithWarns !(Pact.CommandResult Pact.Hash Pact.PactOnChainError) ![Text] | LocalTimeout deriving stock (Generic, Show) -pattern ConvertLocalResultLegacy :: (FromJSON a, J.Encode a) => a -> LocalResult -pattern ConvertLocalResultLegacy cr <- LocalResultLegacy (Aeson.decode . TL.encodeUtf8 . TL.fromStrict . J.getJsonText -> Just cr) where - ConvertLocalResultLegacy cr = LocalResultLegacy (J.encodeJsonText cr) - -pattern Pact4LocalResultLegacy - :: Pact4.CommandResult Pact4.Hash - -> LocalResult -pattern Pact4LocalResultLegacy cr <- ConvertLocalResultLegacy cr where - Pact4LocalResultLegacy cr = ConvertLocalResultLegacy cr -_Pact4LocalResultLegacy :: Prism' LocalResult (Pact4.CommandResult Pact4.Hash) -_Pact4LocalResultLegacy = prism' Pact4LocalResultLegacy $ \case - Pact4LocalResultLegacy cr -> Just cr - _ -> Nothing - -pattern Pact5LocalResultLegacy - :: Pact5.CommandResult Pact5.Hash Pact5.PactOnChainError - -> LocalResult -pattern Pact5LocalResultLegacy cr <- ConvertLocalResultLegacy cr where - Pact5LocalResultLegacy cr = ConvertLocalResultLegacy cr -_Pact5LocalResultLegacy :: Prism' LocalResult (Pact5.CommandResult Pact5.Hash Pact5.PactOnChainError) -_Pact5LocalResultLegacy = prism' Pact5LocalResultLegacy $ \case - Pact5LocalResultLegacy cr -> Just cr - _ -> Nothing - -pattern ConvertLocalResultWithWarns :: (FromJSON a, J.Encode a) => a -> [Text] -> LocalResult -pattern ConvertLocalResultWithWarns cr warns <- LocalResultWithWarns (Aeson.decode . TL.encodeUtf8 . TL.fromStrict . J.getJsonText -> Just cr) warns where - ConvertLocalResultWithWarns cr warns = LocalResultWithWarns (J.encodeJsonText cr) warns - -pattern Pact4LocalResultWithWarns - :: Pact4.CommandResult Pact4.Hash - -> [Text] - -> LocalResult -pattern Pact4LocalResultWithWarns cr warns <- ConvertLocalResultWithWarns cr warns where - Pact4LocalResultWithWarns cr warns = ConvertLocalResultWithWarns cr warns -_Pact4LocalResultWithWarns :: Prism' LocalResult (Pact4.CommandResult Pact4.Hash, [Text]) -_Pact4LocalResultWithWarns = prism' (uncurry Pact4LocalResultWithWarns) $ \case - Pact4LocalResultWithWarns cr warns -> Just (cr, warns) - _ -> Nothing - -pattern Pact5LocalResultWithWarns - :: Pact5.CommandResult Pact5.Hash Pact5.PactOnChainError - -> [Text] - -> LocalResult -pattern Pact5LocalResultWithWarns cr warns <- ConvertLocalResultWithWarns cr warns where - Pact5LocalResultWithWarns cr warns = ConvertLocalResultWithWarns cr warns -_Pact5LocalResultWithWarns :: Prism' LocalResult (Pact5.CommandResult Pact5.Hash Pact5.PactOnChainError, [Text]) -_Pact5LocalResultWithWarns = prism' (uncurry Pact5LocalResultWithWarns) $ \case - Pact5LocalResultWithWarns cr warns -> Just (cr, warns) - _ -> Nothing - makePrisms ''LocalResult instance J.Encode LocalResult where @@ -919,439 +335,490 @@ instance FromJSON LocalResult where (\o -> metaFailureParser o <|> localWithWarnParser o - <|> pure (legacyFallbackParser o) + <|> legacyFallbackParser o ) v where metaFailureParser o = MetadataValidationFailure <$> o .: "preflightValidationFailure" localWithWarnParser o = LocalResultWithWarns - <$> (J.encodeJsonText @Value <$> o .: "preflightResult") + <$> o .: "preflightResult" <*> o .: "preflightWarnings" - legacyFallbackParser _ = LocalResultLegacy $ J.encodeJsonText v + legacyFallbackParser _ = LocalResultLegacy <$> parseJSON v + +type OnChainCommandResult = + Pact.CommandResult Pact.Hash Pact.PactOnChainError +type OffChainCommandResult = + Pact.CommandResult [Pact.TxLog ByteString] (Pact.PactError Pact.Info) + +-- | Pair parent header with transaction metadata. +-- In cases where there is no transaction/Command, 'PublicMeta' +-- default value is used. +data BlockCtx = BlockCtx + { _bctxParentCreationTime :: !(Parent BlockCreationTime) + , _bctxParentHash :: !(Parent BlockHash) + , _bctxParentHeight :: !(Parent BlockHeight) + , _bctxParentForkNumber :: !ForkNumber + , _bctxChainId :: !ChainId + , _bctxMinerReward :: !MinerReward + } deriving stock (Eq, Generic, Show) + +-- The lens for '_bctxParentForkNumber' is not generated because it is unused. +-- +makeLensesWith + (lensRules & lensField .~ \_ _ f -> + if nameBase f == "_bctxParentForkNumber" + then [] + else [TopName $ mkName $ dropWhile (== '_') $ nameBase f]) + ''BlockCtx + +instance ToJSON BlockCtx where + toJSON BlockCtx{..} = object + [ "parentCreationTime" A..= _bctxParentCreationTime + , "parentHash" A..= _bctxParentHash + , "parentHeight" A..= _bctxParentHeight + , "parentForkNumber" A..= _bctxParentForkNumber + , "chainId" A..= _bctxChainId + , "minerReward" A..= _bctxMinerReward + ] +blockCtxOfEvaluationCtx :: ChainId -> EvaluationCtx p -> BlockCtx +blockCtxOfEvaluationCtx cid ec = BlockCtx + { _bctxParentCreationTime = _evaluationCtxParentCreationTime ec + , _bctxParentHash = _evaluationCtxParentHash ec + , _bctxParentHeight = _evaluationCtxParentHeight ec + , _bctxParentForkNumber = _evaluationCtxParentForkNumber ec + , _bctxChainId = cid + , _bctxMinerReward = _evaluationCtxMinerReward ec + } --- | Used in tests for matching on JSON serialized pact exceptions --- -newtype PactExceptionTag = PactExceptionTag Text - deriving (Show, Eq) - -instance FromJSON PactExceptionTag where - parseJSON = withObject "PactExceptionTag" $ \o -> PactExceptionTag - <$> o .: "tag" - --- --- | Gather tx logs for a block, along with last tx for each --- --- key in history, if any --- --- Not intended for public API use; ToJSONs are for logging output. --- -data BlockTxHistory = BlockTxHistory --- - { _blockTxHistory :: !(Map TxId [TxLog RowData]) --- - , _blockPrevHistory :: !(Map RowKey (TxLog RowData)) --- - } --- - deriving (Eq,Generic) --- -instance Show BlockTxHistory where --- - show = show . fmap (J.encodeText . J.Array) . _blockTxHistory --- -instance NFData BlockTxHistory --- | Gather tx logs for a block, along with last tx for each --- key in history, if any --- Not intended for public API use; ToJSONs are for logging output. --- data BlockTxHistory = BlockTxHistory --- { _blockTxHistory :: !(Map TxId [Pact5.TxLog Pact5.RowData]) --- , _blockPrevHistory :: !(Map RowKey (Pact5.TxLog Pact5.RowData)) --- } --- deriving (Eq,Generic) --- instance Show BlockTxHistory where --- show = show . fmap (show) . _blockTxHistory --- TODO: fix show above --- instance NFData BlockTxHistory -- TODO: add NFData for RowData - -internalError :: (HasCallStack, MonadThrow m) => Text -> m a -internalError = throwM . PactInternalError callStack - -throwIfNoHistory :: (HasCallStack, MonadThrow m) => Historical a -> m a -throwIfNoHistory NoHistory = internalError "missing history" -throwIfNoHistory (Historical a) = return a - -data RequestCancelled = RequestCancelled - deriving (Eq, Show) -instance Exception RequestCancelled where - toException = asyncExceptionToException - fromException = asyncExceptionFromException - --- graph-easy < [ RequestNotStarted ] - cancelled -> [ RequestFailed ] --- > [ RequestNotStarted ] - started -> [ RequestInProgress ] --- > [ RequestInProgress ] - cancelled/failed -> [ RequestFailed ] --- > [ RequestInProgress ] - completed -> [ RequestDone ] --- > EOF --- --- +-------------------+ started +-------------------+ completed +-------------+ --- | RequestNotStarted | ------------------> | RequestInProgress | -----------> | RequestDone | --- +-------------------+ +-------------------+ +-------------+ --- | | --- | cancelled | --- v | --- +-------------------+ cancelled/failed | --- | RequestFailed | <---------------------+ --- +-------------------+ -data RequestStatus r - = RequestDone !r - | RequestInProgress - | RequestNotStarted - | RequestFailed !SomeException -data SubmittedRequestMsg - = forall r. SubmittedRequestMsg (RequestMsg r) (TVar (RequestStatus r)) -instance Show SubmittedRequestMsg where - show (SubmittedRequestMsg msg _) = show msg - -data RequestMsg r where - ContinueBlockMsg :: !(ContinueBlockReq pv) -> RequestMsg (Historical (BlockInProgress pv)) - NewBlockMsg :: !NewBlockReq -> RequestMsg (Historical (ForSomePactVersion BlockInProgress)) - ValidateBlockMsg :: !ValidateBlockReq -> RequestMsg PayloadWithOutputs - LocalMsg :: !LocalReq -> RequestMsg LocalResult - LookupPactTxsMsg :: !LookupPactTxsReq -> RequestMsg (HashMap ShortByteString (T2 BlockHeight BlockHash)) - PreInsertCheckMsg :: !PreInsertCheckReq -> RequestMsg (Vector (Maybe InsertError)) - BlockTxHistoryMsg :: !BlockTxHistoryReq -> RequestMsg (Historical BlockTxHistory) - HistoricalLookupMsg :: !HistoricalLookupReq -> RequestMsg (Historical (Maybe (Pact5.TxLog Pact5.RowData))) - SyncToBlockMsg :: !SyncToBlockReq -> RequestMsg () - ReadOnlyReplayMsg :: !ReadOnlyReplayReq -> RequestMsg () - CloseMsg :: RequestMsg () - -instance Show (RequestMsg r) where - show (NewBlockMsg req) = show req - show (ContinueBlockMsg req) = show req - show (ValidateBlockMsg req) = show req - show (LocalMsg req) = show req - show (LookupPactTxsMsg req) = show req - show (PreInsertCheckMsg req) = show req - show (BlockTxHistoryMsg req) = show req - show (HistoricalLookupMsg req) = show req - show (SyncToBlockMsg req) = show req - show (ReadOnlyReplayMsg req) = show req - show CloseMsg = "CloseReq" - -data NewBlockReq - = NewBlockReq - { _newBlockMiner :: !Miner - , _newBlockFill :: !NewBlockFill - -- ^ whether to fill this block with transactions; if false, the block - -- will be empty. - , _newBlockParent :: !ParentHeader - -- ^ the parent to use for the new block - } deriving stock Show - -data NewBlockFill = NewBlockFill | NewBlockEmpty - deriving stock Show - -data ContinueBlockReq pv - = ContinueBlockReq (BlockInProgress pv) -instance Show (ContinueBlockReq pv) where - showsPrec p (ContinueBlockReq bip) = - showParen (p > 10) $ - showString "ContinueBlockReq " . showsPrec 11 p . showString " " . - (case _blockInProgressPactVersion bip of {Pact4T -> showsPrec 11 bip; Pact5T -> showsPrec 11 bip}) - -data ValidateBlockReq = ValidateBlockReq - { _valBlockHeader :: !BlockHeader - , _valCheckablePayload :: !CheckablePayload - } deriving stock Show - -data LocalReq = LocalReq - { _localRequest :: !Pact4.UnparsedTransaction - , _localPreflight :: !(Maybe LocalPreflightSimulation) - , _localSigVerification :: !(Maybe LocalSignatureVerification) - , _localRewindDepth :: !(Maybe RewindDepth) - } -instance Show LocalReq where show LocalReq{..} = show _localRequest +evaluationCtxOfBlockCtx :: BlockCtx -> EvaluationCtx () +evaluationCtxOfBlockCtx bctx = EvaluationCtx + { _evaluationCtxParentCreationTime = _bctxParentCreationTime bctx + , _evaluationCtxParentHeight = _bctxParentHeight bctx + , _evaluationCtxParentForkNumber = _bctxParentForkNumber bctx + , _evaluationCtxParentHash = _bctxParentHash bctx + , _evaluationCtxMinerReward = _bctxMinerReward bctx + , _evaluationCtxPayload = () + } -data LookupPactTxsReq = LookupPactTxsReq - { _lookupConfirmationDepth :: !(Maybe ConfirmationDepth) - , _lookupKeys :: !(Vector ShortByteString) - } -instance Show LookupPactTxsReq where - show (LookupPactTxsReq m _) = - "LookupPactTxsReq@" ++ show m +guardCtx :: HasVersion => (ChainId -> BlockHeight -> a) -> BlockCtx -> a +guardCtx g txCtx = g (_chainId txCtx) (_bctxCurrentBlockHeight txCtx) -data PreInsertCheckReq = PreInsertCheckReq - { _preInsCheckTxs :: !(Vector (Pact4.Command (Pact4.PayloadWithText Pact4.PublicMeta Text))) - } -instance Show PreInsertCheckReq where - show (PreInsertCheckReq v) = - "PreInsertCheckReq@" ++ show v +instance HasChainId BlockCtx where + _chainId = _bctxChainId -data BlockTxHistoryReq = BlockTxHistoryReq - { _blockTxHistoryHeader :: !BlockHeader - , _blockTxHistoryDomain :: !(Pact5.Domain Pact5.RowKey Pact5.RowData Pact5.CoreBuiltin Pact5.Info) - } -instance Show BlockTxHistoryReq where - show (BlockTxHistoryReq h d) = - "BlockTxHistoryReq@" ++ show h ++ ", " ++ show d - -data HistoricalLookupReq = HistoricalLookupReq - { _historicalLookupHeader :: !BlockHeader - , _historicalLookupDomain :: !(Pact5.Domain Pact5.RowKey Pact5.RowData Pact5.CoreBuiltin Pact5.Info) - , _historicalLookupRowKey :: !Pact5.RowKey +_bctxIsGenesis :: HasVersion => BlockCtx -> Bool +_bctxIsGenesis bc = isGenesisBlockHeader' (_chainId bc) (_bctxParentHash bc) + +_bctxParentRankedBlockHash :: BlockCtx -> Parent RankedBlockHash +_bctxParentRankedBlockHash bc = Parent RankedBlockHash + { _rankedBlockHashHash = unwrapParent $ _bctxParentHash bc + , _rankedBlockHashHeight = unwrapParent $ _bctxParentHeight bc } -instance Show HistoricalLookupReq where - show (HistoricalLookupReq h d k) = - "HistoricalLookupReq@" ++ show h ++ ", " ++ show d ++ ", " ++ show k -data ReadOnlyReplayReq = ReadOnlyReplayReq - { _readOnlyReplayLowerBound :: !BlockHeader - , _readOnlyReplayUpperBound :: !(Maybe BlockHeader) - } -instance Show ReadOnlyReplayReq where - show (ReadOnlyReplayReq l u) = - "ReadOnlyReplayReq@" ++ show l ++ ", " ++ show u +_bctxCurrentBlockHeight :: HasVersion => BlockCtx -> BlockHeight +_bctxCurrentBlockHeight bc = + childBlockHeight (_chainId bc) (_bctxParentRankedBlockHash bc) -data SyncToBlockReq = SyncToBlockReq - { _syncToBlockHeader :: !BlockHeader - } -instance Show SyncToBlockReq where show SyncToBlockReq{..} = show _syncToBlockHeader -data SpvRequest = SpvRequest - { _spvRequestKey :: !Pact4.RequestKey - , _spvTargetChainId :: !Pact4.ChainId - } deriving (Eq, Show, Generic) +-- | Externally-injected PactService properties. +-- +data PactServiceConfig = PactServiceConfig + { _pactReorgLimit :: !RewindLimit + -- ^ Maximum allowed reorg depth, implemented as a rewind limit in validate. New block + -- hardcodes this to 8 currently. + -- + -- TODO: This is a property of consensus that is currently implemented on + -- payload provider level. It should be moved to consensus level. + -- + -- Payload providers only need to know how much history to keep, which must + -- be enough to satisfy the reorg limit. -instance J.Encode SpvRequest where - build r = J.object - [ "requestKey" J..= _spvRequestKey r - , "targetChainId" J..= _spvTargetChainId r - ] - {-# INLINE build #-} + , _pactPreInsertCheckTimeout :: !Micros + -- ^ Maximum allowed execution time for the transactions validation. + , _pactAllowReadsInLocal :: !Bool + -- ^ Allow direct database reads in local mode + , _pactUnlimitedInitialRewind :: !Bool + -- ^ disable initial rewind limit + -- + -- TODO: this property is only used for history replays, which should in the + -- future be separated from normal operation. So this should be not about + -- initial rewinds but rewind limits in general. -instance FromJSON SpvRequest where - parseJSON = withObject "SpvRequest" $ \o -> SpvRequest - <$> o .: "requestKey" - <*> o .: "targetChainId" - {-# INLINE parseJSON #-} + , _pactNewBlockGasLimit :: !Pact.GasLimit + -- ^ the gas limit for new block creation, not for validation + , _pactLogGas :: !Bool + -- ^ whether to write transaction gas logs at INFO + , _pactFullHistoryRequired :: !Bool + -- ^ Whether or not the node requires that the full Pact history be + -- available. Compaction can remove history. + , _pactEnableLocalTimeout :: !Bool + -- ^ Whether to enable the local timeout to prevent long-running transactions + , _pactTxTimeLimit :: !(Maybe Micros) + -- ^ *Only affects Pact5* + -- Maximum allowed execution time for a single transaction. + -- If 'Nothing', it's a function of the BlockGasLimit. + , _pactMiner :: !(Maybe Miner) + -- ^ The miner used to make new blocks. + , _pactBlockRefreshInterval :: !Micros + -- ^ How often to refresh blocks. + } deriving (Eq,Show) -newtype TransactionOutputProofB64 = TransactionOutputProofB64 Text - deriving stock (Eq, Show, Generic) - deriving newtype (ToJSON, FromJSON) +defaultPactServiceConfig :: PactServiceConfig +defaultPactServiceConfig = PactServiceConfig + { _pactReorgLimit = defaultReorgLimit + , _pactPreInsertCheckTimeout = defaultPreInsertCheckTimeout + , _pactAllowReadsInLocal = False + , _pactUnlimitedInitialRewind = False + , _pactNewBlockGasLimit = testBlockGasLimit + , _pactLogGas = False + , _pactFullHistoryRequired = False + , _pactEnableLocalTimeout = True + , _pactTxTimeLimit = Nothing + , _pactMiner = Just noMiner + , _pactBlockRefreshInterval = Micros 1_000_000 + } + +-- | This default value is only relevant for testing. In a chainweb-node the @GasLimit@ +-- is initialized from the @_configBlockGasLimit@ value of @ChainwebConfiguration@. +-- +testBlockGasLimit :: Pact.GasLimit +testBlockGasLimit = Pact.GasLimit $ Pact.Gas 100000 + +-- TODO: get rid of this shim, it's probably not necessary +data MemPoolAccess = MemPoolAccess + { mpaGetBlock + :: !(forall to + . BlockFill + -> MempoolPreBlockCheck Pact.Transaction to + -> EvaluationCtx () + -> IO (Vector to) + ) + , mpaProcessFork :: !((Vector Pact.Transaction, Vector Pact.Transaction) -> IO ()) + , mpaBadlistTx :: !(Vector TransactionHash -> IO ()) + } +instance Semigroup MemPoolAccess where + MemPoolAccess f g h <> MemPoolAccess t u v = + MemPoolAccess (f <> t) (g <> u) (h <> v) -data family ModuleCacheFor (pv :: PactVersion) -newtype instance ModuleCacheFor Pact4 - = Pact4ModuleCache Pact4.ModuleCache - deriving newtype (Eq, Show, Monoid, Semigroup) -data instance ModuleCacheFor Pact5 - = Pact5NoModuleCache - deriving (Eq, Show) -instance Monoid (ModuleCacheFor Pact5) where - mempty = Pact5NoModuleCache -instance Semigroup (ModuleCacheFor Pact5) where - _ <> _ = Pact5NoModuleCache +instance Monoid MemPoolAccess where + mempty = MemPoolAccess mempty mempty mempty + +-- TODO PP: this is really a cop-out. PactService is responsible for this, +-- there's no need to make it so open. Just find a good solution and stick with +-- it, like logging to a file, or returning to /local, or both. +type GasLogger = Pact.RequestKey -> [Pact.GasLogEntry Pact.CoreBuiltin Pact.Info] -> IO () + +data ServiceEnv tbl = ServiceEnv + { _psChainId :: ChainId + + , _psGasLogger :: Maybe GasLogger + -- ^ Used to emit gas logs of Pact code; gas logs are disabled if this is set to `Nothing`. + -- Gas logs have a non-zero cost, so usually this is disabled. + + , _psReadWriteSql :: SQLiteEnv + -- ^ Database connection used to mutate the Pact state. + , _psReadSqlPool :: Pool SQLiteEnv + , _psPdb :: PayloadStore (PayloadDb tbl) Chainweb.PayloadData + -- ^ Used to store payloads of validated blocks. + -- Contains outputs too. + , _psCandidatePdb :: MapTable RankedBlockPayloadHash Chainweb.PayloadData + -- ^ Used to store payloads of blocks that have not yet been validated. + + , _psMempoolAccess :: MemPoolAccess + -- ^ The mempool's limited interface as used by Pact. + , _psPreInsertCheckTimeout :: Micros + -- ^ Maximum allowed execution time for mempool transaction validation. + + , _psAllowReadsInLocal :: Bool + -- ^ Whether to allow reads of arbitrary tables in /local. + + , _psEnableLocalTimeout :: Bool + -- ^ Whether to have a timeout for /local calls. + , _psTxFailuresCounter :: Maybe (Counter "txFailures") + -- ^ Counter of the number of failed transactions. + , _psNewPayloadTxTimeLimit :: Maybe Micros + -- ^ Maximum amount of time to validate transactions while constructing payload. + -- If unset, defaults to a reasonable value based on the transaction's gas limit. + , _psMiner :: Maybe Miner + -- ^ Miner identity for use in newly mined blocks. + , _psMiningPayloadVar :: TMVar (Async (), BlockInProgress) + -- ^ Latest mining payload produced, and block continuation thread. + , _psNewBlockGasLimit :: Pact.GasLimit + -- ^ Block gas limit in newly produced blocks. + , _psGenesisPayload :: Maybe Chainweb.PayloadWithOutputs + -- ^ The genesis payload for this chain. + , _psBlockRefreshInterval :: Micros + , _psModuleInitCacheVar :: MVar ModuleInitCache + } + +instance HasChainId (ServiceEnv tbl) where + _chainId = _psChainId + {-# INLINE _chainId #-} + +data BlockEnv = BlockEnv + { _psBlockCtx :: !BlockCtx + , _psBlockDbEnv :: !ChainwebPactDb + } -type family CommandResultFor (pv :: PactVersion) where - CommandResultFor Pact4 = Pact4.CommandResult [Pact4.TxLogJson] - CommandResultFor Pact5 = Pact5.CommandResult [Pact5.TxLog ByteString] (Pact5.PactError Pact5.Info) +instance HasChainId BlockEnv where + _chainId = _chainId . _psBlockCtx + +-- the evaluation context for the genesis block; note that the payload is filled in +genesisEvaluationCtx :: HasVersion => ServiceEnv tbl -> EvaluationCtx ConsensusPayload +genesisEvaluationCtx serviceEnv = EvaluationCtx + { _evaluationCtxParentCreationTime = Parent $ implicitVersion ^?! versionGenesis . genesisTime . atChain cid + , _evaluationCtxParentHash = genesisParentBlockHash cid + , _evaluationCtxParentHeight = Parent $ genesisHeight cid + , _evaluationCtxParentForkNumber = pact4ForkNumber + -- should not be used + , _evaluationCtxMinerReward = MinerReward 0 + , _evaluationCtxPayload = ConsensusPayload + { _consensusPayloadHash = genesisBlockPayloadHash cid + , _consensusPayloadData = + EncodedPayloadData . Chainweb.encodePayloadData . Chainweb.payloadWithOutputsToPayloadData + <$> _psGenesisPayload serviceEnv + } + } + where + cid = _chainId serviceEnv -- State from a block in progress, which is used to extend blocks after -- running their payloads. -data BlockInProgress pv = BlockInProgress - { _blockInProgressHandle :: !(BlockHandle pv) - , _blockInProgressModuleCache :: !(ModuleCacheFor pv) - , _blockInProgressParentHeader :: !(Maybe ParentHeader) - , _blockInProgressChainwebVersion :: !ChainwebVersion - , _blockInProgressChainId :: !ChainId - , _blockInProgressRemainingGasLimit :: !Pact4.GasLimit - , _blockInProgressMiner :: !Miner - , _blockInProgressTransactions :: !(Transactions pv (CommandResultFor pv)) - , _blockInProgressPactVersion :: !(PactVersionT pv) +data BlockInProgress = BlockInProgress + { _blockInProgressHandle :: !BlockHandle + , _blockInProgressBlockCtx :: !BlockCtx + , _blockInProgressRemainingGasLimit :: !Pact.GasLimit + , _blockInProgressTransactions :: !(Transactions Chainweb.Transaction OffChainCommandResult) + , _blockInProgressNumber :: !Int + -- ^ identifier sequentially increasing for the same given BlockCtx, to + -- indicate "freshness" to the miner } -instance Eq (BlockInProgress pv) where +makeLenses ''ServiceEnv +makeLenses ''BlockInProgress + +instance Eq BlockInProgress where bip == bip' = - case (_blockInProgressPactVersion bip, _blockInProgressPactVersion bip') of - (Pact4T, Pact4T) -> - _blockInProgressHandle bip == _blockInProgressHandle bip' && - _blockInProgressModuleCache bip == _blockInProgressModuleCache bip' && - _blockInProgressParentHeader bip == _blockInProgressParentHeader bip' && - _blockInProgressRemainingGasLimit bip == _blockInProgressRemainingGasLimit bip' && - _blockInProgressMiner bip == _blockInProgressMiner bip' && - _blockInProgressTransactions bip == _blockInProgressTransactions bip' - (Pact5T, Pact5T) -> - _blockInProgressHandle bip == _blockInProgressHandle bip' && - _blockInProgressModuleCache bip == _blockInProgressModuleCache bip' && - _blockInProgressParentHeader bip == _blockInProgressParentHeader bip' && - _blockInProgressRemainingGasLimit bip == _blockInProgressRemainingGasLimit bip' && - _blockInProgressMiner bip == _blockInProgressMiner bip' && - _blockInProgressTransactions bip == _blockInProgressTransactions bip' - -instance HasChainwebVersion (BlockInProgress pv) where - _chainwebVersion = _blockInProgressChainwebVersion - {-# INLINE _chainwebVersion #-} - -instance HasChainId (BlockInProgress pv) where - _chainId = _blockInProgressChainId + _blockInProgressHandle bip == _blockInProgressHandle bip' && + _blockInProgressBlockCtx bip == _blockInProgressBlockCtx bip' && + _blockInProgressRemainingGasLimit bip == _blockInProgressRemainingGasLimit bip' && + _blockInProgressTransactions bip == _blockInProgressTransactions bip' + +instance HasChainId BlockInProgress where + _chainId = _chainId . _blockInProgressBlockCtx {-# INLINE _chainId #-} -blockInProgressParent :: BlockInProgress pv -> (BlockHash, BlockHeight, BlockCreationTime) -blockInProgressParent bip = - maybe - (genesisParentBlockHash v cid, genesisHeight v cid, v ^?! versionGenesis . genesisTime . atChain cid) - (\bh -> (view blockHash bh, view blockHeight bh, view blockCreationTime bh)) - (_parentHeader <$> _blockInProgressParentHeader bip) - where - v = _blockInProgressChainwebVersion bip - cid = _blockInProgressChainId bip - -instance Show (BlockInProgress pv) where - show bip = unwords - [ case _blockInProgressPactVersion bip of - Pact4T -> - "Pact4 block," - Pact5T -> - "Pact5 block," - , T.unpack (blockHashToTextShort $ fromMaybe - (genesisParentBlockHash (_blockInProgressChainwebVersion bip) (_blockInProgressChainId bip)) - (view blockHash . _parentHeader <$> _blockInProgressParentHeader bip)) - , show (_blockInProgressMiner bip ^. minerId) - , "# transactions " <> show (V.length (_transactionPairs $ _blockInProgressTransactions bip)) <> "," - , "# gas remaining " <> show (_blockInProgressRemainingGasLimit bip) - ] +makeLenses ''BlockEnv + +-- | Indicates a computed gas charge (gas amount * gas price) +newtype GasSupply = GasSupply { _pact5GasSupply :: Decimal } + deriving (Eq,Ord) + deriving newtype (Num,Real,Fractional) + +instance J.Encode GasSupply where + build = J.build . Pact.StableEncoding . Pact.LDecimal . _pact5GasSupply +instance Show GasSupply where show (GasSupply g) = show g + +-- -------------------------------------------------------------------------- -- +-- Default Values +-- +-- TODO: move to Pact5 + +noInfo :: Pact.Info +noInfo = Pact.LineInfo 0 + +emptyCapState :: Ord name => Ord v => Pact.CapState name v +emptyCapState = Pact.CapState mempty mempty mempty mempty mempty -finalizeBlock :: BlockInProgress pv -> PayloadWithOutputs -finalizeBlock bip = - toPayloadWithOutputs - (_blockInProgressPactVersion bip) - (_blockInProgressMiner bip) - (_blockInProgressTransactions bip) - -pact4CommandToBytes :: Pact4.Command Text -> Transaction -pact4CommandToBytes cwTrans = - let plBytes = J.encodeStrict cwTrans - in Transaction { _transactionBytes = plBytes } - -pact4CommandResultToBytes :: Pact4.CommandResult Pact4.Hash -> TransactionOutput -pact4CommandResultToBytes cr = - let outBytes = J.encodeStrict cr - in TransactionOutput { _transactionOutputBytes = outBytes } - -hashPact4TxLogs :: Pact4.CommandResult [Pact4.TxLogJson] -> Pact4.CommandResult Pact4.Hash -hashPact4TxLogs = over (Pact4.crLogs . _Just) $ Pact4.pactHash . Pact4.encodeTxLogJsonArray - -pact5CommandToBytes :: Pact5.Command Text -> Transaction -pact5CommandToBytes tx = Transaction - { _transactionBytes = - J.encodeStrict tx +noSpanInfo :: Pact.SpanInfo +noSpanInfo = Pact.SpanInfo 0 0 0 0 + +noPublicMeta :: Pact.PublicMeta +noPublicMeta = Pact.PublicMeta + { Pact._pmChainId = Pact.ChainId "" + , Pact._pmSender = "" + , Pact._pmGasLimit = Pact.GasLimit (Pact.Gas 0) + , Pact._pmGasPrice = Pact.GasPrice 0 + , Pact._pmTTL = Pact.TTLSeconds 0 + , Pact._pmCreationTime = Pact.TxCreationTime 0 + } + +data BuyGasError + = BuyGasPactError !(Pact.PactError Pact.Info) + | BuyGasMultipleGasPayerCaps + deriving stock (Show, Eq, Generic) + +makePrisms ''BuyGasError + +data RedeemGasError + = RedeemGasPactError !(Pact.PactError Pact.Info) + deriving stock (Show, Eq, Generic) + +makePrisms ''RedeemGasError + +data TxInvalidError + = BuyGasError !BuyGasError + | RedeemGasError !RedeemGasError + | PurchaseGasTxTooBigForGasLimit + | TxExceedsBlockGasLimit + deriving stock (Show, Eq, Generic) + +-- | Convert an error that would make a transaction invalid, into an error that can be +-- returned to the user. Note that outputs from here do not make it on-chain ever. +txInvalidErrorToOnChainPactError :: TxInvalidError -> Pact.PactOnChainError +txInvalidErrorToOnChainPactError = \case + BuyGasError err -> + prefixMsg "Failed to buy gas:" $ + buyGasErrorToOnChainPactError err + RedeemGasError (RedeemGasPactError err) -> + prefixMsg "Failed to redeem gas:" $ + Pact.pactErrorToOnChainError err + PurchaseGasTxTooBigForGasLimit -> Pact.PactOnChainError + { _peType = Pact.ErrorType "EvalError" + , _peMsg = "gas limit too low to even begin evaluation" + , _peInfo = Pact.LocatedErrorInfo Pact.TopLevelErrorOrigin (Pact.LineInfo 0) + } + TxExceedsBlockGasLimit {} -> Pact.PactOnChainError + { _peType = Pact.ErrorType "EvalError" + , _peMsg = "tx gas limit taken with other block txs exceeds block gas limit" + , _peInfo = Pact.LocatedErrorInfo Pact.TopLevelErrorOrigin (Pact.LineInfo 0) + } + where + buyGasErrorToOnChainPactError (BuyGasPactError err) = Pact.pactErrorToOnChainError err + buyGasErrorToOnChainPactError BuyGasMultipleGasPayerCaps = Pact.PactOnChainError + { _peType = Pact.ErrorType "EvalError" + , _peMsg = "multiple gas payer capabilities in signers list" + , _peInfo = Pact.LocatedErrorInfo Pact.TopLevelErrorOrigin (Pact.LineInfo 0) + } + prefixMsg p err = + err + { Pact._peMsg = Pact.mkBoundedText $ + T.unwords [p, Pact._boundedText (Pact._peMsg err) ] + } + +makePrisms ''TxInvalidError + +data BlockInvalidError + = BlockInvalidDueToOutputMismatch BlockOutputMismatchError + | BlockInvalidDueToInvalidTxs (NonEmpty (Pact.RequestKey, InsertError)) + | BlockInvalidDueToInvalidTxAtRuntime TxInvalidError + | BlockInvalidDueToTxDecodeFailure [Text] + | BlockInvalidDueToCoinbaseFailure (Pact.PactError Pact.Info) + deriving stock (Show, Generic) + +data BlockOutputMismatchError = BlockOutputMismatchError + { blockOutputMismatchCtx :: !BlockCtx + , blockOutputMismatchActualPayload :: !Chainweb.PayloadWithOutputs + , blockOutputMismatchExpectedPayload :: !Chainweb.CheckablePayload } --- | This function converts CommandResults into bytes in a stable way that can --- be stored on-chain. -pact5CommandResultToBytes :: Pact5.CommandResult Pact5.Hash (Pact5.PactError Pact5.Info) -> ByteString -pact5CommandResultToBytes cr = - J.encodeStrict (fmap Pact5.pactErrorToOnChainError cr) +instance Show BlockOutputMismatchError where + show = T.unpack . J.encodeText + +instance J.Encode BlockOutputMismatchError where + build bvf = J.object + [ "ctx" J..= J.encodeWithAeson (blockOutputMismatchCtx bvf) + , "actual" J..= J.encodeWithAeson (blockOutputMismatchActualPayload bvf) + , "expected" J..= J.encodeWithAeson (blockOutputMismatchExpectedPayload bvf) + ] -convertPact5Error :: Pact5.PactError Pact5.Info -> Pact5.PactOnChainError -convertPact5Error err = - Pact5.pactErrorToOnChainError err +-- | Write log message +-- +logg_ :: (MonadIO m, Logger logger) => logger -> LogLevel -> Text -> m () +logg_ logger level msg = liftIO $ logFunction logger level msg -hashPact5TxLogs :: Pact5.CommandResult [Pact5.TxLog ByteString] err -> Pact5.CommandResult Pact5.Hash err -hashPact5TxLogs cr = cr & over (Pact5.crLogs . _Just) - (\ls -> Pact5.hashTxLogs ls) +-- | Write log message using the logger in Checkpointer environment -toPayloadWithOutputs :: PactVersionT pv -> Miner -> Transactions pv (CommandResultFor pv) -> PayloadWithOutputs -toPayloadWithOutputs Pact4T mi ts = - let oldSeq = _transactionPairs ts - trans = cmdBSToTx . fst <$> oldSeq - transOuts = pact4CommandResultToBytes . hashPact4TxLogs . snd <$> oldSeq +logInfo_ :: (MonadIO m, Logger logger) => logger -> Text -> m () +logInfo_ l = logg_ l Info - miner = toMinerData mi - cb = CoinbaseOutput $ J.encodeStrict $ hashPact4TxLogs $ _transactionCoinbase ts - blockTrans = snd $ newBlockTransactions miner trans - cmdBSToTx = pact4CommandToBytes - . fmap (T.decodeUtf8 . SB.fromShort . Pact4.payloadBytes) - blockOuts = snd $ newBlockOutputs cb transOuts - - blockPL = blockPayload blockTrans blockOuts - plData = payloadData blockTrans blockPL - in payloadWithOutputs plData cb transOuts -toPayloadWithOutputs Pact5T mi ts = +logWarn_ :: (MonadIO m, Logger logger) => logger -> Text -> m () +logWarn_ l = logg_ l Warn + +logError_ :: (MonadIO m, Logger logger) => logger -> Text -> m () +logError_ l = logg_ l Error + +logDebug_ :: (MonadIO m, Logger logger) => logger -> Text -> m () +logDebug_ l = logg_ l Debug + +-- | This function converts CommandResults into bytes in a stable way that can +-- be stored on-chain. +pactCommandResultToBytes :: Pact.CommandResult Pact.Hash (Pact.PactError Pact.Info) -> ByteString +pactCommandResultToBytes cr = + J.encodeStrict (fmap Pact.pactErrorToOnChainError cr) + +hashPactTxLogs :: Pact.CommandResult [Pact.TxLog ByteString] err -> Pact.CommandResult Pact.Hash err +hashPactTxLogs cr = cr & over (Pact.crLogs . _Just) + (\ls -> Pact.hashTxLogs ls) + +commandToBytes :: Pact.Transaction -> Chainweb.Transaction +commandToBytes = Chainweb.Transaction . J.encodeStrict + . fmap (T.decodeUtf8 . SB.fromShort . view Pact.payloadBytes) + +toPayloadWithOutputs + :: Miner + -> Transactions Chainweb.Transaction OffChainCommandResult + -> Chainweb.PayloadWithOutputs +toPayloadWithOutputs mi ts = let - oldSeq :: Vector (TransactionFor Pact5, CommandResultFor Pact5) + oldSeq :: Vector (T2 Chainweb.Transaction OffChainCommandResult) oldSeq = _transactionPairs ts - trans :: Vector Transaction - trans = cmdBSToTx . fst <$> oldSeq - transOuts :: Vector TransactionOutput - transOuts = TransactionOutput . pact5CommandResultToBytes . hashPact5TxLogs . snd <$> oldSeq + trans :: Vector Chainweb.Transaction + trans = sfst <$> oldSeq + transOuts :: Vector Chainweb.TransactionOutput + transOuts = Chainweb.TransactionOutput . pactCommandResultToBytes . hashPactTxLogs . ssnd <$> oldSeq - miner :: MinerData + miner :: Chainweb.MinerData miner = toMinerData mi - cb :: CoinbaseOutput - cb = CoinbaseOutput $ pact5CommandResultToBytes $ hashPact5TxLogs $ _transactionCoinbase ts - blockTrans :: BlockTransactions - blockTrans = snd $ newBlockTransactions miner trans - cmdBSToTx :: Pact5.Transaction -> Transaction - cmdBSToTx = pact5CommandToBytes - . fmap (T.decodeUtf8 . SB.fromShort . view Pact5.payloadBytes) - blockOuts :: BlockOutputs - blockOuts = snd $ newBlockOutputs cb transOuts - - blockPL :: BlockPayload - blockPL = blockPayload blockTrans blockOuts - plData :: PayloadData - plData = payloadData blockTrans blockPL - in payloadWithOutputs plData cb transOuts - -type family TransactionFor (pv :: PactVersion) where - TransactionFor Pact4 = Pact4.Transaction - TransactionFor Pact5 = Pact5.Transaction - -data Transactions (pv :: PactVersion) r = Transactions - { _transactionPairs :: !(Vector (TransactionFor pv, r)) - , _transactionCoinbase :: !(CommandResultFor pv) - } - deriving stock (Functor, Foldable, Traversable, Generic) -deriving stock instance Eq r => Eq (Transactions Pact4 r) -deriving stock instance Eq r => Eq (Transactions Pact5 r) -deriving stock instance Show r => Show (Transactions Pact4 r) -deriving stock instance Show r => Show (Transactions Pact5 r) -deriving anyclass instance NFData r => NFData (Transactions Pact4 r) --- why doesn't this compile? --- deriving anyclass instance NFData r => NFData (Transactions Pact5 r) -instance NFData r => NFData (Transactions Pact5 r) where - rnf txs = - rnf (_transactionPairs txs) - `seq` rnf (_transactionCoinbase) + cb :: Chainweb.CoinbaseOutput + cb = Chainweb.CoinbaseOutput $ pactCommandResultToBytes $ hashPactTxLogs $ _transactionCoinbase ts + blockTrans :: Chainweb.BlockTransactions + blockTrans = snd $ Chainweb.newBlockTransactions miner trans + blockOuts :: Chainweb.BlockOutputs + blockOuts = snd $ Chainweb.newBlockOutputs cb transOuts + + blockPL :: Chainweb.BlockPayload + blockPL = Chainweb.blockPayload blockTrans blockOuts + plData :: Chainweb.PayloadData + plData = Chainweb.payloadData blockTrans blockPL + in Chainweb.payloadWithOutputs plData cb transOuts + +data PactTxFailureLog = PactTxFailureLog !Pact.RequestKey !Text + deriving stock (Generic) + deriving anyclass (NFData) +instance LogMessage PactTxFailureLog where + logText (PactTxFailureLog rk msg) = + "Failed tx " <> sshow rk <> ": " <> msg +instance Show PactTxFailureLog where + show m = T.unpack (logText m) -makeLenses 'Transactions -makeLenses 'BlockInProgress +instance ToHttpApiData LocalPreflightSimulation where + toUrlPiece PreflightSimulation = toUrlPiece True + toUrlPiece LegacySimulation = toUrlPiece False -data AssertValidateSigsError - = SignersAndSignaturesLengthMismatch - { _signersLength :: !Int - , _signaturesLength :: !Int - } - | InvalidSignerScheme - { _position :: !Int - } - | InvalidSignerWebAuthnPrefix - { _position :: !Int - } - | InvalidUserSig - { _position :: !Int - , _errMsg :: Text - } +instance FromHttpApiData LocalPreflightSimulation where + parseUrlPiece = fmap (bool LegacySimulation PreflightSimulation) . parseUrlPiece -displayAssertValidateSigsError :: AssertValidateSigsError -> Text -displayAssertValidateSigsError = \case - SignersAndSignaturesLengthMismatch signersLength sigsLength -> - "The number of signers and signatures do not match. Number of signers: " <> sshow signersLength <> ". Number of signatures: " <> sshow sigsLength <> "." - InvalidSignerScheme pos -> - "The signer at position " <> sshow pos <> " has an invalid signature scheme." - InvalidSignerWebAuthnPrefix pos -> - "The signer at position " <> sshow pos <> " has an invalid WebAuthn prefix." - InvalidUserSig pos errMsg -> - "The signature at position " <> sshow pos <> " is invalid: " <> errMsg <> "." +instance ToHttpApiData LocalSignatureVerification where + toUrlPiece Verify = toUrlPiece True + toUrlPiece NoVerify = toUrlPiece False -data AssertCommandError - = InvalidPayloadHash - | AssertValidateSigsError AssertValidateSigsError +instance FromHttpApiData LocalSignatureVerification where + parseUrlPiece = fmap (bool NoVerify Verify) . parseUrlPiece -displayAssertCommandError :: AssertCommandError -> Text -displayAssertCommandError = \case - InvalidPayloadHash -> "The hash of the payload was invalid." - AssertValidateSigsError err -> displayAssertValidateSigsError err +deriving newtype instance FromHttpApiData RewindDepth + +deriving newtype instance ToHttpApiData RewindDepth + +deriving newtype instance FromHttpApiData ConfirmationDepth + +deriving newtype instance ToHttpApiData ConfirmationDepth + +data GenesisConfig + = GeneratingGenesis + | GenesisNotNeeded + | GenesisPayload Chainweb.PayloadWithOutputs diff --git a/src/Chainweb/Pact/Utils.hs b/src/Chainweb/Pact/Utils.hs index c42ad1e1e7..5a7fc1a4ac 100644 --- a/src/Chainweb/Pact/Utils.hs +++ b/src/Chainweb/Pact/Utils.hs @@ -1,4 +1,5 @@ {-# LANGUAGE BangPatterns #-} +{-# LANGUAGE ImportQualifiedPost #-} {-# LANGUAGE OverloadedStrings #-} -- | @@ -29,27 +30,21 @@ module Chainweb.Pact.Utils ) where import Data.Aeson -import qualified Data.Text as T - +import Data.Text qualified as T import Control.Monad.Catch - -import Pact.Parse -import qualified Pact.Types.ChainId as P -import qualified Pact.Types.Term as P -import Pact.Types.ChainMeta -import Pact.Types.KeySet (ed25519HexFormat) - -import qualified Pact.JSON.Encode as J - --- Internal modules - +import Pact.JSON.Encode qualified as J import Chainweb.ChainId import Chainweb.Miner.Pact -import Chainweb.Payload +import Chainweb.Pact.Payload import Chainweb.Time +import Pact.Core.ChainData qualified as P +import Pact.Core.Guards qualified as P +import Pact.Core.Guards (ed25519HexFormat) +import Data.Set qualified as Set +import Chainweb.Utils (fromTextM) fromPactChainId :: MonadThrow m => P.ChainId -> m ChainId -fromPactChainId (P.ChainId t) = chainIdFromText t +fromPactChainId (P.ChainId t) = fromTextM t -- | This is the recursion principle of an 'Aeson' 'Result' of type 'a'. -- Similar to 'either', 'maybe', or 'bool' combinators @@ -58,9 +53,9 @@ aeson :: (String -> b) -> (a -> b) -> Result a -> b aeson f _ (Error a) = f a aeson _ g (Success a) = g a -toTxCreationTime :: Time Micros -> TxCreationTime +toTxCreationTime :: Time Micros -> P.TxCreationTime toTxCreationTime (Time timespan) = - TxCreationTime $ ParsedInteger $ fromIntegral $ timeSpanToSeconds timespan + P.TxCreationTime $ fromIntegral $ timeSpanToSeconds timespan @@ -90,7 +85,7 @@ generateKAccountFromPubKey pubKey -- is valid. -- Note: We are assuming the k: account is ED25519. pubKeyToKAccountKeySet :: P.PublicKeyText -> P.KeySet -pubKeyToKAccountKeySet pubKey = P.mkKeySet [pubKey] "keys-all" +pubKeyToKAccountKeySet pubKey = P.KeySet (Set.singleton pubKey) P.KeysAll generateKeySetFromKAccount :: T.Text -> Maybe P.KeySet generateKeySetFromKAccount kacct = do diff --git a/src/Chainweb/Pact5/Validations.hs b/src/Chainweb/Pact/Validations.hs similarity index 64% rename from src/Chainweb/Pact5/Validations.hs rename to src/Chainweb/Pact/Validations.hs index bdafd74796..772be6236c 100644 --- a/src/Chainweb/Pact5/Validations.hs +++ b/src/Chainweb/Pact/Validations.hs @@ -1,8 +1,10 @@ {-# LANGUAGE DataKinds #-} +{-# LANGUAGE ImportQualifiedPost #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeApplications #-} + -- | --- Module: Chainweb.Pact5.Validations +-- Module: Chainweb.Pact.Validations -- Copyright: Copyright © 2018,2019,2020,2021,2022 Kadena LLC. -- License: See LICENSE file -- Maintainers: Lars Kuhtz, Emily Pillmore, Stuart Popejoy, Greg Hale @@ -13,7 +15,7 @@ -- - The codepath for adding transactions to the mempool -- - The codepath for letting users test their transaction via /local -- -module Chainweb.Pact5.Validations +module Chainweb.Pact.Validations ( -- * Local metadata _validation assertPreflightMetadata -- * Validation checks @@ -34,65 +36,64 @@ module Chainweb.Pact5.Validations ) where import Control.Lens - +import Chainweb.BlockCreationTime (BlockCreationTime(..)) +import Chainweb.Pact.Transaction qualified as Pact +import Chainweb.Pact.Types +import Chainweb.Parent +import Chainweb.Time (Seconds(..), Time(..), secondsToTimeSpan, scaleTimeSpan, second, add) +import Chainweb.Utils (ebool_, int, HasTextRepresentation (toText)) +import Chainweb.Version +import Chainweb.Version.Guards (maxBlockGasLimit) +import Data.ByteString.Short qualified as SBS import Data.Decimal (decimalPlaces) -import Data.Maybe import Data.Either (isRight) import Data.List.NonEmpty (NonEmpty, nonEmpty) +import Data.Maybe import Data.Text (Text) -import qualified Data.Text as Text -import qualified Data.ByteString.Short as SBS +import Data.Text qualified as Text import Data.Word (Word8) - --- internal modules - -import Chainweb.BlockHeader -import Chainweb.BlockCreationTime (BlockCreationTime(..)) -import Chainweb.Pact.Types -import Chainweb.Time (Seconds(..), Time(..), secondsToTimeSpan, scaleTimeSpan, second, add) -import Chainweb.Version - -import qualified Pact.Core.Command.Types as P -import qualified Pact.Core.ChainData as P -import qualified Pact.Core.Gas.Types as P -import qualified Pact.Core.Hash as P -import qualified Chainweb.Pact5.Transaction as P -import qualified Pact.Types.Gas as Pact4 -import qualified Pact.Parse as Pact4 -import Chainweb.Pact5.Types -import qualified Chainweb.Pact5.Transaction as Pact5 -import Chainweb.Utils (ebool_) +import Numeric.Natural +import Pact.Core.ChainData qualified as Pact +import Pact.Core.Command.Types qualified as Pact +import Pact.Core.Gas.Types qualified as Pact +import Pact.Core.Hash qualified as Pact -- | Check whether a local Api request has valid metadata -- assertPreflightMetadata - :: P.Command (P.Payload P.PublicMeta c) - -> TxContext + :: HasVersion + => ServiceEnv tbl + -> Pact.Command (Pact.Payload Pact.PublicMeta c) + -> BlockCtx -> Maybe LocalSignatureVerification - -> PactServiceM logger tbl (Either (NonEmpty Text) ()) -assertPreflightMetadata cmd@(P.Command pay sigs hsh) txCtx sigVerify = do - v <- view psVersion - cid <- view chainId - Pact4.GasLimit (Pact4.ParsedInteger bgl) <- view psBlockGasLimit - - let P.PublicMeta pcid _ gl gp _ _ = P._pMeta pay - nid = P._pNetworkId pay - signers = P._pSigners pay + -> Either (NonEmpty Text) () +assertPreflightMetadata env cmd@(Pact.Command pay sigs hsh) blockCtx sigVerify = do + let cid = view chainId env + -- note that we use the maximum legal block gas limit here. if no miner is + -- willing to accept this tx, it still may not make it on the chain. + let mbgl = maxBlockGasLimit + (_bctxParentForkNumber blockCtx) + (_bctxCurrentBlockHeight blockCtx) + + let Pact.PublicMeta pcid _ gl gp _ _ = Pact._pMeta pay + nid = Pact._pNetworkId pay + signers = Pact._pSigners pay let errs = catMaybes [ eUnless "Chain id mismatch" $ assertChainId cid pcid -- TODO: use failing conversion - , eUnless "Transaction Gas limit exceeds block gas limit" - $ assertBlockGasLimit (P.GasLimit $ P.Gas (fromIntegral @Integer @P.SatWord bgl)) gl + , mbgl >>= \bgl -> + eUnless "Transaction Gas limit exceeds block gas limit" + $ assertBlockGasLimit (Pact.GasLimit $ Pact.Gas $ int @Natural @Pact.SatWord bgl) gl , eUnless "Gas price decimal precision too high" $ assertGasPrice gp - , eUnless "Network id mismatch" $ assertNetworkId v nid + , eUnless "Network id mismatch" $ assertNetworkId nid , eUnless "Signature list size too big" $ assertSigSize sigs , eUnless "Invalid transaction signatures" $ sigValidate signers , eUnless "Tx time outside of valid range" $ assertTxTimeRelativeToParent pct cmd ] - pure $ case nonEmpty errs of + case nonEmpty errs of Nothing -> Right () Just vs -> Left vs where @@ -100,11 +101,7 @@ assertPreflightMetadata cmd@(P.Command pay sigs hsh) txCtx sigVerify = do | Just NoVerify <- sigVerify = True | otherwise = isRight $ assertValidateSigs hsh signers sigs - pct = ParentCreationTime - . view blockCreationTime - . _parentHeader - . _tcParentHeader - $ txCtx + pct = _bctxParentCreationTime blockCtx eUnless t assertion | assertion = Nothing @@ -116,46 +113,46 @@ assertPreflightMetadata cmd@(P.Command pay sigs hsh) txCtx sigVerify = do -- The supplied chain id should be derived from the current -- chainweb node structure -- -assertChainId :: ChainId -> P.ChainId -> Bool -assertChainId cid0 cid1 = chainIdToText cid0 == P._chainId cid1 +assertChainId :: ChainId -> Pact.ChainId -> Bool +assertChainId cid0 cid1 = toText cid0 == Pact._chainId cid1 -- | Check and assert that 'GasPrice' is rounded to at most 12 decimal -- places. -- -assertGasPrice :: P.GasPrice -> Bool -assertGasPrice (P.GasPrice gp) = decimalPlaces gp <= defaultMaxCoinDecimalPlaces +assertGasPrice :: Pact.GasPrice -> Bool +assertGasPrice (Pact.GasPrice gp) = decimalPlaces gp <= defaultMaxCoinDecimalPlaces -- | Check and assert that the 'GasLimit' of a transaction is less than or eqaul to -- the block gas limit -- -assertBlockGasLimit :: P.GasLimit -> P.GasLimit -> Bool +assertBlockGasLimit :: Pact.GasLimit -> Pact.GasLimit -> Bool assertBlockGasLimit bgl tgl = bgl >= tgl -- | Check and assert that 'ChainwebVersion' is equal to some pact 'NetworkId'. -- -assertNetworkId :: ChainwebVersion -> Maybe P.NetworkId -> Bool -assertNetworkId _ Nothing = False -assertNetworkId v (Just (P.NetworkId nid)) = ChainwebVersionName nid == _versionName v +assertNetworkId :: HasVersion => Maybe Pact.NetworkId -> Bool +assertNetworkId Nothing = False +assertNetworkId (Just (Pact.NetworkId nid)) = ChainwebVersionName nid == _versionName implicitVersion -- | Check and assert that the number of signatures in a 'Command' is -- at most 100. -- -assertSigSize :: [P.UserSig] -> Bool +assertSigSize :: [Pact.UserSig] -> Bool assertSigSize sigs = length sigs <= defaultMaxCommandUserSigListSize -- | Check and assert that the initial 'Gas' cost of a transaction -- is less than the specified 'GasLimit'. -- -assertTxSize :: P.Gas -> P.GasLimit -> Bool -assertTxSize initialGas gasLimit = P.GasLimit initialGas < gasLimit +assertTxSize :: Pact.Gas -> Pact.GasLimit -> Bool +assertTxSize initialGas gasLimit = Pact.GasLimit initialGas < gasLimit -- | Check and assert that signers and user signatures are valid for a given -- transaction hash. -- assertValidateSigs :: () - => P.Hash - -> [P.Signer] - -> [P.UserSig] + => Pact.Hash + -> [Pact.Signer] + -> [Pact.UserSig] -> Either AssertValidateSigsError () assertValidateSigs hsh signers sigs = do let signersLength = length signers @@ -168,7 +165,7 @@ assertValidateSigs hsh signers sigs = do (signersLength == sigsLength) iforM_ (zip sigs signers) $ \pos (sig, signer) -> do - case P.verifyUserSig hsh sig signer of + case Pact.verifyUserSig hsh sig signer of Left errMsg -> Left (InvalidUserSig pos (Text.pack errMsg)) Right () -> Right () @@ -180,45 +177,45 @@ assertValidateSigs hsh signers sigs = do -- skipped when replaying old blocks. -- assertTxTimeRelativeToParent - :: ParentCreationTime - -> P.Command (P.Payload P.PublicMeta c) + :: Parent BlockCreationTime + -> Pact.Command (Pact.Payload Pact.PublicMeta c) -> Bool -assertTxTimeRelativeToParent (ParentCreationTime (BlockCreationTime txValidationTime)) tx = +assertTxTimeRelativeToParent (Parent (BlockCreationTime txValidationTime)) tx = ttl > 0 && txValidationTime >= timeFromSeconds 0 && txOriginationTime >= 0 && timeFromSeconds (txOriginationTime + ttl) > txValidationTime && ttl <= defaultMaxTTLSeconds where - P.TTLSeconds ttl = view (P.cmdPayload . P.pMeta . P.pmTTL) tx + Pact.TTLSeconds ttl = view (Pact.cmdPayload . Pact.pMeta . Pact.pmTTL) tx timeFromSeconds = Time . secondsToTimeSpan . Seconds . fromIntegral - P.TxCreationTime txOriginationTime = view (P.cmdPayload . P.pMeta . P.pmCreationTime) tx + Pact.TxCreationTime txOriginationTime = view (Pact.cmdPayload . Pact.pMeta . Pact.pmCreationTime) tx -- | Check that the tx's creation time is not too far in the future relative -- to the block creation time assertTxNotInFuture - :: ParentCreationTime - -> P.Command (P.Payload P.PublicMeta c) + :: Parent BlockCreationTime + -> Pact.Command (Pact.Payload Pact.PublicMeta c) -> Bool -assertTxNotInFuture (ParentCreationTime (BlockCreationTime txValidationTime)) tx = +assertTxNotInFuture (Parent (BlockCreationTime txValidationTime)) tx = timeFromSeconds txOriginationTime <= lenientTxValidationTime where timeFromSeconds = Time . secondsToTimeSpan . Seconds . fromIntegral - P.TxCreationTime txOriginationTime = view (P.cmdPayload . P.pMeta . P.pmCreationTime) tx + Pact.TxCreationTime txOriginationTime = view (Pact.cmdPayload . Pact.pMeta . Pact.pmCreationTime) tx lenientTxValidationTime = add (scaleTimeSpan defaultLenientTimeSlop second) txValidationTime -- | Assert that the command hash matches its payload and -- its signatures are valid, without parsing the payload. -assertCommand :: Pact5.Transaction -> Either AssertCommandError () +assertCommand :: Pact.Transaction -> Either AssertCommandError () assertCommand cmd = do _ <- assertHash & _Left .~ InvalidPayloadHash - assertValidateSigs hsh signers (P._cmdSigs cmd) & _Left %~ AssertValidateSigsError + assertValidateSigs hsh signers (Pact._cmdSigs cmd) & _Left %~ AssertValidateSigsError where - hsh = P._cmdHash cmd - pwt = P._cmdPayload cmd - cmdBS = SBS.fromShort $ pwt ^. P.payloadBytes - signers = pwt ^. P.payloadObj . P.pSigners - assertHash = P.verifyHash hsh cmdBS + hsh = Pact._cmdHash cmd + pwt = Pact._cmdPayload cmd + cmdBS = SBS.fromShort $ pwt ^. Pact.payloadBytes + signers = pwt ^. Pact.payloadObj . Pact.pSigners + assertHash = Pact.verifyHash hsh cmdBS -- -------------------------------------------------------------------- -- -- defaults diff --git a/src/Chainweb/Pact4/Backend/ChainwebPactDb.hs b/src/Chainweb/Pact4/Backend/ChainwebPactDb.hs index 80226154d6..7b441e2603 100644 --- a/src/Chainweb/Pact4/Backend/ChainwebPactDb.hs +++ b/src/Chainweb/Pact4/Backend/ChainwebPactDb.hs @@ -10,7 +10,6 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ImportQualifiedPost #-} --- TODO pact5: fix the orphan PactDbFor instance {-# OPTIONS_GHC -Wno-orphans #-} {-# LANGUAGE ViewPatterns #-} @@ -32,11 +31,15 @@ module Chainweb.Pact4.Backend.ChainwebPactDb , cpPactDbEnv , cpRegisterProcessedTx , cpLookupProcessedTx +, cpHeaderOracle , callDb , BlockEnv(..) +, benvDbEnv +, benvBlockCtx +, BlockDbEnv(..) , blockHandlerEnv , benvBlockState -, runBlockEnv +, runBlockDbEnv , BlockState(..) , bsPendingBlock , bsTxId @@ -49,7 +52,7 @@ module Chainweb.Pact4.Backend.ChainwebPactDb , blockHandlerModuleNameFix , blockHandlerSortedKeys , blockHandlerLowerCaseTables -, blockHandlerPersistIntraBlockWrites +, blockHandlerChainId , mkBlockHandlerEnv , domainTableName @@ -60,6 +63,8 @@ module Chainweb.Pact4.Backend.ChainwebPactDb , convPactId , commitBlockStateToDatabase + +, headerOracleForBlock ) where import Control.Applicative @@ -69,7 +74,7 @@ import Control.Monad.Reader import Control.Monad.State.Strict import Control.Monad.Trans.Maybe -import Data.Aeson hiding ((.=)) +import Data.Aeson hiding ((.=), Error) import qualified Data.ByteString as BS import qualified Data.ByteString.Char8 as B8 import qualified Data.DList as DL @@ -84,6 +89,7 @@ import qualified Data.Set as Set import Data.String import qualified Data.Text as T import qualified Data.Text.Encoding as T +import System.LogLevel import Database.SQLite3.Direct as SQ3 @@ -108,8 +114,8 @@ import Chainweb.BlockHash import Chainweb.BlockHeight import Chainweb.Logger import Chainweb.Pact.Backend.DbCache -import Chainweb.Pact.Backend.Utils -import Chainweb.Pact.Types +-- import Chainweb.Pact.Backend.Utils hiding (SType(..), RType(..), bindParams, qry) +import Chainweb.Pact4.Types import Chainweb.Utils import Chainweb.Version import Pact.Interpreter (PactDbEnv) @@ -119,9 +125,13 @@ import Control.Concurrent import Chainweb.Version.Guards import Control.Exception.Safe import Pact.Types.Command (RequestKey) -import Chainweb.Pact.Backend.Types import Chainweb.Utils.Serialization (runPutS) import Data.Foldable +import Chainweb.Pact.Backend.Types (SQLiteEnv, HeaderOracle (..)) +import Chainweb.Pact.Backend.Utils (toUtf8, asStringUtf8, tbl, fromUtf8) +import Chainweb.BlockPayloadHash (BlockPayloadHash, encodeBlockPayloadHash) +import Chainweb.Pact.Types (BlockCtx) +import Chainweb.Parent execMulti :: Traversable t => SQ3.Database -> SQ3.Utf8 -> t [SType] -> IO () execMulti db q rows = bracket (prepStmt db q) destroy $ \stmt -> do @@ -175,41 +185,41 @@ data BlockHandlerEnv logger = BlockHandlerEnv { _blockHandlerDb :: !SQLiteEnv , _blockHandlerLogger :: !logger , _blockHandlerBlockHeight :: !BlockHeight + , _blockHandlerChainId :: !ChainId , _blockHandlerModuleNameFix :: !Bool , _blockHandlerSortedKeys :: !Bool , _blockHandlerLowerCaseTables :: !Bool - , _blockHandlerPersistIntraBlockWrites :: !IntraBlockPersistence } mkBlockHandlerEnv - :: ChainwebVersion -> ChainId -> BlockHeight - -> SQLiteEnv -> IntraBlockPersistence -> logger -> BlockHandlerEnv logger -mkBlockHandlerEnv v cid bh sql p logger = BlockHandlerEnv + :: HasVersion => ChainId -> BlockHeight + -> SQLiteEnv -> logger -> BlockHandlerEnv logger +mkBlockHandlerEnv cid bh sql logger = BlockHandlerEnv { _blockHandlerDb = sql , _blockHandlerLogger = logger , _blockHandlerBlockHeight = bh - , _blockHandlerModuleNameFix = enableModuleNameFix v cid bh - , _blockHandlerSortedKeys = pact42 v cid bh - , _blockHandlerLowerCaseTables = chainweb217Pact v cid bh - , _blockHandlerPersistIntraBlockWrites = p + , _blockHandlerChainId = cid + , _blockHandlerModuleNameFix = enableModuleNameFix cid bh + , _blockHandlerSortedKeys = pact42 cid bh + , _blockHandlerLowerCaseTables = chainweb217Pact cid bh } makeLenses ''BlockHandlerEnv -data BlockEnv logger = - BlockEnv +data BlockDbEnv logger = + BlockDbEnv { _blockHandlerEnv :: !(BlockHandlerEnv logger) , _benvBlockState :: !BlockState -- ^ The current block state. } -runBlockEnv :: MVar (BlockEnv logger) -> BlockHandler logger a -> IO a -runBlockEnv e m = modifyMVar e $ - \(BlockEnv dbenv bs) -> do +runBlockDbEnv :: MVar (BlockDbEnv logger) -> BlockHandler logger a -> IO a +runBlockDbEnv e m = modifyMVar e $ + \(BlockDbEnv dbenv bs) -> do (!a,!s) <- runStateT (runReaderT (runBlockHandler m) dbenv) bs - return (BlockEnv dbenv s, a) + return (BlockDbEnv dbenv s, a) -- this monad allows access to the database environment "at" a particular block. --- unfortunately, this is tied to a useless MVar via runBlockEnv, which will +-- unfortunately, this is tied to a useless MVar via runBlockDbEnv, which will -- be deleted with pact 5. newtype BlockHandler logger a = BlockHandler { runBlockHandler :: ReaderT (BlockHandlerEnv logger) (StateT BlockState IO) a @@ -232,8 +242,8 @@ newtype BlockHandler logger a = BlockHandler -- on tx failure. data BlockState = BlockState { _bsTxId :: !TxId - , _bsPendingBlock :: !(SQLitePendingData (PendingWrites Pact4)) - , _bsPendingTx :: !(Maybe (SQLitePendingData (PendingWrites Pact4))) + , _bsPendingBlock :: !SQLitePendingData + , _bsPendingTx :: !(Maybe SQLitePendingData) , _bsMode :: !(Maybe ExecutionMode) , _bsModuleCache :: !(DbCache PersistModuleData) } @@ -246,52 +256,51 @@ initBlockState initBlockState cl txid = BlockState { _bsTxId = txid , _bsMode = Nothing - , _bsPendingBlock = emptySQLitePendingData mempty + , _bsPendingBlock = emptySQLitePendingData , _bsPendingTx = Nothing , _bsModuleCache = emptyDbCache cl } -makeLenses ''BlockEnv +makeLenses ''BlockDbEnv makeLenses ''BlockState -- this is effectively a read-write snapshot of the Pact state at a block. data CurrentBlockDbEnv logger = CurrentBlockDbEnv - { _cpPactDbEnv :: !(PactDbEnv (BlockEnv logger)) + { _cpPactDbEnv :: !(PactDbEnv (BlockDbEnv logger)) , _cpRegisterProcessedTx :: !(RequestKey -> IO ()) , _cpLookupProcessedTx :: !(Vector RequestKey -> IO (HashMap RequestKey (T2 BlockHeight BlockHash))) + , _cpHeaderOracle :: !HeaderOracle } makeLenses ''CurrentBlockDbEnv -type instance PactDbFor logger Pact4 = CurrentBlockDbEnv logger - -- | Pact DB which reads from the tip of the checkpointer -chainwebPactDb :: (Logger logger) => PactDb (BlockEnv logger) +chainwebPactDb :: (Logger logger) => PactDb (BlockDbEnv logger) chainwebPactDb = PactDb - { _readRow = \d k e -> runBlockEnv e $ doReadRow Nothing d k - , _writeRow = \wt d k v e -> runBlockEnv e $ doWriteRow Nothing wt d k v - , _keys = \d e -> runBlockEnv e $ doKeys Nothing d - , _txids = \t txid e -> runBlockEnv e $ doTxIds t txid - , _createUserTable = \tn mn e -> runBlockEnv e $ doCreateUserTable Nothing tn mn + { _readRow = \d k e -> runBlockDbEnv e $ doReadRow Nothing d k + , _writeRow = \wt d k v e -> runBlockDbEnv e $ doWriteRow Nothing wt d k v + , _keys = \d e -> runBlockDbEnv e $ doKeys Nothing d + , _txids = \t txid e -> runBlockDbEnv e $ doTxIds t txid + , _createUserTable = \tn mn e -> runBlockDbEnv e $ doCreateUserTable Nothing tn mn , _getUserTableInfo = \_ -> error "WILL BE DEPRECATED!" - , _beginTx = \m e -> runBlockEnv e $ doBegin m - , _commitTx = \e -> runBlockEnv e doCommit - , _rollbackTx = \e -> runBlockEnv e doRollback - , _getTxLog = \d tid e -> runBlockEnv e $ doGetTxLog d tid + , _beginTx = \m e -> runBlockDbEnv e $ doBegin m + , _commitTx = \e -> runBlockDbEnv e doCommit + , _rollbackTx = \e -> runBlockDbEnv e doRollback + , _getTxLog = \d tid e -> runBlockDbEnv e $ doGetTxLog d tid } -- | Pact DB which reads from some past block height, instead of the tip of the checkpointer -rewoundPactDb :: (Logger logger) => BlockHeight -> TxId -> PactDb (BlockEnv logger) +rewoundPactDb :: (Logger logger) => BlockHeight -> TxId -> PactDb (BlockDbEnv logger) rewoundPactDb bh endTxId = chainwebPactDb - { _readRow = \d k e -> runBlockEnv e $ doReadRow (Just (bh, endTxId)) d k - , _writeRow = \wt d k v e -> runBlockEnv e $ doWriteRow (Just (bh, endTxId)) wt d k v - , _keys = \d e -> runBlockEnv e $ doKeys (Just (bh, endTxId)) d - , _createUserTable = \tn mn e -> runBlockEnv e $ doCreateUserTable (Just bh) tn mn + { _readRow = \d k e -> runBlockDbEnv e $ doReadRow (Just (bh, endTxId)) d k + , _writeRow = \wt d k v e -> runBlockDbEnv e $ doWriteRow (Just (bh, endTxId)) wt d k v + , _keys = \d e -> runBlockDbEnv e $ doKeys (Just (bh, endTxId)) d + , _createUserTable = \tn mn e -> runBlockDbEnv e $ doCreateUserTable (Just bh) tn mn } -- returns pending writes in the reverse order they were made -getPendingData :: BlockHandler logger [SQLitePendingData (PendingWrites Pact4)] +getPendingData :: BlockHandler logger [SQLitePendingData] getPendingData = do pb <- use bsPendingBlock ptx <- maybeToList <$> use bsPendingTx @@ -349,7 +358,7 @@ doReadRow mlim d k = forModuleNameFix $ \mnFix -> lookupInPendingData :: forall logger v . FromJSON v => Utf8 - -> SQLitePendingData (PendingWrites Pact4) + -> SQLitePendingData -> MaybeT (BlockHandler logger) v lookupInPendingData (Utf8 rowkey) p = do -- we get the latest-written value at this rowkey @@ -616,7 +625,7 @@ recordTxLog tt d k v = do !txlogs = DL.singleton $! encodeTxLog $ TxLog (asString d) (asString k) v modifyPendingData - :: (SQLitePendingData (PendingWrites Pact4) -> SQLitePendingData (PendingWrites Pact4)) + :: (SQLitePendingData -> SQLitePendingData) -> BlockHandler logger () modifyPendingData f = do m <- use bsPendingTx @@ -678,37 +687,35 @@ doCommit :: BlockHandler logger [TxLogJson] doCommit = use bsMode >>= \case Nothing -> doRollback >> internalError "doCommit: Not in transaction" Just m -> do - txrs <- if m == Transactional - then do - modify' $ over bsTxId succ - -- merge pending tx into block data - pending <- use bsPendingTx - persistIntraBlockWrites <- view blockHandlerPersistIntraBlockWrites - modify' $ over bsPendingBlock (merge persistIntraBlockWrites pending) - -- this is mostly a lie; the previous `merge` call has already replaced the tx - -- logs from bsPendingBlock with those of the transaction. - -- from what I can tell, it's impossible for `pending` to be `Nothing` here, - -- but we don't throw an error for it. - blockLogs <- use $ bsPendingBlock . pendingTxLogMap - modify' $ set bsPendingTx Nothing - resetTemp - return blockLogs - else doRollback >> return mempty + txrs <- + if m == Transactional + then do + modify' $ over bsTxId succ + -- merge pending tx into block data + pending <- use bsPendingTx + modify' $ over bsPendingBlock (merge pending) + -- this is mostly a lie; the previous `merge` call has already replaced the tx + -- logs from bsPendingBlock with those of the transaction. + -- from what I can tell, it's impossible for `pending` to be `Nothing` here, + -- but we don't throw an error for it. + blockLogs <- use $ bsPendingBlock . pendingTxLogMap + modify' $ set bsPendingTx Nothing + resetTemp + return blockLogs + else doRollback >> return mempty return $! concatMap (reverse . DL.toList) txrs - where - merge _ Nothing a = a - merge persistIntraBlockWrites (Just txPending) blockPending = SQLitePendingData + where + merge Nothing a = a + merge (Just txPending) blockPending = SQLitePendingData { _pendingTableCreation = HashSet.union (_pendingTableCreation txPending) (_pendingTableCreation blockPending) , _pendingWrites = HashMap.unionWith (HashMap.unionWith mergeAtRowKey) (_pendingWrites txPending) (_pendingWrites blockPending) , _pendingTxLogMap = _pendingTxLogMap txPending , _pendingSuccessfulTxs = _pendingSuccessfulTxs blockPending } where - mergeAtRowKey txWrites blockWrites = + mergeAtRowKey txWrites _ = let lastTxWrite = NE.head txWrites - in case persistIntraBlockWrites of - PersistIntraBlockWrites -> lastTxWrite `NE.cons` blockWrites - DoNotPersistIntraBlockWrites -> lastTxWrite :| [] + in lastTxWrite :| [] {-# INLINE doCommit #-} -- | Begin a Pact transaction @@ -717,13 +724,13 @@ doBegin m = do logger <- view blockHandlerLogger use bsMode >>= \case Just {} -> do - logError_ logger "PactDb.beginTx: In transaction, rolling back" + liftIO $ logFunctionText logger Error "PactDb.beginTx: In transaction, rolling back" doRollback Nothing -> return () resetTemp modify' $ set bsMode (Just m) - . set bsPendingTx (Just $ emptySQLitePendingData mempty) + . set bsPendingTx (Just emptySQLitePendingData) case m of Transactional -> Just <$> use bsTxId Local -> pure Nothing @@ -798,16 +805,17 @@ indexPactTransaction h = modify' $ vacuumDb :: BlockHandler logger () vacuumDb = callDb "vacuumDb" (`exec_` "VACUUM;") -commitBlockStateToDatabase :: SQLiteEnv -> BlockHash -> BlockHeight -> BlockHandle Pact4 -> IO () -commitBlockStateToDatabase db hsh bh blockHandle = do - let newTables = _pendingTableCreation $ _blockHandlePending blockHandle +commitBlockStateToDatabase :: SQLiteEnv -> BlockHash -> BlockPayloadHash -> BlockHeight -> BlockState -> IO () +commitBlockStateToDatabase db blockHash payloadHash bh blockState = do + let newTables = _pendingTableCreation $ pendingBlock mapM_ (\tn -> createUserTable tn) newTables - let writeV = toChunks $ _pendingWrites (_blockHandlePending blockHandle) + let writeV = toChunks $ _pendingWrites pendingBlock backendWriteUpdateBatch writeV indexPendingPactTransactions - let nextTxId = _blockHandleTxId blockHandle + let nextTxId = _bsTxId blockState blockHistoryInsert nextTxId where + pendingBlock = _bsPendingBlock blockState toChunks writes = over _2 (concatMap toList . HashMap.elems) . over _1 toUtf8 <$> HashMap.toList writes @@ -841,12 +849,13 @@ commitBlockStateToDatabase db hsh bh blockHandle = do blockHistoryInsert t = exec' db stmt [ SInt (fromIntegral bh) - , SBlob (runPutS (encodeBlockHash hsh)) + , SBlob (runPutS (encodeBlockHash blockHash)) + , SBlob (runPutS (encodeBlockPayloadHash payloadHash)) , SInt (fromIntegral t) ] where stmt = - "INSERT INTO BlockHistory ('blockheight','hash','endingtxid') VALUES (?,?,?);" + "INSERT INTO BlockHistory2 ('blockheight','hash','payloadhash','endingtxid') VALUES (?,?,?,?);" createUserTable :: Text -> IO () createUserTable (toUtf8 -> tablename) = do @@ -864,7 +873,7 @@ commitBlockStateToDatabase db hsh bh blockHandle = do -- | Commit the index of pending successful transactions to the database indexPendingPactTransactions :: IO () indexPendingPactTransactions = do - let txs = _pendingSuccessfulTxs $ _blockHandlePending blockHandle + let txs = _pendingSuccessfulTxs pendingBlock dbIndexTransactions txs where @@ -889,3 +898,27 @@ createVersionedTable tablename db = do \, UNIQUE (rowkey, txid));" indexcreationstmt = "CREATE INDEX IF NOT EXISTS " <> tbl ixName <> " ON " <> tbl tablename <> "(txid DESC);" + +data BlockEnv logger = BlockEnv + { _benvBlockCtx :: !BlockCtx + , _benvDbEnv :: !(CurrentBlockDbEnv logger) + } +makeLenses ''BlockEnv + +lookupBlockHash :: SQ3.Database -> BlockHash -> IO (Maybe BlockHeight) +lookupBlockHash db hash = do + qry db qtext [SBlob (runPutS (encodeBlockHash hash))] [RInt] >>= \case + [[SInt n]] -> return $! Just $! int n + [] -> return $ Nothing + res -> error $ "Invalid result, " <> sshow res + where + qtext = "SELECT blockheight FROM BlockHistory2 WHERE hash = ?;" + +headerOracleForBlock :: BlockHandlerEnv logger -> HeaderOracle +headerOracleForBlock env = HeaderOracle + { consult = \(Parent blkHash) -> do + lookupBlockHash (_blockHandlerDb env) blkHash <&> \case + Nothing -> False + Just rootHeight -> rootHeight < _blockHandlerBlockHeight env + , chain = _blockHandlerChainId env + } diff --git a/src/Chainweb/Pact4/ModuleCache.hs b/src/Chainweb/Pact4/ModuleCache.hs index e6e047c619..4fd552e25a 100644 --- a/src/Chainweb/Pact4/ModuleCache.hs +++ b/src/Chainweb/Pact4/ModuleCache.hs @@ -9,7 +9,8 @@ {-# LANGUAGE LambdaCase #-} module Chainweb.Pact4.ModuleCache - ( ModuleCache(..) + ( ModuleInitCache + , ModuleCache(..) , filterModuleCacheByKey , moduleCacheToHashMap , moduleCacheFromHashMap @@ -34,6 +35,9 @@ import Chainweb.ChainId import Chainweb.Version import qualified Pact.JSON.Legacy.HashMap as LHM +import qualified Data.Map as M + +type ModuleInitCache = M.Map BlockHeight ModuleCache -- | Block scoped Module Cache -- @@ -66,10 +70,10 @@ moduleCacheKeys (ModuleCache a) = fst <$> LHM.toList a -- this can't go in Chainweb.Version.Guards because it causes an import cycle -- it uses genesisHeight which is from BlockHeader which imports Guards -cleanModuleCache :: ChainwebVersion -> ChainId -> BlockHeight -> Bool -cleanModuleCache v cid bh = - case v ^?! versionForks . at Chainweb217Pact . _Just . atChain cid of +cleanModuleCache :: HasVersion => ChainId -> BlockHeight -> Bool +cleanModuleCache cid bh = + case implicitVersion ^?! versionForks . at Chainweb217Pact . _Just . atChain cid of ForkAtBlockHeight bh' -> bh == bh' - ForkAtGenesis -> bh == genesisHeight v cid + ForkAtGenesis -> bh == genesisHeight cid ForkNever -> False ForkAtForkNumber _ -> error "ChainWeb217Pact is not supposed to be indexed by a ForkNumber" diff --git a/src/Chainweb/Pact4/SPV.hs b/src/Chainweb/Pact4/SPV.hs index 84bf0b5709..f348d39ea3 100644 --- a/src/Chainweb/Pact4/SPV.hs +++ b/src/Chainweb/Pact4/SPV.hs @@ -1,11 +1,10 @@ +{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE ImportQualifiedPost #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} -{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE GADTs #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE ViewPatterns #-} @@ -28,85 +27,100 @@ module Chainweb.Pact4.SPV , getTxIdx ) where -import Chainweb.BlockHeader -import Chainweb.BlockHeaderDB -import Chainweb.BlockHeaderDB.HeaderOracle qualified as Oracle -import Chainweb.BlockHeight -import Chainweb.Pact.Types(internalError) -import Chainweb.Pact.Utils (aeson) -import Chainweb.Payload -import Chainweb.Payload.PayloadStore -import Chainweb.SPV -import Chainweb.SPV.VerifyProof -import Chainweb.TreeDB -import Chainweb.Utils -import Chainweb.Version qualified as CW -import Chainweb.Version.Guards qualified as CW -import Control.Error + +import GHC.Stack + import Control.Lens hiding (index) import Control.Monad import Control.Monad.Catch -import Control.Monad.IO.Class (liftIO) import Control.Monad.Except import Control.Monad.Trans.Except -import Crypto.Hash.Algorithms + import Data.Aeson hiding (Object, (.=)) import Data.Bifunctor -import Data.ByteString qualified as B -import Data.ByteString.Base64.URL qualified as B64U -import Data.Map.Strict qualified as M +import qualified Data.ByteString as B +import qualified Data.ByteString.Base64.URL as B64U +import qualified Data.Map.Strict as M import Data.Text (Text, pack) -import Data.Text qualified as Text -import Data.Text.Encoding qualified as Text -import Ethereum.Header qualified as EthHeader +import qualified Data.Text as Text +import qualified Data.Text.Encoding as Text +import Text.Read (readMaybe) + +import qualified Ethereum.Header as EthHeader import Ethereum.Misc -import Ethereum.RLP import Ethereum.Receipt import Ethereum.Receipt.ReceiptProof -import GHC.Stack +import Ethereum.RLP + import Numeric.Natural -import Pact.JSON.Encode qualified as J -import Pact.Types.Command qualified as Pact4 -import Pact.Types.Hash qualified as Pact4 -import Pact.Types.Info qualified as Pact4 -import Pact.Types.PactValue qualified as Pact4 -import Pact.Types.Runtime qualified as Pact4 -import Pact.Types.SPV qualified as Pact4 -import Streaming.Prelude qualified as S -import Text.Read (readMaybe) -catchAndDisplaySPVError :: BlockHeader -> ExceptT Text IO a -> ExceptT Text IO a -catchAndDisplaySPVError bh = - if CW.chainweb219Pact (CW._chainwebVersion bh) (CW._chainId bh) (view blockHeight bh) - then flip catch $ \case - SpvExceptionVerificationFailed m -> throwError ("spv verification failed: " <> m) - spvErr -> throwM spvErr - else id - -forkedThrower :: BlockHeader -> Text -> ExceptT Text IO a -forkedThrower bh = - if CW.chainweb219Pact (CW._chainwebVersion bh) (CW._chainId bh) (view blockHeight bh) +import qualified Streaming.Prelude as S + +-- internal chainweb modules + +import Chainweb.BlockHeader +import Chainweb.BlockHeaderDB +import Chainweb.BlockHeight +import Chainweb.Pact.Backend.Types (HeaderOracle) +import Chainweb.Pact.Types(BlockCtx(..), _bctxCurrentBlockHeight) +import Chainweb.Pact.Utils (aeson) +import Chainweb.Pact4.Types(internalError) +import Chainweb.Pact.Payload +import Chainweb.Pact.Payload.PayloadStore +import Chainweb.SPV +import Chainweb.SPV.VerifyProof +import Chainweb.TreeDB +import Chainweb.Utils +import qualified Chainweb.Version as CW +import qualified Chainweb.Version.Guards as CW + +-- internal pact modules + +import qualified Pact.JSON.Encode as J +import qualified Pact.Types.Command as Pact4 +import qualified Pact.Types.Hash as Pact4 +import qualified Pact.Types.Info as Pact4 +import qualified Pact.Types.PactValue as Pact4 +import qualified Pact.Types.Runtime as Pact4 +import qualified Pact.Types.SPV as Pact4 +import Chainweb.MerkleUniverse (ChainwebMerkleHashAlgorithm) + +forkedThrower :: CW.HasVersion => BlockCtx -> Text -> ExceptT Text IO a +forkedThrower bctx = + if CW.chainweb219Pact (CW._chainId bctx) (_bctxCurrentBlockHeight bctx) then throwError else internalError +catchAndDisplaySPVError :: CW.HasVersion => BlockCtx -> ExceptT Text IO a -> ExceptT Text IO a +catchAndDisplaySPVError bctx = + if CW.chainweb219Pact (CW._chainId bctx) (_bctxCurrentBlockHeight bctx) + then id + else flip catchError $ + -- the only error we expect + \_msg -> throwM $ SpvExceptionVerificationFailed "target header is not in the chain" + -- | Spv support for pact -- pactSPV - :: BlockHeaderDb + :: CW.HasVersion + => HeaderOracle -- ^ handle into the cutdb - -> BlockHeader + -> BlockCtx -- ^ the context for verifying the proof -> Pact4.SPVSupport -pactSPV bdb bh = Pact4.SPVSupport (verifySPV bdb bh) (verifyCont bdb bh) +pactSPV headerOracle bctx = Pact4.SPVSupport + (verifySPV headerOracle bctx) + (verifyCont headerOracle bctx) -- | SPV transaction verification support. Calls to 'verify-spv' in Pact -- will thread through this function and verify an SPV receipt, making the -- requisite calls to the SPV api and verifying the output proof. -- verifySPV - :: BlockHeaderDb + :: CW.HasVersion + => HeaderOracle -- ^ handle into the cut db - -> BlockHeader + -> BlockCtx -- ^ the context for verifying the proof -> Text -- ^ TXOUT or TXIN - defines the type of proof @@ -114,12 +128,10 @@ verifySPV -> Pact4.Object Pact4.Name -- ^ the proof object to validate -> IO (Either Text (Pact4.Object Pact4.Name)) -verifySPV bdb bh typ proof = do - oracle <- Oracle.createSpv bdb bh - runExceptT $ go oracle typ proof +verifySPV headerOracle bctx typ proof = runExceptT $ go typ proof where - cid = CW._chainId bdb - enableBridge = CW.enableSPVBridge (CW._chainwebVersion bh) cid (view blockHeight bh) + cid = CW._chainId headerOracle + enableBridge = CW.enableSPVBridge cid (_bctxCurrentBlockHeight bctx) mkSPVResult' cr j | enableBridge = @@ -128,7 +140,7 @@ verifySPV bdb bh typ proof = do Pact4.TObject o _ -> return o _ -> throwError "spv-verified tx output has invalid type" - go oracle s o = case s of + go s o = case s of -- Ethereum Receipt Proof "ETH" | enableBridge -> except (extractEthProof o) >>= @@ -140,7 +152,7 @@ verifySPV bdb bh typ proof = do "TXOUT" -> do u <- except $ extractProof enableBridge o unless (view outputProofChainId u == cid) $ - forkedThrower bh "cannot redeem spv proof on wrong target chain" + forkedThrower bctx "cannot redeem spv proof on wrong target chain" -- SPV proof verification is a 3 step process: -- @@ -151,10 +163,11 @@ verifySPV bdb bh typ proof = do -- 3. Extract tx outputs as a pact object and return the -- object. - TransactionOutput p <- catchAndDisplaySPVError bh $ Pact4.liftIO $ verifyTransactionOutputProof oracle u + TransactionOutput p <- catchAndDisplaySPVError bctx $ + checkProofAndExtractOutput headerOracle u q <- case decodeStrict' p :: Maybe (Pact4.CommandResult Pact4.Hash) of - Nothing -> forkedThrower bh "unable to decode spv transaction output" + Nothing -> forkedThrower bctx "unable to decode spv transaction output" Just cr -> return cr case Pact4._crResult q of @@ -242,28 +255,25 @@ base64DowngradeErrorMessage msg = case msg of -- in Pact, providing a validation that the yield data of a cross-chain pact is valid. -- verifyCont - :: BlockHeaderDb + :: CW.HasVersion + => HeaderOracle -- ^ handle into the cut db - -> BlockHeader + -> BlockCtx -- ^ the context for verifying the proof -> Pact4.ContProof -- ^ bytestring of 'TransactionOutputP roof' object to validate -> IO (Either Text Pact4.PactExec) -verifyCont bdb bh (Pact4.ContProof cp) = runExceptT $ do - oracle <- liftIO $ Oracle.createSpv bdb bh +verifyCont headerOracle bctx (Pact4.ContProof cp) = runExceptT $ do let errorMessageType = - if CW.chainweb221Pact - (CW._chainwebVersion bh) - (CW._chainId bh) - (view blockHeight bh) + if CW.chainweb221Pact (CW._chainId bctx) (_bctxCurrentBlockHeight bctx) then Simplified else Legacy t <- decodeB64UrlNoPaddingTextWithFixedErrorMessage errorMessageType $ Text.decodeUtf8 cp case decodeStrict' t of - Nothing -> forkedThrower bh "unable to decode continuation proof" + Nothing -> forkedThrower bctx "unable to decode continuation proof" Just u | view outputProofChainId u /= cid -> - forkedThrower bh "cannot redeem continuation proof on wrong target chain" + forkedThrower bctx "cannot redeem continuation proof on wrong target chain" | otherwise -> do -- Cont proof verification is a 3 step process: @@ -275,21 +285,22 @@ verifyCont bdb bh (Pact4.ContProof cp) = runExceptT $ do -- 3. Extract continuation 'PactExec' from decoded result -- and return the cont exec object - TransactionOutput p <- catchAndDisplaySPVError bh $ Pact4.liftIO $ verifyTransactionOutputProof oracle u + TransactionOutput p <- catchAndDisplaySPVError bctx $ + checkProofAndExtractOutput headerOracle u q <- case decodeStrict' p :: Maybe (Pact4.CommandResult Pact4.Hash) of - Nothing -> forkedThrower bh "unable to decode spv transaction output" + Nothing -> forkedThrower bctx "unable to decode spv transaction output" Just cr -> return cr case Pact4._crContinuation q of Nothing -> throwError "no pact exec found in command result" Just pe -> return pe where - cid = CW._chainId bdb + cid = CW._chainId headerOracle -- | Extract a 'TransactionOutputProof' from a generic pact object -- -extractProof :: Bool -> Pact4.Object Pact4.Name -> Either Text (TransactionOutputProof SHA512t_256) +extractProof :: Bool -> Pact4.Object Pact4.Name -> Either Text (TransactionOutputProof ChainwebMerkleHashAlgorithm) extractProof False o = Pact4.toPactValue (Pact4.TObject o Pact4.noInfo) >>= k where k = aeson (Left . pack) Right @@ -374,16 +385,17 @@ ethResultToPactValue ReceiptProofValidation{..} = mkObject -- getTxIdx :: HasCallStack + => CW.HasVersion => CanReadablePayloadCas tbl => BlockHeaderDb -> PayloadDb tbl -> BlockHeight -> Pact4.PactHash -> IO (Either Text Int) -getTxIdx bdb pdb bh th = do +getTxIdx headerOracle pdb bh th = do -- get BlockPayloadHash - m <- maxEntry bdb - ph <- seekAncestor bdb m (int bh) >>= \case + m <- maxEntry headerOracle + ph <- seekAncestor headerOracle m (int bh) >>= \case Just x -> return $ Right $! view blockPayloadHash x Nothing -> return $ Left "unable to find payload associated with transaction hash" @@ -399,7 +411,7 @@ getTxIdx bdb pdb bh th = do & S.mapM toTxHash & sindex (== th) - r & note "unable to find transaction at the given block height" + r & maybe (Left "unable to find transaction at the given block height") Right & fmap int & return where diff --git a/src/Chainweb/Pact4/Templates.hs b/src/Chainweb/Pact4/Templates.hs index a8f62002bb..4859f2867c 100644 --- a/src/Chainweb/Pact4/Templates.hs +++ b/src/Chainweb/Pact4/Templates.hs @@ -4,6 +4,8 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE ViewPatterns #-} -- | -- Module : Chainweb.Pact.Templates @@ -19,8 +21,8 @@ module Chainweb.Pact4.Templates , mkBuyGasTerm , mkRedeemGasTerm , mkCoinbaseTerm - , mkCoinbaseCmd +, pattern MinerKeys ) where @@ -39,8 +41,11 @@ import Pact.Types.RPC import Pact.Types.Runtime import Chainweb.Miner.Pact -import Chainweb.Pact.Types -import Chainweb.Pact4.Types (GasSupply) +import Chainweb.Pact4.Types +import qualified Pact.Core.Guards as Pact5 +import qualified Pact.Types.Term as Pact +import Data.Aeson (decodeStrict) +import qualified Pact.Core.StableEncoding as Pact5 inf :: Info inf = Info $ Just (Code "",Parsed (Columns 0 0) 0) @@ -106,10 +111,10 @@ dummyParsedCode = ParsedCode "1" [ELiteral $ LiteralExp (LInteger 1) (Parsed mem mkFundTxTerm - :: MinerId -- ^ Id of the miner to fund - -> MinerKeys -- ^ Miner keyset - -> Text -- ^ Address of the sender from the command - -> GasSupply -- ^ The gas limit total * price + :: MinerId -- ^ Id of the miner to fund + -> MinerGuard -- ^ Miner keyset + -> Text -- ^ Address of the sender from the command + -> GasSupply -- ^ The gas limit total * price -> (Term Name,ExecMsg ParsedCode) mkFundTxTerm (MinerId mid) (MinerKeys ks) sender total = (populatedTerm, execMsg) where (term, senderS, minerS) = fundTxTemplate @@ -119,6 +124,7 @@ mkFundTxTerm (MinerId mid) (MinerKeys ks) sender total = (populatedTerm, execMsg [ "miner-keyset" J..= ks , "total" J..= total ] +mkFundTxTerm _ _ _ _ = error "invalid miner guard" {-# INLINABLE mkFundTxTerm #-} mkBuyGasTerm @@ -134,11 +140,11 @@ mkBuyGasTerm sender total = (populatedTerm, execMsg) {-# INLINABLE mkBuyGasTerm #-} mkRedeemGasTerm - :: MinerId -- ^ Id of the miner to fund - -> MinerKeys -- ^ Miner keyset - -> Text -- ^ Address of the sender from the command - -> GasSupply -- ^ The gas limit total * price - -> GasSupply -- ^ The gas used * price + :: MinerId -- ^ Id of the miner to fund + -> MinerGuard -- ^ Miner keyset + -> Text -- ^ Address of the sender from the command + -> GasSupply -- ^ The gas limit total * price + -> GasSupply -- ^ The gas used * price -> (Term Name,ExecMsg ParsedCode) mkRedeemGasTerm (MinerId mid) (MinerKeys ks) sender total fee = (populatedTerm, execMsg) where (term, senderS, minerS) = redeemGasTemplate @@ -149,6 +155,7 @@ mkRedeemGasTerm (MinerId mid) (MinerKeys ks) sender total fee = (populatedTerm, , "fee" J..= J.toJsonViaEncode fee , "miner-keyset" J..= ks ] +mkRedeemGasTerm _ _ _ _ _ = error "invalid miner guard" {-# INLINABLE mkRedeemGasTerm #-} coinbaseTemplate :: (Term Name,ASetter' (Term Name) Text) @@ -162,7 +169,7 @@ coinbaseTemplate = ) {-# NOINLINE coinbaseTemplate #-} -mkCoinbaseTerm :: MinerId -> MinerKeys -> ParsedDecimal -> (Term Name,ExecMsg ParsedCode) +mkCoinbaseTerm :: MinerId -> MinerGuard -> ParsedDecimal -> (Term Name,ExecMsg ParsedCode) mkCoinbaseTerm (MinerId mid) (MinerKeys ks) reward = (populatedTerm, execMsg) where (term, minerS) = coinbaseTemplate @@ -172,11 +179,12 @@ mkCoinbaseTerm (MinerId mid) (MinerKeys ks) reward = (populatedTerm, execMsg) [ "miner-keyset" J..= ks , "reward" J..= reward ] +mkCoinbaseTerm _ _ _ = error "invalid miner guard" {-# INLINABLE mkCoinbaseTerm #-} -- | "Old method" to build a coinbase 'ExecMsg' for back-compat. -- -mkCoinbaseCmd :: MinerId -> MinerKeys -> ParsedDecimal -> IO (ExecMsg ParsedCode) +mkCoinbaseCmd :: MinerId -> MinerGuard -> ParsedDecimal -> IO (ExecMsg ParsedCode) mkCoinbaseCmd (MinerId mid) (MinerKeys ks) reward = buildExecParsedCode $ mconcat [ "(coin.coinbase" @@ -199,5 +207,10 @@ mkCoinbaseCmd (MinerId mid) (MinerKeys ks) reward = -- if we can't construct coin contract calls, this should -- fail fast Left err -> internalError $ "buildExecParsedCode: parse failed: " <> pack err +mkCoinbaseCmd _ _ _ = error "invalid miner guard" {-# INLINABLE mkCoinbaseCmd #-} + +pattern MinerKeys :: Pact.KeySet -> MinerGuard +pattern MinerKeys ks <- + MinerGuard (Pact5.GKeyset (decodeStrict . J.encodeStrict . Pact5.StableEncoding -> Just ks)) diff --git a/src/Chainweb/Pact4/Transaction.hs b/src/Chainweb/Pact4/Transaction.hs index eb74a6f31b..88c31b5ed3 100644 --- a/src/Chainweb/Pact4/Transaction.hs +++ b/src/Chainweb/Pact4/Transaction.hs @@ -10,28 +10,28 @@ {-# LANGUAGE DeriveTraversable #-} module Chainweb.Pact4.Transaction - ( Transaction - , UnparsedTransaction - , unparseTransaction - , HashableTrans(..) - , PayloadWithText - , PactParserVersion(..) - , IsWebAuthnPrefixLegal(..) - , payloadCodec - , rawCommandCodec - , encodePayload - , decodePayload - , cmdGasLimit - , cmdGasPrice - , cmdTimeToLive - , cmdCreationTime - , mkPayloadWithText - , mkPayloadWithTextOld - , mkPayloadWithTextOldUnparsed - , payloadBytes - , payloadObj - , parsePact - ) where + ( Transaction + , UnparsedTransaction + , unparseTransaction + , HashableTrans(..) + , PayloadWithText + , PactParserVersion(..) + , IsWebAuthnPrefixLegal(..) + , payloadCodec + , rawCommandCodec + , encodePayload + , decodePayload + , cmdGasLimit + , cmdGasPrice + , cmdTimeToLive + , cmdCreationTime + , mkPayloadWithText + , mkPayloadWithTextOld + , mkPayloadWithTextOldUnparsed + , payloadBytes + , payloadObj + , parsePact + ) where import Control.DeepSeq import Control.Lens diff --git a/src/Chainweb/Pact4/TransactionExec.hs b/src/Chainweb/Pact4/TransactionExec.hs index 7d324be85b..e1f1e3db48 100644 --- a/src/Chainweb/Pact4/TransactionExec.hs +++ b/src/Chainweb/Pact4/TransactionExec.hs @@ -1,17 +1,20 @@ {-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE DataKinds #-} {-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE ImportQualifiedPost #-} {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MonoLocalBinds #-} {-# LANGUAGE MultiWayIf #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE MonoLocalBinds #-} +{-# LANGUAGE TypeApplications #-} + -- | -- Module : Chainweb.Pact4.TransactionExec -- Copyright : Copyright © 2018 Kadena LLC. @@ -37,7 +40,6 @@ module Chainweb.Pact4.TransactionExec , txMode , txDbEnv , txLogger - , txGasLogger , txPublicData , txSpvSupport , txNetworkId @@ -45,7 +47,6 @@ module Chainweb.Pact4.TransactionExec , txRequestKey , txExecutionConfig , txQuirkGasFee - , txTxFailuresCounter -- * Transaction Execution Monad , TransactionM(..) @@ -56,7 +57,6 @@ module Chainweb.Pact4.TransactionExec , applyCmd , applyGenesisCmd - , applyLocal , applyExec , applyExec' , applyContinuation @@ -87,6 +87,30 @@ module Chainweb.Pact4.TransactionExec ) where +import Chainweb.BlockCreationTime +import Chainweb.BlockHash +import Chainweb.BlockHeader +import Chainweb.BlockHeight +import Chainweb.ForkState (pact4ForkNumber) +import Chainweb.ChainId qualified as Chainweb +import Chainweb.Logger +import Chainweb.Miner.Pact +import Chainweb.Pact.Backend.ChainwebPactDb qualified as Pact5 +import Chainweb.Pact.Types (BlockCtx, guardCtx, _bctxCurrentBlockHeight, bctxParentCreationTime, bctxParentHash, bctxParentHeight) +import Chainweb.Pact4.Backend.ChainwebPactDb +import Chainweb.Pact4.ModuleCache +import Chainweb.Pact4.Templates +import Chainweb.Pact4.Transaction +import Chainweb.Pact4.Types +import Chainweb.Parent +import Chainweb.Ranked +import Chainweb.Time hiding (second) +import Chainweb.Utils +import Chainweb.VerifierPlugin +import Chainweb.Version as V +import Chainweb.Version.Guards as V +import Chainweb.Version.Utils as V +import Control.Concurrent.MVar import Control.DeepSeq import Control.Lens import Control.Monad @@ -95,30 +119,29 @@ import Control.Monad.Reader import Control.Monad.State.Strict import Control.Monad.Trans.Maybe import Control.Parallel.Strategies(using, rseq) - -import Data.Aeson hiding ((.=)) -import qualified Data.Aeson as A +import Data.Aeson hiding ((.=), Error) +import Data.Aeson qualified as A import Data.Bifunctor -import qualified Data.ByteString as B -import qualified Data.ByteString.Short as SB +import Data.ByteString qualified as B +import Data.ByteString.Short qualified as SB import Data.Decimal (Decimal, roundTo) -import Data.Foldable (fold, for_, traverse_) +import Data.Foldable (fold, for_) import Data.IORef -import qualified Data.List as List -import qualified Data.Map.Strict as M +import Data.Int (Int64) +import Data.List qualified as List +import Data.Map.Strict qualified as M import Data.Maybe -import qualified Data.Set as S +import Data.Set (Set) +import Data.Set qualified as S import Data.Text (Text) -import qualified Data.Text as T -import qualified System.LogLevel as L - --- internal Pact modules - -import Chainweb.Counter +import Data.Text qualified as T +import Pact.Core.Command.Types qualified as Pact5 +import Pact.Core.Errors (VerifierError(..)) +import Pact.Core.Gas qualified as Pact5 import Pact.Eval (eval, liftTerm) import Pact.Gas (freeGasEnv) import Pact.Interpreter -import qualified Pact.JSON.Encode as J +import Pact.JSON.Encode qualified as J import Pact.JSON.Legacy.Value import Pact.Native.Capabilities (evalCap) import Pact.Native.Internal (appToCap) @@ -127,43 +150,45 @@ import Pact.Runtime.Capabilities (popCapStack) import Pact.Runtime.Utils (lookupModule) import Pact.Types.Capability import Pact.Types.Command +import Pact.Types.Gas qualified as Pact import Pact.Types.Hash as Pact import Pact.Types.KeySet import Pact.Types.PactValue import Pact.Types.Pretty import Pact.Types.RPC -import Pact.Types.Runtime hiding (catchesPactError) -import Pact.Types.Server +import Pact.Types.Runtime hiding (Info, catchesPactError) import Pact.Types.SPV -import Pact.Types.Verifier - +import Pact.Types.Server import Pact.Types.Util as PU -import qualified Pact.Utils.StableHashMap as SHM - --- internal Chainweb modules +import Pact.Types.Verifier +import Pact.Utils.StableHashMap qualified as SHM +import System.LogLevel -import Chainweb.BlockHeader -import Chainweb.BlockHeight -import Chainweb.ForkState (pact4ForkNumber) -import Chainweb.Logger -import qualified Chainweb.ChainId as Chainweb -import Chainweb.Mempool.Mempool (pact4RequestKeyToTransactionHash) -import Chainweb.Miner.Pact -import Chainweb.Pact4.Templates -import Chainweb.Pact.Types -import Chainweb.Pact4.Types -import Chainweb.Pact4.Transaction -import Chainweb.Utils -import Chainweb.VerifierPlugin -import Chainweb.Version as V -import Chainweb.Version.Guards as V -import Chainweb.Version.Utils as V -import Pact.JSON.Encode (toJsonViaEncode) -import Data.Set (Set) -import Chainweb.Pact4.ModuleCache -import Chainweb.Pact4.Backend.ChainwebPactDb +-- | Convert context to datatype for Pact environment. +-- +-- Note that we use the grandparent block hash here. This was an accident which +-- we must preserve for backcompat. +-- +ctxToPublicData :: HasVersion => BlockEnv logger -> PublicMeta -> IO PublicData +ctxToPublicData blockenv pm = do + blockDbEnv <- readMVar $ blockenv ^. benvDbEnv . cpPactDbEnv . to pdPactDbVar + let sql = _blockHandlerDb $ _blockHandlerEnv blockDbEnv + let parentHeight = ctx ^. bctxParentHeight . _Parent + BlockHash bhsh <- + if parentHeight > succ (genesisHeight (view V.chainId ctx)) + then _ranked . fromJuste <$> Pact5.throwOnDbError (Pact5.lookupBlockWithHeight sql (pred parentHeight)) + else return $ view blockHash $ genesisBlockHeader (view V.chainId ctx) + return PublicData + { _pdPublicMeta = pm + , _pdBlockHeight = bh + , _pdBlockTime = bt + , _pdPrevBlockHash = toText bhsh + } + where + ctx = blockenv ^. benvBlockCtx + BlockHeight bh = _bctxCurrentBlockHeight ctx + BlockCreationTime (Time (TimeSpan (Micros !bt))) = ctx ^. bctxParentCreationTime . _Parent -import Pact.Core.Errors (VerifierError(..)) -- Note [Throw out verifier proofs eagerly] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -195,7 +220,6 @@ data TransactionEnv logger db = TransactionEnv { _txMode :: !ExecutionMode , _txDbEnv :: !(PactDbEnv db) , _txLogger :: !logger - , _txGasLogger :: !(Maybe logger) , _txPublicData :: !PublicData , _txSpvSupport :: !SPVSupport , _txNetworkId :: !(Maybe NetworkId) @@ -204,7 +228,6 @@ data TransactionEnv logger db = TransactionEnv , _txGasLimit :: !Gas , _txExecutionConfig :: !ExecutionConfig , _txQuirkGasFee :: !(Maybe Gas) - , _txTxFailuresCounter :: !(Maybe (Counter "txFailures")) } makeLenses ''TransactionEnv @@ -293,12 +316,18 @@ magic_GENESIS = mkMagicCapSlot "GENESIS" debitCap :: Text -> SigCapability debitCap s = mkCoinCap "DEBIT" [PLiteral (LString s)] -onChainErrorPrintingFor :: TxContext -> UnexpectedErrorPrinting -onChainErrorPrintingFor txCtx = - if guardCtx chainweb219Pact txCtx +onChainErrorPrintingFor :: HasVersion => BlockCtx -> UnexpectedErrorPrinting +onChainErrorPrintingFor bctx = + if guardCtx chainweb219Pact bctx then CensorsUnexpectedError else PrintsUnexpectedError +convertGasFeeFromPact5 :: Pact5.Gas -> Gas +convertGasFeeFromPact5 (Pact5.Gas g) = Pact.Gas (int @Pact5.SatWord @Int64 g) + +convertGasFeeToPact5 :: Gas -> Pact5.Gas +convertGasFeeToPact5 (Pact.Gas g) = Pact5.Gas (int @Int64 @Pact5.SatWord g) + -- | The main entry point to executing transactions. From here, -- 'applyCmd' assembles the command environment for a command and -- orchestrates gas buys/redemption, and executing payloads. @@ -307,21 +336,15 @@ onChainErrorPrintingFor txCtx = -- codepath later. -- applyCmd - :: (Logger logger) - => ChainwebVersion - -> logger + :: (Logger logger1, Logger logger2) + => HasVersion + => logger1 -- ^ Pact logger - -> Maybe logger - -- ^ Pact gas logger - -> Maybe (Counter "txFailures") - -> PactDbEnv p - -- ^ Pact db environment + -> BlockEnv logger2 -> Miner -- ^ The miner chosen to mine the block -> GasModel -- ^ Gas model (pact Service config) - -> TxContext - -- ^ tx metadata and parent header -> TxIdxInBlock -> SPVSupport -- ^ SPV support (validates cont proofs) @@ -331,22 +354,23 @@ applyCmd -- ^ initial gas used -> ModuleCache -- ^ cached module state - -> ApplyCmdExecutionContext - -- ^ is this a local or send execution context? -> IO (T3 (CommandResult [TxLogJson]) ModuleCache (S.Set PactWarning)) -applyCmd v logger gasLogger txFailuresCounter pdbenv miner gasModel txCtx txIdxInBlock spv cmd initialGas mcache0 callCtx = do - T2 cr st <- runTransactionM cenv txst applyBuyGas +applyCmd logger blockEnv miner gasModel txIdxInBlock spv cmd initialGas mcache0 = do + publicData <- ctxToPublicData blockEnv (publicMetaOf cmd) + T2 cr st <- runTransactionM (cenv publicData) txst applyBuyGas let cache = _txCache st warns = _txWarnings st pure $ T3 cr cache warns where + bctx = blockEnv ^. benvBlockCtx stGasModel | chainweb217Pact' = gasModel | otherwise = _geGasModel freeGasEnv txst = TransactionState mcache0 mempty 0 Nothing stGasModel mempty - quirkGasFee = v ^? versionQuirks . quirkGasFees . ixg cid . ix (ctxCurrentBlockHeight txCtx, txIdxInBlock) + quirkGasFee = fmap convertGasFeeFromPact5 $ + implicitVersion ^? versionQuirks . quirkGasFees . ixg cid . ix (_bctxCurrentBlockHeight bctx, txIdxInBlock) executionConfigNoHistory = ExecutionConfig $ S.singleton FlagDisableHistoryInTransactionalMode @@ -354,25 +378,25 @@ applyCmd v logger gasLogger txFailuresCounter pdbenv miner gasModel txCtx txIdxI ([ FlagOldReadOnlyBehavior | isPactBackCompatV16 ] ++ [ FlagPreserveModuleNameBug | not isModuleNameFix ] ++ [ FlagPreserveNsModuleInstallBug | not isModuleNameFix2 ]) - <> flagsFor v (ctxChainId txCtx) (ctxCurrentBlockHeight txCtx) + <> flagsFor (view V.chainId bctx) (_bctxCurrentBlockHeight bctx) - cenv = TransactionEnv Transactional pdbenv logger gasLogger (ctxToPublicData txCtx) spv nid gasPrice - requestKey (fromIntegral gasLimit) executionConfigNoHistory quirkGasFee txFailuresCounter + cenv publicData = + TransactionEnv Transactional (blockEnv ^. benvDbEnv . cpPactDbEnv) logger publicData spv nid gasPrice requestKey (fromIntegral gasLimit) executionConfigNoHistory quirkGasFee !requestKey = cmdToRequestKey cmd !gasPrice = view cmdGasPrice cmd !gasLimit = view cmdGasLimit cmd !nid = networkIdOf cmd - currHeight = ctxCurrentBlockHeight txCtx - cid = ctxChainId txCtx - isModuleNameFix = enableModuleNameFix v cid currHeight - isModuleNameFix2 = enableModuleNameFix2 v cid currHeight - isPactBackCompatV16 = pactBackCompat_v16 v cid currHeight - chainweb213Pact' = guardCtx chainweb213Pact txCtx - chainweb217Pact' = guardCtx chainweb217Pact txCtx - chainweb219Pact' = guardCtx chainweb219Pact txCtx - chainweb223Pact' = guardCtx chainweb223Pact txCtx - allVerifiers = verifiersAt v cid pact4ForkNumber currHeight + currHeight = _bctxCurrentBlockHeight bctx + cid = view V.chainId bctx + isModuleNameFix = enableModuleNameFix cid currHeight + isModuleNameFix2 = enableModuleNameFix2 cid currHeight + isPactBackCompatV16 = pactBackCompat_v16 cid currHeight + chainweb213Pact' = guardCtx chainweb213Pact bctx + chainweb217Pact' = guardCtx chainweb217Pact bctx + chainweb219Pact' = guardCtx chainweb219Pact bctx + chainweb223Pact' = guardCtx chainweb223Pact bctx + allVerifiers = verifiersAt cid pact4ForkNumber currHeight toEmptyPactError (PactError errty _ _ _) = PactError errty noInfo [] mempty toOldListErr pe = pe { peDoc = listErrMsg } @@ -385,20 +409,18 @@ applyCmd v logger gasLogger txFailuresCounter pdbenv miner gasModel txCtx txIdxI applyRedeem r applyBuyGas = - catchesPactError logger (onChainErrorPrintingFor txCtx) (buyGas txCtx cmd miner) >>= \case + catchesPactError logger (onChainErrorPrintingFor bctx) (buyGas bctx cmd miner) >>= \case Left e -> view txRequestKey >>= \rk -> - throwM $ Pact4BuyGasFailure $ Pact4GasPurchaseFailure (pact4RequestKeyToTransactionHash rk) e + throwM $ PactBuyGasFailure $ sshow (rk, e) Right _ -> checkTooBigTx initialGas gasLimit applyVerifiers redeemAllGas displayPactError e = do - r <- failTxWith e "tx failure for request key when running cmd" + r <- failTxWith e redeemAllGas r stripPactError e = do - let e' = case callCtx of - ApplyLocal -> e - ApplySend -> toEmptyPactError e - r <- failTxWith e' "tx failure for request key when running cmd" + let e' = toEmptyPactError e + r <- failTxWith e' redeemAllGas r applyVerifiers = do @@ -406,20 +428,24 @@ applyCmd v logger gasLogger txFailuresCounter pdbenv miner gasModel txCtx txIdxI then do gasUsed <- use txGasUsed let initGasRemaining = fromIntegral gasLimit - gasUsed + let p5Cmd = + either error id (fromJSON' @(Pact5.Command (Pact5.Payload Value Value)) + (J.toJsonViaEncode (cmd & cmdPayload . mapped %~ _pcCode))) + let p5Verifiers = p5Cmd ^. Pact5.cmdPayload . Pact5.pVerifiers verifierResult <- liftIO $ runVerifierPlugins - (ctxVersion txCtx, cid, currHeight) - logger allVerifiers initGasRemaining - (fromMaybe [] (cmd ^. cmdPayload . pVerifiers)) + (cid, currHeight) + logger allVerifiers (convertGasFeeToPact5 initGasRemaining) + -- don't do this conversion work if there are no verifiers (the usual case) + (fromMaybe [] (fromJuste p5Verifiers <$ cmd ^. cmdPayload . pVerifiers)) case verifierResult of Left err -> do let errMsg = "Tx verifier error: " <> _verifierError err cmdResult <- failTxWith (PactError TxFailure noInfo [] (pretty errMsg)) - errMsg redeemAllGas cmdResult Right verifierGasRemaining -> do - txGasUsed += initGasRemaining - verifierGasRemaining + txGasUsed += initGasRemaining - convertGasFeeFromPact5 verifierGasRemaining applyPayload else applyPayload @@ -428,7 +454,7 @@ applyCmd v logger gasLogger txFailuresCounter pdbenv miner gasModel txCtx txIdxI if chainweb217Pact' then txGasUsed += initialGas else txGasUsed .= initialGas - cr <- catchesPactError logger (onChainErrorPrintingFor txCtx) $! runPayload cmd managedNamespacePolicy + cr <- catchesPactError logger (onChainErrorPrintingFor bctx) $! runPayload cmd managedNamespacePolicy case cr of Left e -- 2.19 onwards errors return on chain @@ -437,14 +463,14 @@ applyCmd v logger gasLogger txFailuresCounter pdbenv miner gasModel txCtx txIdxI | chainweb217Pact' -> stripPactError e | chainweb213Pact' || not (isOldListErr e) -> displayPactError e | otherwise -> do - r <- failTxWith (toOldListErr e) "tx failure for request key when running cmd" + r <- failTxWith (toOldListErr e) redeemAllGas r Right r -> applyRedeem r applyRedeem cr = do txGasModel .= _geGasModel freeGasEnv - r <- catchesPactError logger (onChainErrorPrintingFor txCtx) $! redeemGas txCtx cmd miner + r <- catchesPactError logger (onChainErrorPrintingFor bctx) $! redeemGas bctx cmd miner case r of Left e -> -- redeem gas failure is fatal (block-failing) so miner doesn't lose coins @@ -455,11 +481,7 @@ applyCmd v logger gasLogger txFailuresCounter pdbenv miner gasModel txCtx txIdxI -- /local requires enriched results with metadata, while /send strips them. -- when ?preflight=true is set, make sure that metadata occurs in result. - let !cr' = case callCtx of - ApplySend -> set crLogs (Just logs) $ over crEvents (es ++) cr - ApplyLocal -> set crMetaData (Just $ J.toJsonViaEncode $ ctxToPublicData' txCtx) - $ set crLogs (Just logs) - $ over crEvents (es ++) cr + let !cr' = set crLogs (Just logs) $ over crEvents (es ++) cr return cr' @@ -469,18 +491,19 @@ listErrMsg = applyGenesisCmd :: (Logger logger) + => HasVersion => logger -- ^ Pact logger -> PactDbEnv p -- ^ Pact db environment -> SPVSupport -- ^ SPV support (validates cont proofs) - -> TxContext + -> BlockCtx -- ^ tx metadata -> Command (Payload PublicMeta ParsedCode) -- ^ command with payload to execute -> IO (T2 (CommandResult [TxLogJson]) ModuleCache) -applyGenesisCmd logger dbEnv spv txCtx cmd = +applyGenesisCmd logger dbEnv spv bctx cmd = second _txCache <$!> runTransactionM tenv txst go where nid = networkIdOf cmd @@ -489,7 +512,6 @@ applyGenesisCmd logger dbEnv spv txCtx cmd = { _txMode = Transactional , _txDbEnv = dbEnv , _txLogger = logger - , _txGasLogger = Nothing , _txPublicData = noPublicData , _txSpvSupport = spv , _txNetworkId = nid @@ -497,7 +519,7 @@ applyGenesisCmd logger dbEnv spv txCtx cmd = , _txRequestKey = rk , _txGasLimit = 0 , _txExecutionConfig = ExecutionConfig - $ flagsFor (ctxVersion txCtx) (ctxChainId txCtx) (view blockHeight $ ctxBlockHeader txCtx) + $ flagsFor (view V.chainId bctx) (_bctxCurrentBlockHeight bctx) -- TODO this is very ugly. Genesis blocks need to install keysets -- outside of namespaces so we need to disable Pact 4.4. It would be -- preferable to have a flag specifically for the namespaced keyset @@ -505,7 +527,6 @@ applyGenesisCmd logger dbEnv spv txCtx cmd = -- after the block height where pact4.4 is on. <> S.fromList [ FlagDisableInlineMemCheck, FlagDisablePact44 ] , _txQuirkGasFee = Nothing - , _txTxFailuresCounter = Nothing } txst = TransactionState { _txCache = mempty @@ -521,56 +542,55 @@ applyGenesisCmd logger dbEnv spv txCtx cmd = go = do -- TODO: fix with version recordification so that this matches the flags at genesis heights. - cr <- catchesPactError logger (onChainErrorPrintingFor txCtx) $! runGenesis cmd permissiveNamespacePolicy interp + cr <- catchesPactError logger (onChainErrorPrintingFor bctx) $! runGenesis cmd permissiveNamespacePolicy interp case cr of Left e -> fatal $ "Genesis command failed: " <> sshow e Right r -> r <$ debug "successful genesis tx for request key" -flagsFor :: ChainwebVersion -> V.ChainId -> BlockHeight -> S.Set ExecutionFlag -flagsFor v cid bh = S.fromList $ concat - [ enablePactEvents' v cid bh - , enablePact40 v cid bh - , enablePact42 v cid bh - , enforceKeysetFormats' v cid bh - , enablePactModuleMemcheck v cid bh - , enablePact43 v cid bh - , enablePact431 v cid bh - , enablePact44 v cid bh - , enablePact45 v cid bh - , enableNewTrans v cid bh - , enablePact46 v cid bh - , enablePact47 v cid bh - , enablePact48 v cid bh - , disableReturnRTC v cid bh - , enablePact49 v cid bh - , enablePact410 v cid bh - , enablePact411 v cid bh - , enablePact412 v cid bh +flagsFor :: HasVersion => V.ChainId -> BlockHeight -> S.Set ExecutionFlag +flagsFor cid bh = S.fromList $ concat + [ enablePactEvents' cid bh + , enablePact40 cid bh + , enablePact42 cid bh + , enforceKeysetFormats' cid bh + , enablePactModuleMemcheck cid bh + , enablePact43 cid bh + , enablePact431 cid bh + , enablePact44 cid bh + , enablePact45 cid bh + , enableNewTrans cid bh + , enablePact46 cid bh + , enablePact47 cid bh + , enablePact48 cid bh + , disableReturnRTC cid bh + , enablePact49 cid bh + , enablePact410 cid bh + , enablePact411 cid bh + , enablePact412 cid bh ] applyCoinbase - :: (Logger logger) - => ChainwebVersion - -> logger + :: (Logger logger1, Logger logger2) + => HasVersion + => logger1 -- ^ Pact logger - -> PactDbEnv p + -> BlockEnv logger2 -- ^ Pact db environment + -> Miner -> ParsedDecimal -- ^ Miner reward - -> TxContext - -- ^ tx metadata and parent header -> EnforceCoinbaseFailure -- ^ enforce coinbase failure or not -> CoinbaseUsePrecompiled -- ^ always enable precompilation -> ModuleCache -> IO (T2 (CommandResult [TxLogJson]) (Maybe ModuleCache)) -applyCoinbase v logger dbEnv reward@(ParsedDecimal d) txCtx +applyCoinbase logger blockEnv miner reward@(ParsedDecimal d) (EnforceCoinbaseFailure enfCBFailure) (CoinbaseUsePrecompiled enablePC) mc | fork1_3InEffect || enablePC = do when chainweb213Pact' $ enforceKeyFormats - (\k -> throwM $ CoinbaseFailure $ Pact4CoinbaseFailure $ "Invalid miner key: " <> sshow k) - (validKeyFormats v (ctxChainId txCtx) (ctxCurrentBlockHeight txCtx)) + (\k -> throwM $ CoinbaseFailure $ "Invalid miner key: " <> sshow k) + (validKeyFormats (view V.chainId bctx) (_bctxCurrentBlockHeight bctx)) mk let (cterm, cexec) = mkCoinbaseTerm mid mks reward interp = Interpreter $ \_ -> do put initState; fmap pure (eval cterm) @@ -581,165 +601,94 @@ applyCoinbase v logger dbEnv reward@(ParsedDecimal d) txCtx let interp = initStateInterpreter initState go interp cexec where - (Miner mid mks@(MinerKeys mk)) = _tcMiner txCtx - chainweb213Pact' = chainweb213Pact v cid bh - fork1_3InEffect = vuln797Fix v cid bh + bctx = blockEnv ^. benvBlockCtx + (mid, mks, mk) = case miner of + Miner mid' mks'@(MinerKeys mk') -> (mid', mks', mk') + Miner _ _ -> error "invalid miner guard" + chainweb213Pact' = chainweb213Pact cid bh + fork1_3InEffect = vuln797Fix cid bh throwCritical = fork1_3InEffect || enfCBFailure ec = ExecutionConfig $ S.delete FlagEnforceKeyFormats $ fold [ S.singleton FlagDisableModuleInstall , S.singleton FlagDisableHistoryInTransactionalMode - , flagsFor v (ctxChainId txCtx) (ctxCurrentBlockHeight txCtx) + , flagsFor (view V.chainId bctx) (_bctxCurrentBlockHeight bctx) ] - tenv = TransactionEnv Transactional dbEnv logger Nothing (ctxToPublicData txCtx) noSPVSupport - Nothing 0.0 rk 0 ec Nothing Nothing + tenv publicData = TransactionEnv Transactional (blockEnv ^. benvDbEnv . cpPactDbEnv) logger publicData noSPVSupport Nothing 0.0 rk 0 ec Nothing txst = TransactionState mc mempty 0 Nothing (_geGasModel freeGasEnv) mempty initState = setModuleCache mc $ initCapabilities [magic_COINBASE] rk = RequestKey chash - parent = _tcParentHeader txCtx - bh = ctxCurrentBlockHeight txCtx - cid = Chainweb._chainId parent - chash = Pact.Hash $ SB.toShort $ encodeToByteString $ view blockHash $ _parentHeader parent + bh = _bctxCurrentBlockHeight bctx + cid = Chainweb._chainId bctx + chash = Pact.Hash $ SB.toShort $ encodeToByteString $ bctx ^. (bctxParentHash . _Parent) -- NOTE: it holds that @ _pdPrevBlockHash pd == encode _blockHash@ -- NOTE: chash includes the /quoted/ text of the parent header. - go interp cexec = evalTransactionM tenv txst $! do - cr <- catchesPactError logger (onChainErrorPrintingFor txCtx) $ - applyExec' 0 interp cexec [] [] chash managedNamespacePolicy - - case cr of - Left e - | throwCritical -> throwM $ CoinbaseFailure $ Pact4CoinbaseFailure $ sshow e - | otherwise -> (`T2` Nothing) <$> failTxWith e "coinbase tx failure" - Right er -> do - debug - $! "successful coinbase of " - <> T.take 18 (sshow d) - <> " to " - <> sshow mid - - upgradedModuleCache <- applyUpgrades v cid bh - - logs <- use txLogs - - return $! T2 - CommandResult - { _crReqKey = rk - , _crTxId = _erTxId er - , _crResult = PactResult (Right (last (_erOutput er))) - , _crGas = _erGas er - , _crLogs = Just logs - , _crContinuation = _erExec er - , _crMetaData = Nothing - , _crEvents = _erEvents er - } - upgradedModuleCache - -applyLocal - :: (Logger logger) - => logger - -- ^ Pact logger - -> Maybe logger - -- ^ Pact gas logger - -> PactDbEnv p - -- ^ Pact db environment - -> GasModel - -- ^ Gas model (pact Service config) - -> TxContext - -- ^ tx metadata and parent header - -> SPVSupport - -- ^ SPV support (validates cont proofs) - -> Transaction - -- ^ command with payload to execute - -> ModuleCache - -> ExecutionConfig - -> IO (CommandResult [TxLogJson]) -applyLocal logger gasLogger dbEnv gasModel txCtx spv cmdIn mc execConfig = - evalTransactionM tenv txst go - where - !cmd = payloadObj <$> cmdIn `using` traverse rseq - !rk = cmdToRequestKey cmd - !nid = networkIdOf cmd - !chash = toUntypedHash $ _cmdHash cmd - !signers = _pSigners $ _cmdPayload cmd - !verifiers = fromMaybe [] $ _pVerifiers $ _cmdPayload cmd - !gasPrice = view cmdGasPrice cmd - !gasLimit = view cmdGasLimit cmd - tenv = TransactionEnv Local dbEnv logger gasLogger (ctxToPublicData txCtx) spv nid gasPrice - rk (fromIntegral gasLimit) execConfig Nothing Nothing - txst = TransactionState mc mempty 0 Nothing gasModel mempty - gas0 = initialGasOf (_cmdPayload cmdIn) - currHeight = ctxCurrentBlockHeight txCtx - cid = V._chainId txCtx - v = _chainwebVersion txCtx - - allVerifiers = verifiersAt v cid pact4ForkNumber currHeight - -- Note [Throw out verifier proofs eagerly] - !verifiersWithNoProof = - (fmap . fmap) (\_ -> ()) verifiers - `using` (traverse . traverse) rseq - - applyVerifiers m = do - let initGasRemaining = fromIntegral gasLimit - gas0 - verifierResult <- - liftIO $ runVerifierPlugins - (v, cid, currHeight) logger allVerifiers initGasRemaining - (fromMaybe [] $ cmd ^. cmdPayload . pVerifiers) - case verifierResult of - Left err -> do - let errMsg = "Tx verifier error: " <> _verifierError err - failTxWith - (PactError TxFailure noInfo [] (pretty errMsg)) - errMsg - Right verifierGasRemaining -> do - let gas1 = (initGasRemaining - verifierGasRemaining) + gas0 - applyPayload gas1 m - - applyPayload gas1 m = do - interp <- gasInterpreter gas1 - cr <- catchesPactError logger PrintsUnexpectedError $! case m of - Exec em -> - applyExec gas1 interp em signers verifiersWithNoProof chash managedNamespacePolicy - Continuation cm -> - applyContinuation gas1 interp cm signers chash managedNamespacePolicy - - case cr of - Left e -> failTxWith e "applyLocal" - Right r -> return $! r { _crMetaData = Just (J.toJsonViaEncode $ ctxToPublicData' txCtx) } - - go = checkTooBigTx gas0 gasLimit (applyVerifiers $ _pPayload $ _cmdPayload cmd) return + go interp cexec = do + publicData <- ctxToPublicData blockEnv noPublicMeta + evalTransactionM (tenv publicData) txst $! do + cr <- catchesPactError logger (onChainErrorPrintingFor bctx) $ + applyExec' 0 interp cexec [] [] chash managedNamespacePolicy + + case cr of + Left e + | throwCritical -> throwM $ CoinbaseFailure $ sshow e + | otherwise -> (`T2` Nothing) <$> failTxWith e + Right er -> do + debug + $! "successful coinbase of " + <> T.take 18 (sshow d) + <> " to " + <> sshow mid + + upgradedModuleCache <- applyUpgrades cid bh + + logs <- use txLogs + + return $! T2 + CommandResult + { _crReqKey = rk + , _crTxId = _erTxId er + , _crResult = PactResult (Right (last (_erOutput er))) + , _crGas = _erGas er + , _crLogs = Just logs + , _crContinuation = _erExec er + , _crMetaData = Nothing + , _crEvents = _erEvents er + } + upgradedModuleCache readInitModules - :: forall logger tbl. (Logger logger) - => PactBlockM logger tbl ModuleCache -readInitModules = do - logger <- view (psServiceEnv . psLogger) - dbEnv <- view (psBlockDbEnv . to _cpPactDbEnv) - txCtx <- getTxContext noMiner noPublicMeta + :: forall logger1 logger2 + . (Logger logger1, Logger logger2) + => HasVersion + => logger1 + -> BlockEnv logger2 + -> IO ModuleCache +readInitModules logger blockEnv = do + let bctx = view benvBlockCtx blockEnv -- guarding chainweb 2.17 here to allow for -- cache purging everything but coin and its -- dependencies. let - chainweb217Pact' = guardCtx chainweb217Pact txCtx - chainweb224Pact' = guardCtx chainweb224Pact txCtx + chainweb217Pact' = guardCtx chainweb217Pact bctx + chainweb224Pact' = guardCtx chainweb224Pact bctx - parent = _tcParentHeader txCtx - v = ctxVersion txCtx - cid = ctxChainId txCtx - h = view blockHeight (_parentHeader parent) + 1 + cid = view V.chainId bctx + h = _bctxCurrentBlockHeight bctx rk = RequestKey chash nid = Nothing chash = pactInitialHash - tenv = TransactionEnv Local dbEnv logger Nothing (ctxToPublicData txCtx) noSPVSupport nid 0.0 - rk 0 emptyExecutionConfig Nothing Nothing + tenv publicData = TransactionEnv Local (blockEnv ^. benvDbEnv . cpPactDbEnv) logger publicData noSPVSupport nid 0.0 + rk 0 emptyExecutionConfig Nothing txst = TransactionState mempty mempty 0 Nothing (_geGasModel freeGasEnv) mempty interp = defaultInterpreter die msg = internalError $ "readInitModules: " <> msg - mkCmd = buildExecParsedCode (pact4ParserVersion v cid h) Nothing - run :: Text -> ExecMsg ParsedCode -> TransactionM logger p PactValue + mkCmd = buildExecParsedCode (pact4ParserVersion cid h) Nothing + run :: Text -> ExecMsg ParsedCode -> TransactionM logger1 p PactValue run msg cmd = do - er <- catchesPactError logger (onChainErrorPrintingFor txCtx) $! + er <- catchesPactError logger (onChainErrorPrintingFor bctx) $! applyExec' 0 interp cmd [] [] chash permissiveNamespacePolicy case er of Left e -> die $ msg <> ": failed: " <> sshow e @@ -748,7 +697,7 @@ readInitModules = do (o:_) -> return o - go :: TransactionM logger p ModuleCache + go :: TransactionM logger1 p ModuleCache go = do -- see if fungible-v2 is there @@ -783,16 +732,16 @@ readInitModules = do -- requires a block height that witnesses the invariant. -- -- if this changes, we must change the filter in 'updateInitCache' - goCw217 :: TransactionM logger p ModuleCache + goCw217 :: TransactionM logger1 p ModuleCache goCw217 = do coinDepCmd <- liftIO $ mkCmd "coin.MINIMUM_PRECISION" void $ run "load modules" coinDepCmd use txCache - + publicData <- ctxToPublicData blockEnv noPublicMeta if | chainweb224Pact' -> pure mempty - | chainweb217Pact' -> liftIO $ evalTransactionM tenv txst goCw217 - | otherwise -> liftIO $ evalTransactionM tenv txst go + | chainweb217Pact' -> liftIO $ evalTransactionM (tenv publicData) txst goCw217 + | otherwise -> liftIO $ evalTransactionM (tenv publicData) txst go -- | Apply (forking) upgrade transactions and module cache updates -- at a particular blockheight. @@ -806,16 +755,15 @@ readInitModules = do applyUpgrades :: forall logger p . (Logger logger) - => ChainwebVersion - -> Chainweb.ChainId + => HasVersion => Chainweb.ChainId -> BlockHeight -> TransactionM logger p (Maybe ModuleCache) -applyUpgrades v cid height +applyUpgrades cid height | Just Pact4Upgrade{_pact4UpgradeTransactions = txs, _legacyUpgradeIsPrecocious = isPrecocious} <- - v ^? versionUpgrades . atChain cid . ix height = applyUpgrade txs isPrecocious + implicitVersion ^? versionUpgrades . atChain cid . ix height = applyUpgrade txs isPrecocious | Just Pact5Upgrade{} <- - v ^? versionUpgrades . atChain cid . ix height = error "Expected Pact 4 upgrade, got Pact 5" - | cleanModuleCache v cid height = filterModuleCache + implicitVersion ^? versionUpgrades . atChain cid . ix height = error "Expected Pact 4 upgrade, got Pact 5" + | cleanModuleCache cid height = filterModuleCache | otherwise = return Nothing where installCoinModuleAdmin = set (evalCapabilities . capModuleAdmin) $ S.singleton (ModuleName "coin" Nothing) @@ -836,7 +784,7 @@ applyUpgrades v cid height -- init cache in the pact service state (_psInitCache). -- - let flags = flagsFor v cid (if isPrecocious then height + 1 else height) + let flags = flagsFor cid (if isPrecocious then height + 1 else height) caches <- local (txExecutionConfig .~ ExecutionConfig flags) (mapM applyTx payloads) @@ -858,18 +806,11 @@ applyUpgrades v cid height failTxWith :: (Logger logger) => PactError - -> Text -> TransactionM logger p (CommandResult [TxLogJson]) -failTxWith err msg = do +failTxWith err = do logs <- use txLogs gas <- view txGasLimit -- error means all gas was charged rk <- view txRequestKey - l <- view txLogger - - liftIO $ logFunction l L.Debug - (Pact4TxFailureLog rk err msg) - liftIO . traverse_ inc - =<< view txTxFailuresCounter return $! CommandResult rk Nothing (PactResult (Left err)) gas (Just logs) Nothing Nothing [] @@ -881,7 +822,7 @@ runPayload -> TransactionM logger p (CommandResult [TxLogJson]) runPayload cmd nsp = do g0 <- use txGasUsed - interp <- gasInterpreter g0 + interp <- gasInterpreter -- Note [Throw out verifier proofs eagerly] let !verifiersWithNoProof = @@ -938,7 +879,6 @@ applyExec -> TransactionM logger p (CommandResult [TxLogJson]) applyExec initialGas interp em senderSigs verifiers hsh nsp = do EvalResult{..} <- applyExec' initialGas interp em senderSigs verifiers hsh nsp - for_ _erLogGas $ \gl -> gasLog $ "gas logs: " <> sshow gl !logs <- use txLogs !rk <- view txRequestKey @@ -989,60 +929,60 @@ applyExec' initialGas interp (ExecMsg parsedCode execData) senderSigs verifiersW return quirkedEvalResult -enablePactEvents' :: ChainwebVersion -> V.ChainId -> BlockHeight -> [ExecutionFlag] -enablePactEvents' v cid bh = [FlagDisablePactEvents | not (enablePactEvents v cid bh)] +enablePactEvents' :: HasVersion => V.ChainId -> BlockHeight -> [ExecutionFlag] +enablePactEvents' cid bh = [FlagDisablePactEvents | not (enablePactEvents cid bh)] -enforceKeysetFormats' :: ChainwebVersion -> V.ChainId -> BlockHeight -> [ExecutionFlag] -enforceKeysetFormats' v cid bh = [FlagEnforceKeyFormats | enforceKeysetFormats v cid bh] +enforceKeysetFormats' :: HasVersion => V.ChainId -> BlockHeight -> [ExecutionFlag] +enforceKeysetFormats' cid bh = [FlagEnforceKeyFormats | enforceKeysetFormats cid bh] -enablePact40 :: ChainwebVersion -> V.ChainId -> BlockHeight -> [ExecutionFlag] -enablePact40 v cid bh = [FlagDisablePact40 | not (pact4Coin3 v cid bh)] +enablePact40 :: HasVersion => V.ChainId -> BlockHeight -> [ExecutionFlag] +enablePact40 cid bh = [FlagDisablePact40 | not (pact4Coin3 cid bh)] -enablePact42 :: ChainwebVersion -> V.ChainId -> BlockHeight -> [ExecutionFlag] -enablePact42 v cid bh = [FlagDisablePact42 | not (pact42 v cid bh)] +enablePact42 :: HasVersion => V.ChainId -> BlockHeight -> [ExecutionFlag] +enablePact42 cid bh = [FlagDisablePact42 | not (pact42 cid bh)] -enablePactModuleMemcheck :: ChainwebVersion -> V.ChainId -> BlockHeight -> [ExecutionFlag] -enablePactModuleMemcheck v cid bh = [FlagDisableInlineMemCheck | not (chainweb213Pact v cid bh)] +enablePactModuleMemcheck :: HasVersion => V.ChainId -> BlockHeight -> [ExecutionFlag] +enablePactModuleMemcheck cid bh = [FlagDisableInlineMemCheck | not (chainweb213Pact cid bh)] -enablePact43 :: ChainwebVersion -> V.ChainId -> BlockHeight -> [ExecutionFlag] -enablePact43 v cid bh = [FlagDisablePact43 | not (chainweb214Pact v cid bh)] +enablePact43 :: HasVersion => V.ChainId -> BlockHeight -> [ExecutionFlag] +enablePact43 cid bh = [FlagDisablePact43 | not (chainweb214Pact cid bh)] -enablePact431 :: ChainwebVersion -> V.ChainId -> BlockHeight -> [ExecutionFlag] -enablePact431 v cid bh = [FlagDisablePact431 | not (chainweb215Pact v cid bh)] +enablePact431 :: HasVersion => V.ChainId -> BlockHeight -> [ExecutionFlag] +enablePact431 cid bh = [FlagDisablePact431 | not (chainweb215Pact cid bh)] -enablePact44 :: ChainwebVersion -> V.ChainId -> BlockHeight -> [ExecutionFlag] -enablePact44 v cid bh = [FlagDisablePact44 | not (chainweb216Pact v cid bh)] +enablePact44 :: HasVersion => V.ChainId -> BlockHeight -> [ExecutionFlag] +enablePact44 cid bh = [FlagDisablePact44 | not (chainweb216Pact cid bh)] -enablePact45 :: ChainwebVersion -> V.ChainId -> BlockHeight -> [ExecutionFlag] -enablePact45 v cid bh = [FlagDisablePact45 | not (chainweb217Pact v cid bh)] +enablePact45 :: HasVersion => V.ChainId -> BlockHeight -> [ExecutionFlag] +enablePact45 cid bh = [FlagDisablePact45 | not (chainweb217Pact cid bh)] -enableNewTrans :: ChainwebVersion -> V.ChainId -> BlockHeight -> [ExecutionFlag] -enableNewTrans v cid bh = [FlagDisableNewTrans | not (pact44NewTrans v cid bh)] +enableNewTrans :: HasVersion => V.ChainId -> BlockHeight -> [ExecutionFlag] +enableNewTrans cid bh = [FlagDisableNewTrans | not (pact44NewTrans cid bh)] -enablePact46 :: ChainwebVersion -> V.ChainId -> BlockHeight -> [ExecutionFlag] -enablePact46 v cid bh = [FlagDisablePact46 | not (chainweb218Pact v cid bh)] +enablePact46 :: HasVersion => V.ChainId -> BlockHeight -> [ExecutionFlag] +enablePact46 cid bh = [FlagDisablePact46 | not (chainweb218Pact cid bh)] -enablePact47 :: ChainwebVersion -> V.ChainId -> BlockHeight -> [ExecutionFlag] -enablePact47 v cid bh = [FlagDisablePact47 | not (chainweb219Pact v cid bh)] +enablePact47 :: HasVersion => V.ChainId -> BlockHeight -> [ExecutionFlag] +enablePact47 cid bh = [FlagDisablePact47 | not (chainweb219Pact cid bh)] -enablePact48 :: ChainwebVersion -> V.ChainId -> BlockHeight -> [ExecutionFlag] -enablePact48 v cid bh = [FlagDisablePact48 | not (chainweb220Pact v cid bh)] +enablePact48 :: HasVersion => V.ChainId -> BlockHeight -> [ExecutionFlag] +enablePact48 cid bh = [FlagDisablePact48 | not (chainweb220Pact cid bh)] -enablePact49 :: ChainwebVersion -> V.ChainId -> BlockHeight -> [ExecutionFlag] -enablePact49 v cid bh = [FlagDisablePact49 | not (chainweb221Pact v cid bh)] +enablePact49 :: HasVersion => V.ChainId -> BlockHeight -> [ExecutionFlag] +enablePact49 cid bh = [FlagDisablePact49 | not (chainweb221Pact cid bh)] -enablePact410 :: ChainwebVersion -> V.ChainId -> BlockHeight -> [ExecutionFlag] -enablePact410 v cid bh = [FlagDisablePact410 | not (chainweb222Pact v cid bh)] +enablePact410 :: HasVersion => V.ChainId -> BlockHeight -> [ExecutionFlag] +enablePact410 cid bh = [FlagDisablePact410 | not (chainweb222Pact cid bh)] -enablePact411 :: ChainwebVersion -> V.ChainId -> BlockHeight -> [ExecutionFlag] -enablePact411 v cid bh = [FlagDisablePact411 | not (chainweb223Pact v cid bh)] +enablePact411 :: HasVersion => V.ChainId -> BlockHeight -> [ExecutionFlag] +enablePact411 cid bh = [FlagDisablePact411 | not (chainweb223Pact cid bh)] -enablePact412 :: ChainwebVersion -> V.ChainId -> BlockHeight -> [ExecutionFlag] -enablePact412 v cid bh = [FlagDisablePact412 | not (chainweb224Pact v cid bh)] +enablePact412 :: HasVersion => V.ChainId -> BlockHeight -> [ExecutionFlag] +enablePact412 cid bh = [FlagDisablePact412 | not (chainweb224Pact cid bh)] -- | Even though this is not forking, abstracting for future shutoffs -disableReturnRTC :: ChainwebVersion -> V.ChainId -> BlockHeight -> [ExecutionFlag] -disableReturnRTC _v _cid _bh = [FlagDisableRuntimeReturnTypeChecking] +disableReturnRTC :: HasVersion => V.ChainId -> BlockHeight -> [ExecutionFlag] +disableReturnRTC _cid _bh = [FlagDisableRuntimeReturnTypeChecking] -- | Execute a 'ContMsg' and return the command result and module cache -- @@ -1057,7 +997,6 @@ applyContinuation -> TransactionM logger p (CommandResult [TxLogJson]) applyContinuation initialGas interp cm senderSigs hsh nsp = do EvalResult{..} <- applyContinuation' initialGas interp cm senderSigs hsh nsp - for_ _erLogGas $ \gl -> gasLog $ "gas logs: " <> sshow gl logs <- use txLogs rk <- view txRequestKey @@ -1108,17 +1047,20 @@ applyContinuation' initialGas interp cm@(ContMsg pid s rb d _) senderSigs hsh ns -- -- see: 'pact/coin-contract/coin.pact#fund-tx' -- -buyGas :: (Logger logger) => TxContext -> Command (Payload PublicMeta ParsedCode) -> Miner -> TransactionM logger p () -buyGas txCtx cmd (Miner mid mks) = go +buyGas + :: (Logger logger) + => HasVersion + => BlockCtx -> Command (Payload PublicMeta ParsedCode) -> Miner -> TransactionM logger p () +buyGas bctx cmd (Miner mid mks) = go where - isChainweb224Pact = guardCtx chainweb224Pact txCtx + isChainweb224Pact = guardCtx chainweb224Pact bctx sender = view (cmdPayload . pMeta . pmSender) cmd initState mc logGas = set evalLogGas (guard logGas >> Just [("GBuyGas",0)]) $ setModuleCache mc $ initCapabilities [magic_GAS] run input = do - (findPayer txCtx cmd) >>= \r -> case r of + (findPayer bctx cmd) >>= \r -> case r of Nothing -> input Just withPayerCap -> withPayerCap input @@ -1128,7 +1070,6 @@ buyGas txCtx cmd (Miner mid mks) = go go = do mcache <- use txCache supply <- gasSupplyOf <$> view txGasLimit <*> view txGasPrice - logGas <- isJust <$> view txGasLogger let (buyGasTerm, buyGasCmd) = -- post-chainweb 2.24, we call buy-gas directly rather than @@ -1140,7 +1081,7 @@ buyGas txCtx cmd (Miner mid mks) = go -- that ignores its argument and instead executes a term -- of our choice. we do the same to redeem gas. interp mc = Interpreter $ \_input -> - put (initState mc logGas) >> run (pure <$> eval buyGasTerm) + put (initState mc False) >> run (pure <$> eval buyGasTerm) let gasCapName = QualifiedName (ModuleName "coin" Nothing) "GAS" noInfo @@ -1174,10 +1115,11 @@ buyGas txCtx cmd (Miner mid mks) = go void $! txGasId .= (Just $! GasId (_pePactId pe)) findPayer - :: TxContext + :: HasVersion + => BlockCtx -> Command (Payload PublicMeta ParsedCode) -> Eval e (Maybe (Eval e [Term Name] -> Eval e [Term Name])) -findPayer txCtx cmd = runMaybeT $ do +findPayer bctx cmd = runMaybeT $ do (!m,!qn,!as) <- MaybeT findPayerCap pMod <- MaybeT $ lookupModule qn m capRef <- MaybeT $ return $ lookupIfaceModRef qn pMod @@ -1202,7 +1144,7 @@ findPayer txCtx cmd = runMaybeT $ do runCap i capRef as input = do let msgBody = enrichedMsgBody cmd - enrichMsgBody | guardCtx pactBackCompat_v16 txCtx = id + enrichMsgBody | guardCtx pactBackCompat_v16 bctx = id | otherwise = setEnvMsgBody (toLegacyJson msgBody) ar <- local enrichMsgBody $ do (cap, capDef, args) <- appToCap $ mkApp i capRef as @@ -1223,11 +1165,11 @@ enrichedMsgBody cmd = case (_pPayload $ _cmdPayload cmd) of , "exec-user-data" A..= pactFriendlyUserData (_getLegacyValue userData) ] Continuation (ContMsg pid step isRollback userData proof) -> object [ "tx-type" A..= ("cont" :: Text) - , "cont-pact-id" A..= toJsonViaEncode pid - , "cont-step" A..= toJsonViaEncode (LInteger $ toInteger step) - , "cont-is-rollback" A..= toJsonViaEncode (LBool isRollback) + , "cont-pact-id" A..= J.toJsonViaEncode pid + , "cont-step" A..= J.toJsonViaEncode (LInteger $ toInteger step) + , "cont-is-rollback" A..= J.toJsonViaEncode (LBool isRollback) , "cont-user-data" A..= pactFriendlyUserData (_getLegacyValue userData) - , "cont-has-proof" A..= toJsonViaEncode (isJust proof) + , "cont-has-proof" A..= J.toJsonViaEncode (isJust proof) ] where pactFriendlyUserData Null = object [] @@ -1238,13 +1180,19 @@ enrichedMsgBody cmd = case (_pPayload $ _cmdPayload cmd) of -- -- see: 'pact/coin-contract/coin.pact#fund-tx' -- -redeemGas :: (Logger logger) => TxContext -> Command (Payload PublicMeta ParsedCode) -> Miner -> TransactionM logger p [PactEvent] -redeemGas txCtx cmd (Miner mid mks) = do +redeemGas + :: (Logger logger) + => HasVersion + => BlockCtx + -> Command (Payload PublicMeta ParsedCode) + -> Miner + -> TransactionM logger p [PactEvent] +redeemGas bctx cmd (Miner mid mks) = do mcache <- use txCache let sender = view (cmdPayload . pMeta . pmSender) cmd fee <- gasSupplyOf <$> use txGasUsed <*> view txGasPrice -- if we're past chainweb 2.24, we don't use defpacts for gas - if guardCtx chainweb224Pact txCtx + if guardCtx chainweb224Pact bctx then do total <- gasSupplyOf <$> view txGasLimit <*> view txGasPrice let (redeemGasTerm, redeemGasCmd) = @@ -1270,7 +1218,7 @@ redeemGas txCtx cmd (Miner mid mks) = do Nothing -> fatal $! "redeemGas: no gas id in scope for gas refunds" Just g -> return g let redeemGasCmd = - ContMsg gid 1 False (toLegacyJson $ object [ "fee" A..= toJsonViaEncode fee ]) Nothing + ContMsg gid 1 False (toLegacyJson $ object [ "fee" A..= J.toJsonViaEncode fee ]) Nothing fmap _crEvents $ locally txQuirkGasFee (const Nothing) $ applyContinuation 0 (initState mcache) redeemGasCmd @@ -1314,16 +1262,15 @@ checkTooBigTx initialGas gasLimit next onFail $ "Tx too big (" <> pretty initialGas <> "), limit " <> pretty gasLimit - r <- failTxWith pe "Tx too big" + r <- failTxWith pe onFail r | otherwise = next -gasInterpreter :: Gas -> TransactionM logger db (Interpreter p) -gasInterpreter g = do +gasInterpreter :: TransactionM logger db (Interpreter p) +gasInterpreter = do mc <- use txCache - logGas <- isJust <$> view txGasLogger return $ initStateInterpreter - $ set evalLogGas (guard logGas >> Just [("GTxSize",g)]) -- enables gas logging + $ set evalLogGas Nothing -- enables gas logging $ setModuleCache mc emptyEvalState @@ -1520,20 +1467,13 @@ toCoinUnit :: Decimal -> Decimal toCoinUnit = roundTo 12 {-# INLINE toCoinUnit #-} -gasLog :: (Logger logger) => Text -> TransactionM logger db () -gasLog m = do - l <- view txGasLogger - rk <- view txRequestKey - for_ l $ \logger -> - logInfo_ logger $ m <> ": " <> sshow rk - -- | Log request keys at DEBUG when successful -- debug :: (Logger logger) => Text -> TransactionM logger db () debug s = do l <- view txLogger rk <- view txRequestKey - logDebug_ l $ s <> ": " <> sshow rk + liftIO $ logFunctionText l Debug $ s <> ": " <> sshow rk -- | Denotes fatal failure points in the tx exec process -- @@ -1542,14 +1482,14 @@ fatal e = do l <- view txLogger rk <- view txRequestKey - logError_ l + liftIO $ logFunctionText l Error $ "critical transaction failure: " <> sshow rk <> ": " <> e throwM $ PactTransactionExecError (fromUntypedHash $ unRequestKey rk) e logError :: (Logger logger) => Text -> TransactionM logger db () -logError msg = view txLogger >>= \l -> logError_ l msg +logError msg = view txLogger >>= \l -> liftIO $ logFunctionText l Error msg infoLog :: (Logger logger) => Text -> TransactionM logger db () -infoLog msg = view txLogger >>= \l -> logInfo_ l msg +infoLog msg = view txLogger >>= \l -> liftIO $ logFunctionText l Info msg diff --git a/src/Chainweb/Pact4/Types.hs b/src/Chainweb/Pact4/Types.hs index 92ad20eb0a..72353b4c17 100644 --- a/src/Chainweb/Pact4/Types.hs +++ b/src/Chainweb/Pact4/Types.hs @@ -1,84 +1,91 @@ {-# LANGUAGE BangPatterns #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE DataKinds #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE ImportQualifiedPost #-} {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} module Chainweb.Pact4.Types - ( getInitCache - , updateInitCache - , updateInitCacheM - - , GasSupply(..) + ( GasSupply(..) -- * TxContext - , TxContext(..) - , ctxToPublicData - , ctxToPublicData' - , ctxBlockHeader - , ctxCurrentBlockHeight - , ctxChainId - , ctxVersion - , guardCtx - , getTxContext - , localLabelBlock + -- , TxContext(..) + -- , tcParentHeader + -- , tcPublicMeta + -- , tcMiner + -- , tcIsGenesis + -- , ctxToPublicData + -- , ctxToPublicData' + -- , ctxBlockHeader + -- , ctxCurrentBlockHeight + -- , ctxParentBlockHeight + -- , ctxChainId + -- , guardCtx + -- , getTxContext , catchesPactError , UnexpectedErrorPrinting(..) , GasId(..) , EnforceCoinbaseFailure(..) , CoinbaseUsePrecompiled(..) - , PactBlockM(..) - , liftPactServiceM - , runPactBlockM - , tracePactBlockM - , tracePactBlockM' + , internalError + , PactInternalError(..) + , SQLiteRowDelta(..) + , SQLitePendingData(..) + , emptySQLitePendingData + , pendingTableCreation + , pendingWrites + , pendingTxLogMap + , pendingSuccessfulTxs + , toPayloadWithOutputs + , TxTimeout(..) , getGasModel ) where +import Chainweb.Logger +import Chainweb.Miner.Pact +import Chainweb.Pact.Payload(PayloadWithOutputs, newBlockOutputs, blockPayload, payloadData, payloadWithOutputs, newBlockTransactions, Transaction (..), TransactionOutput (..), CoinbaseOutput (..)) +import Chainweb.Pact.Types (Transactions(..), BlockCtx, guardCtx) +import Chainweb.Pact4.Transaction qualified as Pact +import Chainweb.Utils +import Chainweb.Version +import Chainweb.Version.Guards import Control.Exception.Safe import Control.Lens import Control.Monad.Reader -import Control.Monad.State.Strict - import Data.Aeson hiding (Error,(.=)) -import qualified Data.Map.Strict as M +import Data.ByteString (ByteString) +import Data.ByteString.Short qualified as SB +import Data.DList (DList) +import Data.HashMap.Strict (HashMap) +import Data.HashSet (HashSet) +import Data.List.NonEmpty (NonEmpty) +import Data.Map.Strict qualified as M import Data.Text (Text) - --- internal pact modules - -import qualified Pact.JSON.Encode as J +import Data.Text qualified as T +import Data.Text.Encoding qualified as T +import GHC.Generics +import GHC.Stack (CallStack, HasCallStack, callStack) +import Pact.Gas.Table +import Pact.JSON.Encode qualified as J import Pact.Parse (ParsedDecimal) -import Pact.Types.ChainMeta +import Pact.Types.Command import Pact.Types.Gas import Pact.Types.Info +import Pact.Types.Persistence qualified as Pact import Pact.Types.Pretty (viaShow) import Pact.Types.Runtime (PactError(..), PactErrorType(..)) +import Pact.Types.Runtime qualified as Pact import Pact.Types.Term - --- internal chainweb modules - -import Chainweb.BlockCreationTime -import Chainweb.BlockHash -import Chainweb.BlockHeader -import Chainweb.BlockHeight -import Chainweb.ChainId -import Chainweb.Miner.Pact -import Chainweb.Logger -import Chainweb.Time -import Chainweb.Utils -import Chainweb.Version -import Utils.Logging.Trace - -import Pact.Gas.Table -import Chainweb.Pact.Types -import Chainweb.Pact4.ModuleCache -import Chainweb.Version.Guards +import System.LogLevel -- | Indicates a computed gas charge (gas amount * gas price) @@ -90,166 +97,46 @@ instance Show GasSupply where show (GasSupply g) = show g instance J.Encode GasSupply where build = J.build . _gasSupply --- | Update init cache at adjusted parent block height (APBH). --- Contents are merged with cache found at or before APBH. --- APBH is 0 for genesis and (parent block height + 1) thereafter. -updateInitCache :: ModuleCache -> ParentHeader -> PactServiceM logger tbl () -updateInitCache mc ph = get >>= \PactServiceState{..} -> do - let bf 0 = 0 - bf h = succ h - let pbh = bf (view blockHeight $ _parentHeader ph) - - v <- view psVersion - cid <- view chainId - - psInitCache .= case M.lookupLE pbh _psInitCache of - Nothing -> M.singleton pbh mc - Just (_,before) - | cleanModuleCache v cid pbh -> - M.insert pbh mc _psInitCache - | otherwise -> M.insert pbh (before <> mc) _psInitCache - --- | Pair parent header with transaction metadata. --- In cases where there is no transaction/Command, 'PublicMeta' --- default value is used. -data TxContext = TxContext - { _tcParentHeader :: !ParentHeader - , _tcPublicMeta :: !PublicMeta - , _tcMiner :: !Miner - } deriving Show - -instance HasChainId TxContext where - _chainId = _chainId . _tcParentHeader -instance HasChainwebVersion TxContext where - _chainwebVersion = _chainwebVersion . _tcParentHeader - --- | Convert context to datatype for Pact environment. --- --- TODO: this should be deprecated, since the `ctxBlockHeader` --- call fetches a grandparent, not the parent. --- -ctxToPublicData :: TxContext -> PublicData -ctxToPublicData ctx = PublicData - { _pdPublicMeta = _tcPublicMeta ctx - , _pdBlockHeight = bh - , _pdBlockTime = bt - , _pdPrevBlockHash = toText hsh - } - where - h = ctxBlockHeader ctx - BlockHeight bh = ctxCurrentBlockHeight ctx - BlockCreationTime (Time (TimeSpan (Micros !bt))) = view blockCreationTime h - BlockHash hsh = view blockParent h - --- | Convert context to datatype for Pact environment using the --- current blockheight, referencing the parent header (not grandparent!) --- hash and blocktime data --- -ctxToPublicData' :: TxContext -> PublicData -ctxToPublicData' ctx = PublicData - { _pdPublicMeta = _tcPublicMeta ctx - , _pdBlockHeight = bh - , _pdBlockTime = bt - , _pdPrevBlockHash = toText h - } - where - bheader = _parentHeader (_tcParentHeader ctx) - BlockHeight !bh = succ $ view blockHeight bheader - BlockCreationTime (Time (TimeSpan (Micros !bt))) = - view blockCreationTime bheader - BlockHash h = view blockHash bheader +-- -- | Pair parent header with transaction metadata. +-- -- In cases where there is no transaction/Command, 'PublicMeta' +-- -- default value is used. +-- data TxContext = TxContext +-- { _tcParentHeader :: !(Parent BlockHeader) +-- , _tcPublicMeta :: !PublicMeta +-- , _tcMiner :: !Miner +-- , _tcIsGenesis :: !Bool +-- } deriving Show --- | Retrieve parent header as 'BlockHeader' -ctxBlockHeader :: TxContext -> BlockHeader -ctxBlockHeader = _parentHeader . _tcParentHeader +-- makeLenses ''TxContext --- | Get "current" block height, which means parent height + 1. --- This reflects Pact environment focus on current block height, --- which influenced legacy switch checks as well. -ctxCurrentBlockHeight :: TxContext -> BlockHeight -ctxCurrentBlockHeight = succ . view blockHeight . ctxBlockHeader +-- instance HasChainId TxContext where +-- _chainId = _chainId . _tcParentHeader -ctxChainId :: TxContext -> ChainId -ctxChainId = view blockChainId . ctxBlockHeader +-- -- | Retrieve parent header as 'BlockHeader' +-- ctxBlockHeader :: TxContext -> BlockHeader +-- ctxBlockHeader = view _Parent . _tcParentHeader -ctxVersion :: TxContext -> ChainwebVersion -ctxVersion = view chainwebVersion . ctxBlockHeader +-- -- | Get "current" block height, which means parent height + 1. +-- -- This reflects Pact environment focus on current block height, +-- -- which influenced legacy switch checks as well. +-- ctxCurrentBlockHeight :: TxContext -> BlockHeight +-- ctxCurrentBlockHeight = succ . view blockHeight . ctxBlockHeader -guardCtx :: (ChainwebVersion -> ChainId -> BlockHeight -> a) -> TxContext -> a -guardCtx g txCtx = g (ctxVersion txCtx) (ctxChainId txCtx) (ctxCurrentBlockHeight txCtx) +-- -- | Get "current" block height, which means parent height + 1. +-- -- This reflects Pact environment focus on current block height, +-- -- which influenced legacy switch checks as well. +-- ctxParentBlockHeight :: TxContext -> Parent BlockHeight +-- ctxParentBlockHeight = Parent . view blockHeight . ctxBlockHeader + +-- ctxChainId :: TxContext -> ChainId +-- ctxChainId = view blockChainId . ctxBlockHeader + +-- guardCtx :: (ChainId -> BlockHeight -> a) -> TxContext -> a +-- guardCtx g txCtx = g (ctxChainId txCtx) (ctxCurrentBlockHeight txCtx) -- | Assemble tx context from transaction metadata and parent header. -getTxContext :: Miner -> PublicMeta -> PactBlockM logger tbl TxContext -getTxContext miner pm = view psParentHeader >>= \ph -> return (TxContext ph pm miner) - --- | A sub-monad of PactServiceM, for actions taking place at a particular block. -newtype PactBlockM logger tbl a = PactBlockM - { _unPactBlockM :: - ReaderT (PactBlockEnv logger Pact4 tbl) (StateT PactServiceState IO) a - } deriving newtype - ( Functor, Applicative, Monad - , MonadReader (PactBlockEnv logger Pact4 tbl) - , MonadState PactServiceState - , MonadThrow, MonadCatch, MonadMask - , MonadIO - ) - --- | Lifts PactServiceM to PactBlockM by forgetting about the current block. --- It is unsafe to use `runPactBlockM` inside the argument to this function. -liftPactServiceM :: PactServiceM logger tbl a -> PactBlockM logger tbl a -liftPactServiceM (PactServiceM a) = PactBlockM $ ReaderT $ \e -> - StateT $ \s -> do - runStateT (runReaderT a (_psServiceEnv e)) s - --- | Look up an init cache that is stored at or before the height of the current parent header. -getInitCache :: PactBlockM logger tbl ModuleCache -getInitCache = do - ph <- views psParentHeader (view blockHeight . _parentHeader) - get >>= \PactServiceState{..} -> - case M.lookupLE ph _psInitCache of - Just (_,mc) -> return mc - Nothing -> return mempty - --- | A wrapper for 'updateInitCache' that uses the current block. -updateInitCacheM :: ModuleCache -> PactBlockM logger tbl () -updateInitCacheM mc = do - pc <- view psParentHeader - liftPactServiceM $ - updateInitCache mc pc - --- | Run 'PactBlockM' by providing the block context, in the form of --- a database snapshot at that block and information about the parent header. --- It is unsafe to use this function in an argument to `liftPactServiceM`. -runPactBlockM - :: ParentHeader -> Bool -> PactDbFor logger Pact4 - -> PactBlockM logger tbl a -> PactServiceM logger tbl a -runPactBlockM pctx isGenesis dbEnv (PactBlockM act) = PactServiceM $ ReaderT $ \e -> StateT $ \s -> do - let blockEnv = PactBlockEnv - { _psServiceEnv = e - , _psIsGenesis = isGenesis - , _psParentHeader = pctx - , _psBlockDbEnv = dbEnv - } - (a, s') <- runStateT - (runReaderT act blockEnv) - s - return (a, s') - -tracePactBlockM :: (Logger logger, ToJSON param) => Text -> param -> Int -> PactBlockM logger tbl a -> PactBlockM logger tbl a -tracePactBlockM label param weight a = tracePactBlockM' label (const param) (const weight) a - -tracePactBlockM' :: (Logger logger, ToJSON param) => Text -> (a -> param) -> (a -> Int) -> PactBlockM logger tbl a -> PactBlockM logger tbl a -tracePactBlockM' label calcParam calcWeight a = do - e <- ask - s <- get - (r, s') <- liftIO $ trace' (logJsonTrace_ (_psLogger $ _psServiceEnv e)) label (calcParam . fst) (calcWeight . fst) - $ runStateT (runReaderT (_unPactBlockM a) e) s - put s' - return r - -localLabelBlock :: (Logger logger) => (Text, Text) -> PactBlockM logger tbl x -> PactBlockM logger tbl x -localLabelBlock lbl x = do - locally (psServiceEnv . psLogger) (addLabel lbl) x +-- getTxContext :: Miner -> PublicMeta -> Parent BlockHeader -> TxContext +-- getTxContext miner pm ph = TxContext ph pm miner data UnexpectedErrorPrinting = PrintsUnexpectedError | CensorsUnexpectedError @@ -261,7 +148,7 @@ catchesPactError logger exnPrinting action = catches (Right <$> action) PrintsUnexpectedError -> return (viaShow e) CensorsUnexpectedError -> do - liftIO $ logWarn_ logger ("catchesPactError: unknown error: " <> sshow e) + liftIO $ logFunctionText logger Warn ("catchesPactError: unknown error: " <> sshow e) return "unknown error" return $ Left $ PactError EvalError noInfo [] err ] @@ -319,8 +206,139 @@ chainweb224GasModel = chainweb213GasModel ga -> runGasModel chainweb213GasModel name ga } -getGasModel :: TxContext -> GasModel +getGasModel :: HasVersion => BlockCtx -> GasModel getGasModel ctx | guardCtx chainweb213Pact ctx = chainweb213GasModel | guardCtx chainweb224Pact ctx = chainweb224GasModel | otherwise = freeModuleLoadGasModel + +-- | While a block is being run, mutations to the pact database are held +-- in RAM to be written to the DB in batches at @save@ time. For any given db +-- write, we need to record the table name, the current tx id, the row key, and +-- the row value. +-- +data SQLiteRowDelta = SQLiteRowDelta + { _deltaTableName :: !Text + , _deltaTxId :: {-# UNPACK #-} !Pact.TxId + , _deltaRowKey :: !ByteString + , _deltaData :: !ByteString + } deriving (Show, Generic, Eq) + +instance Ord SQLiteRowDelta where + compare a b = compare aa bb + where + aa = (_deltaTableName a, _deltaRowKey a, _deltaTxId a) + bb = (_deltaTableName b, _deltaRowKey b, _deltaTxId b) + {-# INLINE compare #-} + +-- | A map from table name to a list of 'TxLog' entries. This is maintained in +-- 'BlockState' and is cleared upon pact transaction commit. +type TxLogMap = M.Map Pact.TableName (DList Pact.TxLogJson) + +-- | Between a @restore..save@ bracket, we also need to record which tables +-- were created during this block (so the necessary @CREATE TABLE@ statements +-- can be performed upon block save). +type SQLitePendingTableCreations = HashSet Text + +-- | Pact transaction hashes resolved during this block. +type SQLitePendingSuccessfulTxs = HashSet ByteString + +-- | Pending writes to the pact db during a block, to be recorded in 'BlockState'. +-- Structured as a map from table name to a map from rowkey to inserted row delta. +type SQLitePendingWrites = HashMap Text (HashMap ByteString (NonEmpty SQLiteRowDelta)) + +-- Note [TxLogs in SQLitePendingData] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- We should really not store TxLogs in SQLitePendingData, +-- because this data structure is specifically for things that +-- can exist both for the whole block and for specific transactions, +-- and txlogs only exist on the transaction level. +-- We don't do this in Pact 5 at all. + +-- | A collection of pending mutations to the pact db. We maintain two of +-- these; one for the block as a whole, and one for any pending pact +-- transaction. Upon pact transaction commit, the two 'SQLitePendingData' +-- values are merged together. +data SQLitePendingData = SQLitePendingData + { _pendingTableCreation :: !SQLitePendingTableCreations + , _pendingWrites :: !SQLitePendingWrites + -- See Note [TxLogs in SQLitePendingData] + , _pendingTxLogMap :: !TxLogMap + , _pendingSuccessfulTxs :: !SQLitePendingSuccessfulTxs + } + deriving (Eq, Show) + +emptySQLitePendingData :: SQLitePendingData +emptySQLitePendingData = SQLitePendingData mempty mempty mempty mempty + +data PactInternalError + = PactInternalError !CallStack !Text + | BlockValidationFailure !Text + | PactDuplicateTableError !Text + | PactTransactionExecError !Pact.PactHash !Text + | PactTransactionValidationException !Text + | CoinbaseFailure !Text + | PactBuyGasFailure !Text + | BlockGasLimitExceeded !Pact.Gas + | TransactionDecodeFailure !Text + deriving stock (Generic) + deriving anyclass (Exception) + +instance Show PactInternalError where + show = T.unpack . J.encodeText + +internalError :: (HasCallStack, MonadThrow m) => Text -> m a +internalError = throwM . PactInternalError callStack + +instance J.Encode PactInternalError where + build (PactInternalError _stack msg) = tagged "PactInternalError" msg + build (PactDuplicateTableError msg) = tagged "PactDuplicateTableError" msg + build (PactTransactionExecError h msg) = tagged "PactTransactionExecError" (J.Array (h, msg)) + build (PactTransactionValidationException errs) = tagged "PactTransactionValidationException" errs + build (CoinbaseFailure msg) = tagged "CoinbaseFailure" msg + build (PactBuyGasFailure msg) = tagged "PactBuyGasFailure" msg + build (BlockValidationFailure msg) = tagged "BlockValidationFailure" msg + build (BlockGasLimitExceeded g) = tagged "BlockGasLimitExceeded" g + build (TransactionDecodeFailure g) = tagged "TransactionDecodeFailure" g + +tagged :: J.Encode v => Text -> v -> J.Builder +tagged t v = J.object + [ "tag" J..= t + , "contents" J..= v + ] + +makeLenses ''SQLitePendingData + +pactCommandToBytes :: Command Text -> Transaction +pactCommandToBytes cwTrans = + let plBytes = J.encodeStrict cwTrans + in Transaction { _transactionBytes = plBytes } + +pactCommandResultToBytes :: CommandResult Pact.Hash -> TransactionOutput +pactCommandResultToBytes cr = + let outBytes = J.encodeStrict cr + in TransactionOutput { _transactionOutputBytes = outBytes } + +hashPactTxLogs :: CommandResult [Pact.TxLogJson] -> CommandResult Pact.Hash +hashPactTxLogs = over (crLogs . _Just) $ Pact.pactHash . Pact.encodeTxLogJsonArray + +toPayloadWithOutputs :: Miner -> Transactions Pact.Transaction (CommandResult [Pact.TxLogJson]) -> PayloadWithOutputs +toPayloadWithOutputs mi ts = + let oldSeq = _transactionPairs ts + trans = cmdBSToTx . sfst <$> oldSeq + transOuts = pactCommandResultToBytes . hashPactTxLogs . ssnd <$> oldSeq + + miner = toMinerData mi + cb = CoinbaseOutput $ J.encodeStrict $ hashPactTxLogs $ _transactionCoinbase ts + blockTrans = snd $ newBlockTransactions miner trans + cmdBSToTx = pactCommandToBytes + . fmap (T.decodeUtf8 . SB.fromShort . Pact.payloadBytes) + blockOuts = snd $ newBlockOutputs cb transOuts + + blockPL = blockPayload blockTrans blockOuts + plData = payloadData blockTrans blockPL + in payloadWithOutputs plData cb transOuts + +newtype TxTimeout = TxTimeout Text + deriving Show +instance Exception TxTimeout diff --git a/src/Chainweb/Pact4/Validations.hs b/src/Chainweb/Pact4/Validations.hs index d279ec439e..c5c5c0d878 100644 --- a/src/Chainweb/Pact4/Validations.hs +++ b/src/Chainweb/Pact4/Validations.hs @@ -1,4 +1,5 @@ {-# LANGUAGE DataKinds #-} +{-# LANGUAGE ImportQualifiedPost #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -42,55 +43,50 @@ module Chainweb.Pact4.Validations , defaultLenientTimeSlop ) where +import Chainweb.BlockCreationTime (BlockCreationTime(..)) +import Chainweb.Pact.Types +import Chainweb.Pact4.Transaction +import Chainweb.Parent +import Chainweb.Time (Seconds(..), Time(..), secondsToTimeSpan, scaleTimeSpan, second, add) +import Chainweb.Utils (ebool_, int, fromTextM, HasTextRepresentation (toText)) +import Chainweb.Version +import Chainweb.Version.Guards (isWebAuthnPrefixLegal, validPPKSchemes) import Control.Lens - -import Data.Decimal (decimalPlaces) import Data.Bifunctor (first) -import Data.Maybe (isJust, catMaybes, fromMaybe) +import Data.ByteString.Short qualified as SBS +import Data.Decimal (decimalPlaces) import Data.Either (isRight) import Data.List.NonEmpty (NonEmpty, nonEmpty) +import Data.Maybe (isJust, catMaybes, fromMaybe) import Data.Text (Text) -import qualified Data.Text as Text -import qualified Data.ByteString.Short as SBS +import Data.Text qualified as Text import Data.Word (Word8) - --- internal modules - -import Chainweb.BlockHeader -import Chainweb.BlockCreationTime (BlockCreationTime(..)) -import Chainweb.Pact.Types -import Chainweb.Pact.Utils (fromPactChainId) -import Chainweb.Time (Seconds(..), Time(..), secondsToTimeSpan, scaleTimeSpan, second, add) -import Chainweb.Pact4.Transaction -import Chainweb.Version -import Chainweb.Version.Guards (isWebAuthnPrefixLegal, validPPKSchemes) - -import qualified Pact.Types.Gas as P -import qualified Pact.Types.Hash as P -import qualified Pact.Types.ChainId as P -import qualified Pact.Types.Command as P -import qualified Pact.Types.ChainMeta as P -import qualified Pact.Types.KeySet as P -import qualified Pact.Parse as P -import Chainweb.Pact4.Types -import Chainweb.Utils (ebool_) +import Pact.Core.Gas.Types qualified as Pact5 +import Pact.Parse qualified as P +import Pact.Types.ChainId qualified as P +import Pact.Types.ChainMeta qualified as P +import Pact.Types.Command qualified as P +import Pact.Types.Gas qualified as P +import Pact.Types.Hash qualified as P +import Pact.Types.KeySet qualified as P -- | Check whether a local Api request has valid metadata -- assertPreflightMetadata - :: P.Command (P.Payload P.PublicMeta c) - -> TxContext + :: HasVersion + => P.Command (P.Payload P.PublicMeta c) + -> BlockCtx -> Maybe LocalSignatureVerification - -> PactServiceM logger tbl (Either (NonEmpty Text) ()) -assertPreflightMetadata cmd@(P.Command pay sigs hsh) txCtx sigVerify = do - v <- view psVersion - cid <- view chainId - bgl <- view psBlockGasLimit + -> ServiceEnv tbl + -> IO (Either (NonEmpty Text) ()) +assertPreflightMetadata cmd@(P.Command pay sigs hsh) bctx sigVerify serviceEnv = do + let cid = view chainId serviceEnv + let bgl = view psNewBlockGasLimit serviceEnv - let bh = ctxCurrentBlockHeight txCtx - let validSchemes = validPPKSchemes v cid bh - let webAuthnPrefixLegal = isWebAuthnPrefixLegal v cid bh + let bh = _bctxCurrentBlockHeight bctx + let validSchemes = validPPKSchemes cid bh + let webAuthnPrefixLegal = isWebAuthnPrefixLegal cid bh let P.PublicMeta pcid _ gl gp _ _ = P._pMeta pay nid = P._pNetworkId pay @@ -102,7 +98,7 @@ assertPreflightMetadata cmd@(P.Command pay sigs hsh) txCtx sigVerify = do -- TODO , eUnless "Transaction Gas limit exceeds block gas limit" $ assertBlockGasLimit bgl gl , eUnless "Gas price decimal precision too high" $ assertGasPrice gp - , eUnless "Network id mismatch" $ assertNetworkId v nid + , eUnless "Network id mismatch" $ assertNetworkId nid , eUnless "Signature list size too big" $ assertSigSize sigs , eUnless "Invalid transaction signatures" $ sigValidate validSchemes webAuthnPrefixLegal signers , eUnless "Tx time outside of valid range" $ assertTxTimeRelativeToParent pct cmd @@ -116,11 +112,7 @@ assertPreflightMetadata cmd@(P.Command pay sigs hsh) txCtx sigVerify = do | Just NoVerify <- sigVerify = True | otherwise = isRight $ assertValidateSigs validSchemes webAuthnPrefixLegal hsh signers sigs - pct = ParentCreationTime - . view blockCreationTime - . _parentHeader - . _tcParentHeader - $ txCtx + pct = view bctxParentCreationTime bctx eUnless t assertion | assertion = Nothing @@ -129,7 +121,7 @@ assertPreflightMetadata cmd@(P.Command pay sigs hsh) txCtx sigVerify = do -- | Check whether a particular Pact chain id is parseable -- assertParseChainId :: P.ChainId -> Bool -assertParseChainId = isJust . fromPactChainId +assertParseChainId (P.ChainId cid) = isJust $ fromTextM @_ @ChainId cid -- | Check whether the chain id defined in the metadata of a Pact/Chainweb -- command payload matches a given chain id. @@ -138,7 +130,7 @@ assertParseChainId = isJust . fromPactChainId -- chainweb node structure -- assertChainId :: ChainId -> P.ChainId -> Bool -assertChainId cid0 cid1 = chainIdToText cid0 == P._chainId cid1 +assertChainId cid0 cid1 = toText cid0 == P._chainId cid1 -- | Check and assert that 'GasPrice' is rounded to at most 12 decimal -- places. @@ -149,14 +141,14 @@ assertGasPrice (P.GasPrice (P.ParsedDecimal gp)) = decimalPlaces gp <= defaultMa -- | Check and assert that the 'GasLimit' of a transaction is less than or eqaul to -- the block gas limit -- -assertBlockGasLimit :: P.GasLimit -> P.GasLimit -> Bool -assertBlockGasLimit bgl tgl = bgl >= tgl +assertBlockGasLimit :: Pact5.GasLimit -> P.GasLimit -> Bool +assertBlockGasLimit (Pact5.GasLimit (Pact5.Gas bgl)) tgl = P.GasLimit (int bgl) >= tgl -- | Check and assert that 'ChainwebVersion' is equal to some pact 'NetworkId'. -- -assertNetworkId :: ChainwebVersion -> Maybe P.NetworkId -> Bool -assertNetworkId _ Nothing = False -assertNetworkId v (Just (P.NetworkId nid)) = ChainwebVersionName nid == _versionName v +assertNetworkId :: HasVersion => Maybe P.NetworkId -> Bool +assertNetworkId Nothing = False +assertNetworkId (Just (P.NetworkId nid)) = ChainwebVersionName nid == _versionName implicitVersion -- | Check and assert that the number of signatures in a 'Command' is -- at most 100. @@ -209,10 +201,10 @@ assertValidateSigs validSchemes webAuthnPrefixLegal hsh signers sigs = do -- skipped when replaying old blocks. -- assertTxTimeRelativeToParent - :: ParentCreationTime + :: Parent BlockCreationTime -> P.Command (P.Payload P.PublicMeta c) -> Bool -assertTxTimeRelativeToParent (ParentCreationTime (BlockCreationTime txValidationTime)) tx = +assertTxTimeRelativeToParent (Parent (BlockCreationTime txValidationTime)) tx = ttl > 0 && txValidationTime >= timeFromSeconds 0 && txOriginationTime >= 0 @@ -226,10 +218,10 @@ assertTxTimeRelativeToParent (ParentCreationTime (BlockCreationTime txValidation -- | Check that the tx's creation time is not too far in the future relative -- to the block creation time assertTxNotInFuture - :: ParentCreationTime + :: Parent BlockCreationTime -> P.Command (P.Payload P.PublicMeta c) -> Bool -assertTxNotInFuture (ParentCreationTime (BlockCreationTime txValidationTime)) tx = +assertTxNotInFuture (Parent (BlockCreationTime txValidationTime)) tx = timeFromSeconds txOriginationTime <= lenientTxValidationTime where timeFromSeconds = Time . secondsToTimeSpan . Seconds . fromIntegral diff --git a/src/Chainweb/Pact5/Templates.hs b/src/Chainweb/Pact5/Templates.hs deleted file mode 100644 index b2540e418f..0000000000 --- a/src/Chainweb/Pact5/Templates.hs +++ /dev/null @@ -1,145 +0,0 @@ -{-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} - --- | --- Module : Chainweb.Pact5.Templates --- Copyright : Copyright © 2010 Kadena LLC. --- License : (see the file LICENSE) --- Maintainer : Stuart Popejoy --- Stability : experimental --- --- Prebuilt Term templates for automated operations (coinbase, gas buy) --- -module Chainweb.Pact5.Templates -( mkFundTxTerm -, mkBuyGasTerm -, mkRedeemGasTerm -, mkCoinbaseTerm -) where - -import Data.Decimal -import Data.Text (Text) - --- internal modules - -import qualified Pact.JSON.Encode as J - -import Chainweb.Miner.Pact - -import Pact.Core.Literal -import Pact.Core.Names -import Pact.Core.Syntax.ParseTree -import Pact.Core.PactValue -import qualified Data.Map as Map -import Chainweb.Utils (decodeOrThrow) -import Pact.Core.StableEncoding (StableEncoding(_stableEncoding)) -import Control.Exception.Safe (impureThrow) -import qualified Pact.Types.KeySet as Pact4 -import Chainweb.Pact5.Types - -fundTxTemplate :: Text -> Text -> Expr () -fundTxTemplate sender mid = - let senderTerm = strLit sender - midTerm = strLit mid - varApp = qn "fund-tx" "coin" - rks = app (bn "read-keyset") [strLit "miner-keyset"] - rds = app (bn "read-decimal") [strLit "total"] - in app varApp [senderTerm, midTerm, rks, rds] - -buyGasTemplate :: Text -> Expr () -buyGasTemplate sender = - let senderTerm = strLit sender - varApp = qn "buy-gas" "coin" - rds = app (bn "read-decimal") [strLit "total"] - in app varApp [senderTerm, rds] - -redeemGasTemplate :: Text -> Text -> Expr () -redeemGasTemplate mid sender = - let midTerm = strLit mid - senderTerm = strLit sender - varApp = qn "redeem-gas" "coin" - rks = app (bn "read-keyset") [strLit "miner-keyset"] - rds = app (bn "read-decimal") [strLit "total"] - in app varApp [midTerm, rks, senderTerm, rds] - -app :: Expr () -> [Expr ()] -> Expr () -app arg args = App arg args () - -strLit :: Text -> Expr () -strLit txt = Constant (LString txt) () - -qn :: Text -> Text -> Expr () -qn name modname = Var (QN (QualifiedName name (ModuleName modname Nothing))) () - -bn :: Text -> Expr () -bn name = Var (BN (BareName name)) () - -mkFundTxTerm - :: MinerId -- ^ Id of the miner to fund - -> MinerKeys - -> Text -- ^ Address of the sender from the command - -> GasSupply - -> (Expr (), Map.Map Field PactValue) -mkFundTxTerm (MinerId mid) (MinerKeys ks) sender total = - let - term = fundTxTemplate sender mid - buyGasData = Map.fromList - [ ("miner-keyset", convertKeySet ks) - , ("total", PDecimal $ _pact5GasSupply total) - ] - in (term, buyGasData) - --- we configure the miner keyset as a Pact4 keyset --- TODO: change this? -convertKeySet :: Pact4.KeySet -> PactValue -convertKeySet = - either impureThrow _stableEncoding . decodeOrThrow . J.encode -{-# INLINABLE mkFundTxTerm #-} - -mkBuyGasTerm - :: Text -- ^ Address of the sender from the command - -> GasSupply - -> (Expr (), Map.Map Field PactValue) -mkBuyGasTerm sender total = (buyGasTemplate sender, buyGasData) - where - buyGasData = Map.fromList - [ ("total", PDecimal $ _pact5GasSupply total) ] -{-# INLINABLE mkBuyGasTerm #-} - -mkRedeemGasTerm - :: MinerId -- ^ Id of the miner to fund - -> MinerKeys -- ^ Miner keyset - -> Text -- ^ Address of the sender from the command - -> GasSupply -- ^ The gas limit total * price - -> GasSupply -- ^ The gas used * price - -> (Expr (), PactValue) -mkRedeemGasTerm (MinerId mid) (MinerKeys ks) sender total fee = - (redeemGasTemplate mid sender, redeemGasData) - where - redeemGasData = PObject $ Map.fromList - [ ("total", PDecimal $ _pact5GasSupply total) - , ("fee", PDecimal $ _pact5GasSupply fee) - , ("miner-keyset", convertKeySet ks) - ] -{-# INLINABLE mkRedeemGasTerm #-} - -coinbaseTemplate :: Text -> Expr () -coinbaseTemplate mid = - let midTerm = strLit mid - varApp = qn "coinbase" "coin" - rks = app (bn "read-keyset") [strLit "miner-keyset"] - rds = app (bn "read-decimal") [strLit "reward"] - in app varApp [midTerm, rks, rds] - -mkCoinbaseTerm :: MinerId -> MinerKeys -> Decimal -> (Expr (), PactValue) -mkCoinbaseTerm (MinerId mid) (MinerKeys ks) reward = (coinbaseTemplate mid, coinbaseData) - where - coinbaseData = PObject $ Map.fromList - [ ("miner-keyset", convertKeySet ks) - , ("reward", PDecimal reward) - ] -{-# INLINABLE mkCoinbaseTerm #-} diff --git a/src/Chainweb/Pact5/Types.hs b/src/Chainweb/Pact5/Types.hs deleted file mode 100644 index bb970494d9..0000000000 --- a/src/Chainweb/Pact5/Types.hs +++ /dev/null @@ -1,213 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE TemplateHaskell #-} - -module Chainweb.Pact5.Types - ( TxContext(..) - , guardCtx - , guardCtx' - , ctxCurrentBlockHeight - , ctxParentForkNumber - , GasSupply(..) - , PactBlockM(..) - , PactBlockState(..) - , pbBlockHandle - , pbServiceState - , runPactBlockM - , tracePactBlockM - , tracePactBlockM' - , liftPactServiceM - , pactTransaction - , localLabelBlock - -- * default values - , noInfo - , noPublicMeta - , noSpanInfo - , emptyCapState - ) - where - -import Chainweb.BlockHeader -import Chainweb.Miner.Pact (Miner) -import Chainweb.BlockHeight -import Chainweb.Version -import Chainweb.ForkState -import Chainweb.Pact.Types -import qualified Chainweb.ChainId -import Control.Lens -import Control.Exception.Safe -import Control.Monad.IO.Class -import Chainweb.Logger -import qualified Pact.Core.Evaluate as Pact5 -import Data.Decimal -import qualified Pact.JSON.Encode as J -import qualified Pact.Core.StableEncoding as Pact5 -import qualified Pact.Core.Literal as Pact5 -import Control.Monad.State.Strict -import Control.Monad.Reader -import Data.Aeson (ToJSON) -import Data.Text (Text) -import Utils.Logging.Trace -import Pact.Core.Persistence -import Chainweb.Pact5.Backend.ChainwebPactDb (Pact5Db(..)) -import qualified Pact.Core.Builtin as Pact5 -import Pact.Core.Command.Types (RequestKey) - -import qualified Pact.Core.Capabilities as Pact5 -import qualified Pact.Core.ChainData as Pact5 -import qualified Pact.Core.Info as Pact5 -import qualified Pact.Core.Gas.Types as Pact5 -import Chainweb.Pact.Backend.Types - --- | Pair parent header with transaction metadata. --- In cases where there is no transaction/Command, 'PublicMeta' --- default value is used. -data TxContext = TxContext - { _tcParentHeader :: !ParentHeader - , _tcMiner :: !Miner - } deriving Show - -instance HasChainId TxContext where - _chainId = Chainweb.ChainId._chainId . _tcParentHeader -instance HasChainwebVersion TxContext where - _chainwebVersion = _chainwebVersion . _tcParentHeader - --- | Retrieve parent header as 'BlockHeader' -ctxBlockHeader :: TxContext -> BlockHeader -ctxBlockHeader = _parentHeader . _tcParentHeader - --- | Get "current" block height, which means parent height + 1. --- This reflects Pact environment focus on current block height, --- which influenced legacy switch checks as well. -ctxCurrentBlockHeight :: TxContext -> BlockHeight -ctxCurrentBlockHeight = succ . view blockHeight . ctxBlockHeader - --- We use the parent fork number in Pact, so when the fork --- number is incremented, only that block's descendents will --- have the forking behavior active. We do this because computing --- the "currently active fork number" requires information from adjacent --- headers, which is not actually available yet when we execute a new Pact payload. -ctxParentForkNumber :: TxContext -> ForkNumber -ctxParentForkNumber = view blockForkNumber . ctxBlockHeader - -ctxChainId :: TxContext -> Chainweb.ChainId.ChainId -ctxChainId = _chainId . ctxBlockHeader - -ctxVersion :: TxContext -> ChainwebVersion -ctxVersion = _chainwebVersion . ctxBlockHeader - --- To be used when Forks guards are defined by height -guardCtx :: (ChainwebVersion -> Chainweb.ChainId.ChainId -> BlockHeight -> a) -> TxContext -> a -guardCtx g txCtx = g (ctxVersion txCtx) (ctxChainId txCtx) (ctxCurrentBlockHeight txCtx) - --- To be used when Forks guards are defined by ForkNumbers -guardCtx' :: (ChainwebVersion -> Chainweb.ChainId.ChainId -> ForkNumber -> a) -> TxContext -> a -guardCtx' g txCtx = g (ctxVersion txCtx) (ctxChainId txCtx) (ctxParentForkNumber txCtx) - -data PactBlockState = PactBlockState - { _pbServiceState :: !PactServiceState - , _pbBlockHandle :: !(BlockHandle Pact5) - } - -makeLenses ''PactBlockState - --- | A sub-monad of PactServiceM, for actions taking place at a particular block. -newtype PactBlockM logger tbl a = PactBlockM - { _unPactBlockM :: - ReaderT (PactBlockEnv logger Pact5 tbl) (StateT PactBlockState IO) a - } deriving newtype - ( Functor, Applicative, Monad - , MonadReader (PactBlockEnv logger Pact5 tbl) - , MonadState PactBlockState - , MonadThrow, MonadCatch, MonadMask - , MonadIO - ) - --- | Run 'PactBlockM' by providing the block context, in the form of --- a database snapshot at that block and information about the parent header. --- It is unsafe to use this function in an argument to `liftPactServiceM`. -runPactBlockM - :: ParentHeader -> Bool -> PactDbFor logger Pact5 -> BlockHandle Pact5 - -> PactBlockM logger tbl a -> PactServiceM logger tbl (a, BlockHandle Pact5) -runPactBlockM pctx isGenesis dbEnv startBlockHandle (PactBlockM act) = PactServiceM $ ReaderT $ \e -> StateT $ \s -> do - let blockEnv = PactBlockEnv - { _psServiceEnv = e - , _psParentHeader = pctx - , _psIsGenesis = isGenesis - , _psBlockDbEnv = dbEnv - } - (a, s') <- runStateT - (runReaderT act blockEnv) - (PactBlockState s startBlockHandle) - return ((a, _pbBlockHandle s'), _pbServiceState s') - -tracePactBlockM :: (Logger logger, ToJSON param) => Text -> param -> Int -> PactBlockM logger tbl a -> PactBlockM logger tbl a -tracePactBlockM label param weight a = tracePactBlockM' label (const param) (const weight) a - -tracePactBlockM' :: (Logger logger, ToJSON param) => Text -> (a -> param) -> (a -> Int) -> PactBlockM logger tbl a -> PactBlockM logger tbl a -tracePactBlockM' label calcParam calcWeight a = do - e <- ask - s <- get - (r, s') <- liftIO $ trace' (logJsonTrace_ (_psLogger $ _psServiceEnv e)) label (calcParam . fst) (calcWeight . fst) - $ runStateT (runReaderT (_unPactBlockM a) e) s - put s' - return r - --- | Lifts PactServiceM to PactBlockM by forgetting about the current block. --- It is unsafe to use `runPactBlockM` inside the argument to this function. -liftPactServiceM :: PactServiceM logger tbl a -> PactBlockM logger tbl a -liftPactServiceM (PactServiceM a) = - PactBlockM $ ReaderT $ \e -> StateT $ \s -> do - let sp = runReaderT a (_psServiceEnv e) - (r, s') <- runStateT sp (_pbServiceState s) - return (r, s { _pbServiceState = s' }) - -pactTransaction :: Maybe RequestKey -> (PactDb Pact5.CoreBuiltin Pact5.Info -> IO a) -> PactBlockM logger tbl a -pactTransaction rk k = do - e <- view psBlockDbEnv - h <- use pbBlockHandle - (r, h') <- liftIO $ doPact5DbTransaction e h rk k - pbBlockHandle .= h' - return r - --- | Indicates a computed gas charge (gas amount * gas price) -newtype GasSupply = GasSupply { _pact5GasSupply :: Decimal } - deriving (Eq,Ord) - deriving newtype (Num,Real,Fractional) - -instance J.Encode GasSupply where - build = J.build . Pact5.StableEncoding . Pact5.LDecimal . _pact5GasSupply -instance Show GasSupply where show (GasSupply g) = show g - -localLabelBlock :: (Logger logger) => (Text, Text) -> PactBlockM logger tbl x -> PactBlockM logger tbl x -localLabelBlock lbl x = do - locally (psServiceEnv . psLogger) (addLabel lbl) x - --- -------------------------------------------------------------------------- -- --- Default Values --- --- TODO: move to Pact5 - -noInfo :: Pact5.Info -noInfo = Pact5.LineInfo 0 - -emptyCapState :: Ord name => Ord v => Pact5.CapState name v -emptyCapState = Pact5.CapState mempty mempty mempty mempty mempty - -noSpanInfo :: Pact5.SpanInfo -noSpanInfo = Pact5.SpanInfo 0 0 0 0 - -noPublicMeta :: Pact5.PublicMeta -noPublicMeta = Pact5.PublicMeta - { Pact5._pmChainId = Pact5.ChainId "" - , Pact5._pmSender = "" - , Pact5._pmGasLimit = Pact5.GasLimit (Pact5.Gas 0) - , Pact5._pmGasPrice = Pact5.GasPrice 0 - , Pact5._pmTTL = Pact5.TTLSeconds 0 - , Pact5._pmCreationTime = Pact5.TxCreationTime 0 - } diff --git a/src/Chainweb/Parent.hs b/src/Chainweb/Parent.hs new file mode 100644 index 0000000000..351d668f8f --- /dev/null +++ b/src/Chainweb/Parent.hs @@ -0,0 +1,40 @@ +{-# language DerivingStrategies #-} +{-# language GeneralizedNewtypeDeriving #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE TemplateHaskell #-} + +module Chainweb.Parent + -- * Newtype wrappers for function parameters + ( Parent(..) + , _Parent + ) where + +import Control.DeepSeq +import Control.Lens +import Data.Aeson +import Data.Hashable +import Numeric.AffineSpace +import GHC.Generics + +import Chainweb.ChainId +import Chainweb.Version + +newtype Parent h = Parent { unwrapParent :: h } + deriving stock (Show, Functor, Foldable, Traversable, Eq, Ord, Generic) + deriving newtype (NFData, ToJSON, FromJSON, Hashable, LeftTorsor) +instance Applicative Parent where + pure = Parent + Parent f <*> Parent a = Parent (f a) + +instance HasChainId h => HasChainId (Parent h) where + _chainId = _chainId . unwrapParent +instance HasChainGraph h => HasChainGraph (Parent h) where + _chainGraph = _chainGraph . unwrapParent + +makePrisms ''Parent + +-- NOTE: no instance for IsRanked a => IsRanked (Parent a) because that could be +-- confusing diff --git a/src/Chainweb/PayloadProvider.hs b/src/Chainweb/PayloadProvider.hs new file mode 100644 index 0000000000..e3cff16f34 --- /dev/null +++ b/src/Chainweb/PayloadProvider.hs @@ -0,0 +1,1034 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE OverloadedRecordDot #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} + +-- | +-- Module: Chainweb.PayloadProvider +-- Copyright: Copyright © 2024 Kadena LLC. +-- License: MIT +-- Maintainer: Lars Kuhtz +-- Stability: experimental +-- +module Chainweb.PayloadProvider +( +-- * Hints + Hints(..) + +-- * SyncState +, SyncState(..) +, syncStateOfBlockHeader +, _syncStateRankedBlockPayloadHash +, _syncStateRankedBlockHash + +-- * ConsensusState +, ConsensusState(..) +, genesisSyncState +, genesisConsensusState +, latestRankedBlockPayloadHash +, safeRankedBlockPayloadHash +, finalRankedBlockPayloadHash +, genesisState + +-- * NewBlock Context +, NewBlockCtx(..) + +-- * Evaluation Context +, EvaluationCtx(..) +, ConsensusPayload(..) +, _evaluationCtxCurrentHeight +, _evaluationCtxRankedPayloadHash +, _evaluationCtxRankedParentHash +, _evaluationCtxRankedPayload + +-- * Fork Info +, ForkInfo(..) +, forkInfoNewBlockCtx +, forkInfoBasePayloadHash +, forkInfoTargetState +, forkInfoTrace +, PayloadProvider(..) +, EncodedPayloadData(..) +, EncodedPayloadOutputs(..) +, assertForkInfoInvariants +, _forkInfoBaseHeight +, _forkInfoBaseRankedPayloadHash +, _forkInfoTraceBlockHashes + +-- * New Payload +, NewPayload(..) +, _newPayloadRankedParentHash +-- , SyncError(..) +-- , EvmPayloadCtx +-- , PactPayloadCtx +, blockHeaderToEvaluationCtx +, nextPayload +, nextPayloadStm +, waitForChangedPayload +, payloadStream + +-- * PayloadProvider +, ConfiguredPayloadProvider(..) + +-- * SPV +, PayloadSpvException(..) +, renderPayloadSpvException +, TransactionIndex(..) +, EventIndex(..) +, XEventId(..) +, SpvProof(..) + +-- * Utils + +-- ** Consensus State Accessors +, _latestBlockHash +, _latestRankedBlockHash +, _latestPayloadHash +, _latestHeight +, _safeBlockHash +, _safePayloadHash +, _safeHeight +, _finalBlockHash +, _finalPayloadHash +, _finalHeight +) where + +import Chainweb.BlockCreationTime +import Chainweb.BlockHash +import Chainweb.BlockHeader +import Chainweb.ForkState (ForkNumber) +import Chainweb.BlockHeight +import Chainweb.BlockPayloadHash +import Chainweb.MinerReward +import Chainweb.Parent +import Chainweb.Ranked +import Chainweb.Utils +import Chainweb.Version +import Control.Concurrent.STM +import Control.DeepSeq (NFData) +import Control.Lens hiding ((.=)) +import Control.Monad +import Control.Monad.Catch +import Control.Monad.IO.Class +import Data.Aeson +import Data.ByteString qualified as B +import Data.Function +import Data.Hashable +import Data.Maybe +import Data.Text qualified as T +import GHC.Generics (Generic) +import Numeric.Natural +import P2P.Peer +import Streaming.Prelude qualified as S + +-- -------------------------------------------------------------------------- -- +-- Exceptions + +newtype PayloadProviderException = InvalidForkInfo T.Text + deriving (Show, Eq, Generic) + +instance Exception PayloadProviderException + +-- -------------------------------------------------------------------------- -- +-- Sync State + +-- | This identifies the block that corresponds to the current state of the +-- payload provider. +-- +-- TODO: +-- To accomodate existing providers (Pact and EVM), we include both, block hash +-- and the block payload hash. When future versions of Pact are able to resolve +-- payloads through the payload block hash alone, we may drop the block hash +-- from this structure. +-- +-- TODO: +-- Safe and Finalized Block should be identified via the block payload hashes +-- (and possibly number) instead of the height. +-- +data SyncState = SyncState + { _syncStateHeight :: !BlockHeight + -- ^ The BlockHeight of the lastest Block + , _syncStateBlockHash :: !BlockHash + -- ^ The BlockHash of the latest Block + , _syncStateBlockPayloadHash :: !BlockPayloadHash + -- ^ The BlockPayloadHash of the latest Block + } + deriving (Show, Eq, Ord) + +syncStateOfBlockHeader :: BlockHeader -> SyncState +syncStateOfBlockHeader hdr = SyncState + { _syncStateHeight = view blockHeight hdr + , _syncStateBlockHash = view blockHash hdr + , _syncStateBlockPayloadHash = view blockPayloadHash hdr + } + +_syncStateRankedBlockPayloadHash :: SyncState -> RankedBlockPayloadHash +_syncStateRankedBlockPayloadHash s = RankedBlockPayloadHash + (_syncStateHeight s) (_syncStateBlockPayloadHash s) + +_syncStateRankedBlockHash :: SyncState -> RankedBlockHash +_syncStateRankedBlockHash s = RankedBlockHash + (_syncStateHeight s) (_syncStateBlockHash s) + +syncStateProperties :: forall e kv . KeyValue e kv => SyncState -> [kv] +syncStateProperties a = + [ "height" .= _syncStateHeight a + , "blockHash" .= _syncStateBlockHash a + , "payloadHash" .= _syncStateBlockPayloadHash a + ] + +instance ToJSON SyncState where + toEncoding = pairs . mconcat . syncStateProperties + toJSON = object . syncStateProperties + {-# INLINE toEncoding #-} + {-# INLINE toJSON #-} + +-- -------------------------------------------------------------------------- -- +-- Consensus State + +data ConsensusState = ConsensusState + { _consensusStateLatest :: !SyncState + , _consensusStateSafe :: !SyncState + -- ^ The latest block that is generally considered safe. In a Chainweb a + -- block is considered safe, when it has at least Graph-diameter many + -- full layers on top of it. However, depending on on current conditions + -- of the network the required depth can be larger. For testing networks + -- with low-diameter chain graphs the minimal required depth is at least + -- 3. + , _consensusStateFinal :: !SyncState + -- ^ The latest block that is considered final. Note that this is a + -- heuristics. There is no definite finality in any PoW/PoH blockchain + -- system. (And the same should probably be true for PoS blockchains as + -- well.) + -- + -- Chainweb uses an very conservative measure of finality. A block that + -- is considered final can not be reorged automatically. Instead such a + -- reorg would require manual intervention of node maintainers. + } + deriving (Show, Eq, Ord) + +genesisSyncState + :: HasVersion + => HasChainId c + => c + -> SyncState +genesisSyncState c = + syncStateOfBlockHeader (genesisBlockHeader c) + +genesisConsensusState + :: HasVersion + => HasChainId c + => c + -> ConsensusState +genesisConsensusState c = ConsensusState + { _consensusStateLatest = genesisSyncState c + , _consensusStateSafe = genesisSyncState c + , _consensusStateFinal = genesisSyncState c + } + +latestRankedBlockPayloadHash :: ConsensusState -> RankedBlockPayloadHash +latestRankedBlockPayloadHash = + _syncStateRankedBlockPayloadHash . _consensusStateLatest + +safeRankedBlockPayloadHash :: ConsensusState -> RankedBlockPayloadHash +safeRankedBlockPayloadHash = + _syncStateRankedBlockPayloadHash . _consensusStateSafe + +finalRankedBlockPayloadHash :: ConsensusState -> RankedBlockPayloadHash +finalRankedBlockPayloadHash = + _syncStateRankedBlockPayloadHash . _consensusStateFinal + +consensusStateProperties :: forall e kv . KeyValue e kv => ConsensusState -> [kv] +consensusStateProperties a = + [ "latest" .= _consensusStateLatest a + , "safe" .= _consensusStateSafe a + , "final" .= _consensusStateFinal a + ] + +instance ToJSON ConsensusState where + toEncoding = pairs . mconcat . consensusStateProperties + toJSON = object . consensusStateProperties + {-# INLINE toEncoding #-} + {-# INLINE toJSON #-} + +-- -------------------------------------------------------------------------- -- +-- Payload Evaluation Context + +-- | The block payload evaluation context for a given payload provider. +-- +-- It contains all data that allows the provider to evaluate the payload of +-- a single block. +-- +-- IMPORTANT NOTE: +-- The context is deterministcally derived from the consensus state of the +-- blockchain. The payload provider must validate that the context is correct. +-- This is particularly important for payload providers that redundantly store +-- some contextual information internally in payload data structure. Some of the +-- contextual information, namely the timestamp and the mining reward, can not +-- be derived from the previous payload. While the mining reward is a constant +-- property of the blockchain, i.e. it is determined at genesis, the timestamp +-- is determined only at mining time. If such a property is stored and remotely +-- synchronized with remote peers, the payload provider must confirm the +-- validity of this information with the local consensus state before committing +-- the the payload evaluation. +-- +-- Binary format: The concatenation of the binary serialization of the +-- individual fields in the order as they appear in the data type definition. +-- +data EvaluationCtx p = EvaluationCtx + { _evaluationCtxParentCreationTime :: !(Parent BlockCreationTime) + -- ^ Creation time of the parent block. If transactions in the block + -- have a notion of "current" time, they should use this value. + , _evaluationCtxParentHash :: !(Parent BlockHash) + -- ^ Block hash of the parent block. + , _evaluationCtxParentHeight :: !(Parent BlockHeight) + -- ^ Block height of the parent block. + , _evaluationCtxParentForkNumber :: !ForkNumber + -- ^ Fork number of the parent block. + , _evaluationCtxMinerReward :: !MinerReward + -- ^ The miner reward that is assigned to the miner of the block. Miner + -- rewards are not constant and determined by the consensus protocol. It + -- depends on the block height and the respective chain graph. + -- + -- The payload provider must validate for each block that the reward is + -- correct. + -- + -- On payload provider API level the amount is provided in Stu and + -- encoded as unsigned 64 bit integer value in little endian encoding. + -- + -- Internally, encoding and unit is provider specific. For Pact it is a + -- Kda value for the EVM provider it is in Stu. Also the recipient and + -- the mechanism how it is credited is provider specific. + , _evaluationCtxPayload :: !p + -- ^ The 'BlockPayloadHash' for the payload to be evaluated. It may also + -- include some additional payload data. This should be of type + -- `ConsensusPayload` in most cases. + } + deriving (Functor, Show, Eq, Ord) + +_evaluationCtxCurrentHeight :: EvaluationCtx p -> BlockHeight +_evaluationCtxCurrentHeight = succ . unwrapParent . _evaluationCtxParentHeight + +_evaluationCtxRankedPayloadHash + :: EvaluationCtx ConsensusPayload + -> RankedBlockPayloadHash +_evaluationCtxRankedPayloadHash ctx = RankedBlockPayloadHash + (_evaluationCtxCurrentHeight ctx) + (_consensusPayloadHash $ _evaluationCtxPayload ctx) + +_evaluationCtxRankedParentHash + :: EvaluationCtx p + -> Parent RankedBlockHash +_evaluationCtxRankedParentHash ctx = Parent $ RankedBlockHash + (unwrapParent $ _evaluationCtxParentHeight ctx) + (unwrapParent $ _evaluationCtxParentHash ctx) + +_evaluationCtxRankedPayload + :: EvaluationCtx ConsensusPayload + -> Ranked ConsensusPayload +_evaluationCtxRankedPayload ctx = Ranked + (_evaluationCtxCurrentHeight ctx) + (_evaluationCtxPayload ctx) + +evaluationCtxProperties :: forall e kv p . (KeyValue e kv, ToJSON p) => EvaluationCtx p -> [kv] +evaluationCtxProperties a = + [ "parentCreationTime" .= _evaluationCtxParentCreationTime a + , "parentBlockHash" .= _evaluationCtxParentHash a + , "parentHeight" .= _evaluationCtxParentHeight a + , "parentForkNumber" .= _evaluationCtxParentForkNumber a + , "minerReward" .= _evaluationCtxMinerReward a + , "payload" .= _evaluationCtxPayload a + ] + +instance ToJSON p => ToJSON (EvaluationCtx p) where + toEncoding = pairs . mconcat . evaluationCtxProperties + toJSON = object . evaluationCtxProperties + {-# INLINE toEncoding #-} + {-# INLINE toJSON #-} + +-- -------------------------------------------------------------------------- -- +-- New Block Context + +-- | Context for creating a new block on top of the latest Block. +-- +-- The miner reward depends on global consensus properties like block height and +-- chain graph. +-- +-- In the future this structure may be extended with additional fields. +-- +-- Note, that the mechanism how the reward is credited as well as the recipient +-- is defined in the scope of the specific payload provider. It is *not* part of +-- the global chainweb consensus protocol. Similarly, gas fees and the recipient +-- of those fees are provider specific. This implies a trust relationship +-- between payload provider and consensus (the miner, which is part of +-- consensus, must trust its payload provider). +-- +data NewBlockCtx = NewBlockCtx + { _newBlockCtxMinerReward :: !MinerReward + -- ^ the miner reward for the new block. + , _newBlockCtxParentCreationTime :: !(Parent BlockCreationTime) + -- ^ the creation time of the block on which the new is created. + } + deriving (Show, Eq, Ord) + +-- | Get the evaluation context for given parent header and block payload hash +-- +blockHeaderToEvaluationCtx + :: HasVersion + => Parent BlockHeader + -> EvaluationCtx () +blockHeaderToEvaluationCtx (Parent ph) = EvaluationCtx + { _evaluationCtxParentCreationTime = Parent $ view blockCreationTime ph + , _evaluationCtxParentHash = Parent $ view blockHash ph + , _evaluationCtxParentHeight = parentHeight + , _evaluationCtxParentForkNumber = view blockForkNumber ph + , _evaluationCtxMinerReward = blockMinerReward height + , _evaluationCtxPayload = () + } + where + parentHeight = Parent $ view blockHeight ph + height = unwrapParent parentHeight + 1 + +newBlockCtxProperties :: forall e kv . KeyValue e kv => NewBlockCtx -> [kv] +newBlockCtxProperties a = + [ "minerReward" .= _newBlockCtxMinerReward a + , "parentCreationTime" .= _newBlockCtxParentCreationTime a + ] + +instance ToJSON NewBlockCtx where + toEncoding = pairs . mconcat . newBlockCtxProperties + toJSON = object . newBlockCtxProperties + {-# INLINE toEncoding #-} + {-# INLINE toJSON #-} + +-- | Payload in an Evaluation Context that is sent to a Payload Provider. +-- +data ConsensusPayload = ConsensusPayload + { _consensusPayloadHash :: !BlockPayloadHash + -- ^ Payload hash of the block that is validated. This is used as a + -- checksum for the payload validation. For the last block of a ForkInfo + -- structure this value must match the respective value in the target + -- sync state. + -- + -- The BlockPayloadHash is first computed when the respective payload is + -- created for mining and before it is included in a block. + , _consensusPayloadData :: !(Maybe EncodedPayloadData) + -- ^ Optional external payload data. This may be the complete, self + -- contained block payload or it may just contain complementary data + -- that aids with the validation. + -- + -- The main purpose of this field is to allow consensus to gossip around + -- payload data along with new cuts in the P2P network, which allows for + -- more efficient synchronization and a reduction of block propagation + -- latencies. + } + deriving (Show, Eq, Ord) + +consensusPayloadProperties :: forall e kv . KeyValue e kv => ConsensusPayload -> [kv] +consensusPayloadProperties a = + [ "hash" .= _consensusPayloadHash a + , "data" .= _consensusPayloadData a + ] + +instance ToJSON ConsensusPayload where + toEncoding = pairs . mconcat . consensusPayloadProperties + toJSON = object . consensusPayloadProperties + {-# INLINE toEncoding #-} + {-# INLINE toJSON #-} + + +-- -------------------------------------------------------------------------- -- +-- ForkInfo + +-- | Synchronize the state of a payload provider to a particular fork of a +-- Chainweb chain. +-- +-- This contains all data that is required for a payload provider to evaluate +-- the payloads of a consecutive sequence of blocks on top of some historic +-- provider state. +-- +-- In order to create this value the client makes an educated guess about the +-- current state of the payload provider. Under normal circumstances the client +-- is able to make an accurate guess. It can fail on the first initialization of +-- a provider or on re-initialization after an ungracefull shutdown of the +-- payload provider or the client. If that happens and no suitable historic +-- state is known to the payload provider it rejects the `ForkInfo` and returns +-- the current `PayloadProviderState` to the caller. This enables the caller to +-- prepare a new `ForkInfo` value. +-- +-- Binary format: the length of `_forkInfoTrace` as unsigned 32 bit integer +-- number in little endian byte order followed by the binary serialization of +-- the entries of `_forkInfoTrace`, followed by the binary serialization of +-- `forkInfoTraceHash`. +-- +-- NOTE: +-- +-- A special case are stateless payload providers for which the evaluation of a +-- payload depends only on the local evaluation context and not on the history +-- of the chain. Those payload providers do not need to resolve reorgs. However, +-- they cannot offer access to a complete and consistent payload history via the +-- service API. The minimal payload provider is an example for a stateless +-- payload provider. +-- +data ForkInfo = ForkInfo + { _forkInfoTrace :: ![EvaluationCtx ConsensusPayload] + -- ^ The payload evaluation contexts for a consecutive sequence of + -- blocks. The first entry determines the fork point which must be + -- known to the payload provider (although it is not necessary that the + -- payload provider is able to reconstruct the respective state. The + -- provider is not obligated to replay all blocks as long as the final + -- state is valid. + -- + -- If evaluation of the full list of payloads fails, the payload provider + -- may choose to remain in an intermediate state, as long as that state + -- is consistent with the evaluation of some prefix of this field. + -- + -- The payload provider is also obligated to validate the correctness of + -- the evaluation context with respect the payload provider state for + -- all provided contexts in this field up to the lastest validated + -- block. This allows the client to request the evaluation and + -- validation of a series of new blocks. The payload provider does not + -- need to guarantee the correctness of the validation context for + -- blocks that had been validated before. This includes all re-validated + -- blocks that are not included in this field, because it can be assumed + -- that those have been validated before with their respective contexts + -- provided. + -- + -- However, the operation for the respective evaluated prefix must + -- satisfy the ACID criteria. + -- + -- FIXME: + -- It may be more intuitive and convenient to store the trace in reverse + -- order. + -- + , _forkInfoBasePayloadHash :: !(Parent BlockPayloadHash) + -- ^ The payload hash of the parent block of the first entry in the + -- fork info trace. If the fork info trace is empty, this is the payload + -- hash of the latest block in the consensus state. + -- + -- The payload hash of the parent block is not part of the evaluation + -- context, because it does need to be validated. However, some payload + -- providers may require it to identify the base state onto which the + -- fork info trace is applied. + , _forkInfoTargetState :: !ConsensusState + -- ^ The target sync state. This allows the payload provider + -- to update its `SyncState`. Intermediate block hashes are + -- available in form of `BlockParentHash`s from the `PayloadCtx` + -- entries. + , _forkInfoNewBlockCtx :: !(Maybe NewBlockCtx) + -- ^ If mining is enabled in the payload provider and this field is not + -- `Nothing`, the payload provider creates a new block payload with the + -- given miner info and miner reward. + } + deriving (Show, Eq, Ord) + +_forkInfoBaseHeight :: ForkInfo -> Parent BlockHeight +_forkInfoBaseHeight fi = case _forkInfoTrace fi of + [] -> Parent $ _latestHeight (_forkInfoTargetState fi) + (h:_) -> _evaluationCtxParentHeight h + +_forkInfoBaseRankedPayloadHash :: ForkInfo -> Parent RankedBlockPayloadHash +_forkInfoBaseRankedPayloadHash fi = RankedBlockPayloadHash + <$> _forkInfoBaseHeight fi + <*> _forkInfoBasePayloadHash fi + + +-- | Return the block hashes of the block in a fork info trace. +-- +_forkInfoTraceBlockHashes :: ForkInfo -> [RankedBlockHash] +_forkInfoTraceBlockHashes forkInfo = + -- The trace entries contain the respective parent block hashes. So, in + -- order to get the block hashes we need to shift the trace by one and add + -- the hash of the last block in the trace. The hash of the last block in + -- the trace can be found in the target state + drop 1 trace <> [top] + where + trace = unwrapParent . _evaluationCtxRankedParentHash <$> _forkInfoTrace forkInfo + top = _syncStateRankedBlockHash + . _consensusStateLatest + . _forkInfoTargetState + $ forkInfo + +assertForkInfoInvariants :: MonadThrow m => ForkInfo -> m () +assertForkInfoInvariants forkInfo = do + when (null (_forkInfoTrace forkInfo)) $ + unless (trgPayloadHash forkInfo == unwrapParent (_forkInfoBasePayloadHash forkInfo)) $ + throwM $ InvalidForkInfo + "The base payload hash must match the target payload hash, when the fork info trace is empty" + + where + trgPayloadHash = _latestPayloadHash . _forkInfoTargetState + +forkInfoProperties :: forall e kv . KeyValue e kv => ForkInfo -> [kv] +forkInfoProperties a = + [ "trace" .= _forkInfoTrace a + , "basePayloadHash" .= _forkInfoBasePayloadHash a + , "target" .= _forkInfoTargetState a + , "newBlockContext" .= _forkInfoNewBlockCtx a + ] + +instance ToJSON ForkInfo where + toEncoding = pairs . mconcat . forkInfoProperties + toJSON = object . forkInfoProperties + {-# INLINE toEncoding #-} + {-# INLINE toJSON #-} + +-- -------------------------------------------------------------------------- -- +-- Hints for querying Payloads + +newtype Hints = Hints + { _hintsOrigin :: PeerInfo + } + +hintsProperties :: forall e kv . KeyValue e kv => Hints -> [kv] +hintsProperties a = + [ "origin" .= _hintsOrigin a + ] + +instance ToJSON Hints where + toEncoding = pairs . mconcat . hintsProperties + toJSON = object . hintsProperties + {-# INLINE toEncoding #-} + {-# INLINE toJSON #-} + +-- -------------------------------------------------------------------------- -- +-- Encoded Payloads + +newtype EncodedPayloadData = EncodedPayloadData + { _encodedPayloadData :: B.ByteString } + deriving (Show, Eq, Ord, Generic) + deriving anyclass (NFData) + +instance ToJSON EncodedPayloadData where + toJSON = toJSON . encodeB64UrlNoPaddingText . _encodedPayloadData + toEncoding = b64UrlNoPaddingTextEncoding . _encodedPayloadData + {-# INLINE toJSON #-} + {-# INLINE toEncoding #-} + +instance FromJSON EncodedPayloadData where + parseJSON = withText "EncodedPayloadData" $ \t -> + case decodeB64UrlNoPaddingText t of + Left e -> fail (show e) + Right x -> return $ EncodedPayloadData x + {-# INLINE parseJSON #-} + +newtype EncodedPayloadOutputs = EncodedPayloadOutputs + { _encodedPayloadOutputs :: B.ByteString } + deriving (Show, Eq, Ord, Generic) + deriving anyclass (NFData) + +instance ToJSON EncodedPayloadOutputs where + toJSON = toJSON . encodeB64UrlNoPaddingText . _encodedPayloadOutputs + toEncoding = b64UrlNoPaddingTextEncoding . _encodedPayloadOutputs + {-# INLINE toJSON #-} + {-# INLINE toEncoding #-} + +instance FromJSON EncodedPayloadOutputs where + parseJSON = withText "EncodedPayloadOutputs" $ \t -> + case decodeB64UrlNoPaddingText t of + Left e -> fail (show e) + Right x -> return $ EncodedPayloadOutputs x + {-# INLINE parseJSON #-} + +-- -------------------------------------------------------------------------- -- +-- New Payload + +-- | +-- +-- Some metrics included that maybe used by consensus for performance +-- optimizations and optimal resource allocations and reporting of aggregated +-- metrics. +-- +-- TODO: describe encoding +-- +data NewPayload = NewPayload + { _newPayloadChainId :: !ChainId + , _newPayloadParentHeight :: !(Parent BlockHeight) + , _newPayloadParentHash :: !(Parent BlockHash) + , _newPayloadBlockPayloadHash :: !BlockPayloadHash + , _newPayloadEncodedPayloadData :: !(Maybe EncodedPayloadData) + , _newPayloadEncodedPayloadOutputs :: !(Maybe EncodedPayloadOutputs) + , _newPayloadNumber :: !Int + -- ^ a locally monotonically increasing identifier. Its purpose is to + -- induce an order on payloads that are created for the same parent + -- header. The miner will give precedence to larger id values. + + -- Informative: + , _newPayloadTxCount :: !Natural + -- ^ The number of user transactions in the block. The exact way how + -- transactions are counted is provider specific. + , _newPayloadSize :: !Natural + -- ^ On-chain storage size in bytes. This is not generally the same as + -- the size of the optional PayloadData. The exact meaning is provider + -- specific. + , _newPayloadOutputSize :: !Natural + -- ^ Size of evaluation outputs bytes. This is not generally the same as + -- the size of the optional PayloadOuputs. The exact meaning is provider + -- specific. + , _newPayloadFees :: !Stu + -- ^ The total amount of all fees payed for transaction processing in + -- Stu. The exact meaning is provider specific. + } + deriving (Show, Generic) + +_newPayloadRankedParentHash :: NewPayload -> Parent RankedBlockHash +_newPayloadRankedParentHash np = Parent $ RankedBlockHash + (unwrapParent $ _newPayloadParentHeight np) + (unwrapParent $ _newPayloadParentHash np) + +instance Eq NewPayload where + (==) = on (==) $ \x -> + -- move entropy to the beginning of the comparision to fail fast + -- (assuming that tuple starts at the front) + ( _newPayloadBlockPayloadHash x + , _newPayloadChainId x + , _newPayloadNumber x + , isJust (_newPayloadEncodedPayloadData x) + , isJust (_newPayloadEncodedPayloadOutputs x) + ) + -- including the chainweb version and chain id should ideally be + -- redundant for almost all sane (production) payload provider + -- implementations. But, for instance, Ethereum Development blocks share + -- the same block payload hash accross chains. The same is true for some + -- empty pact blocks in certain testing scenarios. + +instance Ord NewPayload where + compare = on compare $ \x -> + ( _newPayloadChainId x + , _newPayloadBlockPayloadHash x + , _newPayloadNumber x + , isJust (_newPayloadEncodedPayloadData x) + , isJust (_newPayloadEncodedPayloadOutputs x) + ) + +-- | NOTE: this instance is efficient but opinionated. It hashes blocks from +-- different chains with the same block payload hash to the same value. +-- Hopefully, this is a degenerated case that is of no relevance for practical +-- production settings (cf. the code comment on the Eq instance for some more +-- details). For non-degenerated applications the hash values are of high +-- quality. +-- +instance Hashable NewPayload where + -- This is opinionated but should be fine for our purposes + hashWithSalt s = hashWithSalt s . _newPayloadBlockPayloadHash + {-# INLINE hashWithSalt #-} + +instance HasChainId NewPayload where + _chainId = _newPayloadChainId + {-# INLINE _chainId #-} + +newPayloadProperties :: forall e kv . KeyValue e kv => NewPayload -> [kv] +newPayloadProperties a = + [ "chainId" .= _newPayloadChainId a + , "parentHeight" .= _newPayloadParentHeight a + , "parentHash" .= _newPayloadParentHash a + , "payloadHash" .= _newPayloadBlockPayloadHash a + , "data" .= _newPayloadEncodedPayloadData a + , "outputs" .= _newPayloadEncodedPayloadOutputs a + , "revision" .= _newPayloadNumber a + , "txCount" .= _newPayloadTxCount a + , "size" .= _newPayloadSize a + , "outputSize" .= _newPayloadOutputSize a + , "fees" .= _newPayloadFees a + ] + +instance ToJSON NewPayload where + toEncoding = pairs . mconcat . newPayloadProperties + toJSON = object . newPayloadProperties + {-# INLINE toEncoding #-} + {-# INLINE toJSON #-} + +-- -------------------------------------------------------------------------- -- +-- Payload Provider + +-- | Payload Provider API. +-- +-- Typically, a payload this is a list of transactions, including some system +-- specific transactions for rewarding miners and paying gas fees. It may also +-- include additional metadata that affect the evaluation. +-- +-- The content is completely provider specific. Chainweb only requires that +-- it has a finite binary representation that can be efficiently stored, +-- copied, and moved around. In particular, if a provider has internal ways +-- to materialize payload contents (e.g. using an internal P2P gossip +-- network), this type may contain only enough information to identify the +-- payload (e.g. a hash value). +-- +-- There are some semantic requirements about the evaluation of a block +-- payload. Those include the payment of rewards to the miner of a block +-- and support for SPV proofs (both creation and verification). The details +-- of those are beyond the scope of this document which is concerned with +-- the syntactic aspects of the node-internal provider API. +-- +-- Note, that the use of the term `Payload` is overloaded in the context of +-- Chainweb. Here it refers only to the input to block validation that is +-- provided by the payload provider. It does not include the evaluation +-- context that is provided by the consensus component of Chainweb and also +-- does not include the evaluation results. It also does not include the +-- internal state of the payload provider and changes to the state that are +-- caused by the evaluation of the payload. +-- +-- In some case this data structure may represent only a commitment to the +-- payload and the actual payload is synchronized out-off-band (from the +-- viewpoint of consensus) or not needed at all (in case of ZK +-- computations). +-- +-- Some payload providers mix data from the evaluation context and the +-- payload itself in a single data structure. This API can accomodate this +-- behavior. +-- +class (HasChainId p) => PayloadProvider p where + + -- | Returns the current sync state of the payload provider. + -- Note that this may be ahead of that returned by `prefetchBlock`. + -- + -- syncState :: p -> IO SyncState + + -- | Tell the PayloadProvider to fetch the block, and do whatever work is + -- necessary for us to synchronize with a block later that has this payload + -- hash. This is probably not necessary when compacted headers are added to + -- catchup. + -- + -- TODO: is this allowed to fail? Does it return or is it fire and forget? + -- + prefetchPayloads + :: HasVersion + => p + -> Maybe Hints + -> [Ranked ConsensusPayload] + -> IO () + + -- | Request that the payload provider updates its internal state to + -- represent the validation of the last block in the provide `ForkInfo`. + -- + -- If the the first entry in `ForkInfo` is not known to the payload provider + -- this operation is a no-op and the provider returns its current sync + -- state. + -- + -- The payload provider may update the internal state only to a predecessor + -- of the requested block. This can happen if, for instance, the operation + -- times out or gets interrupted or an validation error occurs. In any case + -- the must be valid and the respective `SyncState` must be returned. + -- + -- The payload provider may update the internal state to a successor + -- of the requested block. This can happen if the provider is unable to + -- rewind blocks on a fork, for example the EVM. In that case 'syncToBlock' + -- will regardless return a SyncState for the requested block, not the successor. + -- + -- Independent of the actual final state, the operation must satisify ACID + -- criteria. In particular, any intermediate state while the operation is + -- ongoing must not be observable and the final state must be consistent + -- and persistent. + -- + syncToBlock + :: HasVersion + => p + -- ^ Payload provider handle + -> Maybe Hints + -- ^ hints for fetching missing payloads + -> ForkInfo + -> IO ConsensusState + + -- | Asynchronously yield new block payloads on top of the latest block. + -- + -- The new payload is identified by the block payload hash. + -- + -- New payloads only depend on there respective evaluation context and new + -- block context and are only valid within this context. The context is + -- fully determined by the parent header, which is always the block of the + -- latest block of the current consensus state. It is represented by its + -- respective height and block hash. + -- + -- The result may include the actual payload and some representation of the + -- evaluation outputs. This allows for better error reporting and + -- optimizations in payload synchronizations (e.g. by piggybacking the new + -- payloads onto the respective new cuts in the P2P gossip network). Beside + -- of being a sequence of bytes the content of the those payloads are + -- completely parametric outside the context of the payload provider. + -- + -- Payload providers should cache new payloads internally as long they + -- are not either integrated into the longest chain or definitely + -- abandoned. Payload providers may also cache the validation result. + -- + latestPayloadSTM :: HasVersion => p -> STM NewPayload + + -- If backed by an TVar, this can usually be implemented more efficiently + -- using 'readTVarIO' + -- + latestPayloadIO :: HasVersion => p -> IO NewPayload + latestPayloadIO = atomically . latestPayloadSTM + + -- FIXME FIXME FIXME + eventProof :: HasVersion => p -> XEventId -> IO SpvProof + +nextPayloadStm :: (HasVersion, PayloadProvider p) => p -> NewPayload -> STM NewPayload +nextPayloadStm p cur = do + new <- latestPayloadSTM p + when (new == cur) retry + return new + +nextPayload :: (HasVersion, PayloadProvider p) => p -> NewPayload -> IO NewPayload +nextPayload p = atomically . nextPayloadStm p + +waitForChangedPayload :: (HasVersion, PayloadProvider p) => p -> IO NewPayload +waitForChangedPayload p = do + old <- latestPayloadIO p + nextPayload p old + +payloadStream :: (HasVersion, PayloadProvider p) => p -> S.Stream (S.Of NewPayload) IO () +payloadStream p = do + cur <- liftIO $ latestPayloadIO p + S.yield cur + go cur + where + go c = do + n <- liftIO $ nextPayload p c + S.yield n + go n + +-- -------------------------------------------------------------------------- -- +-- SPV + +-- | SPV Exceptions +-- +data PayloadSpvException + = InvalidBlockHeight XEventId + -- ^ The chain has not yet produced a block a the requested height. + | InvalidTransactionIndex XEventId + -- ^ A transaction with that index can not be found in the block + | InvalidEventIndex XEventId + -- ^ An event with that index can not be found in the transaction + | UnsupportedEventType XEventId + -- ^ The event type is not supported by the protocol + | InvalidEvent XEventId T.Text + -- ^ The event is invalid for some reason + | ProofPending XEventId BlockHeight + -- ^ The proof is not yet available on the target chain, which currently + -- is at the given block height. + deriving (Show, Eq) + +instance Exception PayloadSpvException where + displayException = T.unpack . renderPayloadSpvException + +renderPayloadSpvException :: PayloadSpvException -> T.Text +renderPayloadSpvException (InvalidBlockHeight e) = + "The chain has not yet produced a block a the requested height. " + <> encodeToText e +renderPayloadSpvException (InvalidTransactionIndex e) = + "A transaction with that index can not be found in the block. " + <> encodeToText e +renderPayloadSpvException (InvalidEventIndex e) = + "An event with that index can not be found in the transaction. " + <> encodeToText e +renderPayloadSpvException (UnsupportedEventType e) = + "The event type is not supported by the protocol. " + <> encodeToText e +renderPayloadSpvException (InvalidEvent e msg) = + "The event is invalid. " + <> encodeToText e + <> ". " <> msg +renderPayloadSpvException (ProofPending e curHeight) = + "The proof is not yet available on the target chain. " + <> encodeToText e + <> ". Current target chain height: " + <> sshow curHeight + +newtype TransactionIndex = TransactionIndex Natural + deriving (Show, Eq, Ord, Generic) + deriving newtype (FromJSON, ToJSON, Num, Enum, Real, Integral, HasTextRepresentation) + +newtype EventIndex = EventIndex Natural + deriving (Show, Eq, Ord, Generic) + deriving newtype (FromJSON, ToJSON, Num, Enum, Real, Integral, HasTextRepresentation) + +-- | A way to identify cross chain events. +-- +-- It is not required that this is payload provider independent. It is just +-- convenient. +-- +data XEventId = XEventId + { _xEventBlockHeight :: !BlockHeight + , _xEventTransactionIndex :: !TransactionIndex + , _xEventEventIndex :: !EventIndex + } + deriving (Show, Eq, Generic) + +instance ToJSON XEventId where + toJSON o = object + [ "height" .= _xEventBlockHeight o + , "transactionIndex" .= _xEventTransactionIndex o + , "eventIndex" .= _xEventEventIndex o + ] + +-- | Preliminary Type for SPV Event Proofs. +-- +newtype SpvProof = SpvProof Value + deriving (Show, Eq, Generic) + +-- -------------------------------------------------------------------------- -- +-- Some Payload Provider + +data ConfiguredPayloadProvider where + ConfiguredPayloadProvider :: PayloadProvider p => p -> ConfiguredPayloadProvider + DisabledPayloadProvider :: ConfiguredPayloadProvider + +-- -------------------------------------------------------------------------- -- +-- Utils + +_latestBlockHash :: ConsensusState -> BlockHash +_latestBlockHash = _syncStateBlockHash . _consensusStateLatest + +_latestRankedBlockHash :: ConsensusState -> RankedBlockHash +_latestRankedBlockHash = _syncStateRankedBlockHash . _consensusStateLatest + +_latestPayloadHash :: ConsensusState -> BlockPayloadHash +_latestPayloadHash = _syncStateBlockPayloadHash . _consensusStateLatest + +_latestHeight :: ConsensusState -> BlockHeight +_latestHeight = _syncStateHeight . _consensusStateLatest + +_safeBlockHash :: ConsensusState -> BlockHash +_safeBlockHash = _syncStateBlockHash . _consensusStateSafe + +_safePayloadHash :: ConsensusState -> BlockPayloadHash +_safePayloadHash = _syncStateBlockPayloadHash . _consensusStateSafe + +_safeHeight :: ConsensusState -> BlockHeight +_safeHeight = _syncStateHeight . _consensusStateSafe + +_finalBlockHash :: ConsensusState -> BlockHash +_finalBlockHash = _syncStateBlockHash . _consensusStateFinal + +_finalPayloadHash :: ConsensusState -> BlockPayloadHash +_finalPayloadHash = _syncStateBlockPayloadHash . _consensusStateFinal + +_finalHeight :: ConsensusState -> BlockHeight +_finalHeight = _syncStateHeight . _consensusStateFinal + +genesisState + :: HasVersion + => HasChainId c + => c + -> ConsensusState +genesisState c = ConsensusState + { _consensusStateLatest = s + , _consensusStateSafe = s + , _consensusStateFinal = s + } + where + s = SyncState + { _syncStateHeight = 0 + , _syncStateBlockHash = view blockHash hdr + , _syncStateBlockPayloadHash = view blockPayloadHash hdr + } + hdr = genesisBlockHeader c + +makeLenses ''ForkInfo diff --git a/src/Chainweb/PayloadProvider/EVM.hs b/src/Chainweb/PayloadProvider/EVM.hs new file mode 100644 index 0000000000..b7f8e6e827 --- /dev/null +++ b/src/Chainweb/PayloadProvider/EVM.hs @@ -0,0 +1,1939 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE NumericUnderscores #-} +{-# LANGUAGE OverloadedRecordDot #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeAbstractions #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +{-# OPTIONS_GHC -Wprepositive-qualified-module #-} +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +-- | +-- Module: Chainweb.PayloadProvider.EVM +-- Copyright: Copyright © 2024 Kadena LLC. +-- License: MIT +-- Maintainer: Lars Kuhtz +-- Stability: experimental +-- +module Chainweb.PayloadProvider.EVM +( EvmProviderConfig(..) +, evmConfEngineUri +, evmConfEngineJwtSecret +, evmConfMinerAddress +, defaultEvmProviderConfig +, pEvmProviderConfig +, validateEvmProviderConfig + +-- * EVM Payload Provider Implementation +, EvmPayloadProvider(..) +, withEvmPayloadProvider +, evmPayloadDb +, evmPayloadQueue + +-- * Payload Provider API +, evmSyncToBlock +) where + +import Chainweb.BlockHash qualified as Chainweb +import Chainweb.BlockHeader +import Chainweb.BlockHeight +import Chainweb.BlockPayloadHash +import Chainweb.ChainId +import Chainweb.Core.Brief +import Chainweb.Logger +import Chainweb.MinerReward +import Chainweb.Parent +import Chainweb.PayloadProvider hiding (TransactionIndex) +import Chainweb.PayloadProvider.EVM.EngineAPI +import Chainweb.PayloadProvider.EVM.EthRpcAPI +import Chainweb.PayloadProvider.EVM.ExecutionPayload +import Chainweb.PayloadProvider.EVM.Header qualified as EVM +import Chainweb.PayloadProvider.EVM.JsonRPC (JsonRpcHttpCtx, callMethodHttp) +import Chainweb.PayloadProvider.EVM.JsonRPC qualified as RPC +import Chainweb.PayloadProvider.EVM.PayloadDB qualified as EvmDB +import Chainweb.PayloadProvider.EVM.SPV +import Chainweb.PayloadProvider.EVM.Utils (decodeRlpM) +import Chainweb.PayloadProvider.EVM.Utils qualified as EVM +import Chainweb.PayloadProvider.EVM.Utils qualified as Utils +import Chainweb.PayloadProvider.P2P +import Chainweb.PayloadProvider.P2P.RestAPI +import Chainweb.PayloadProvider.P2P.RestAPI.Client qualified as Rest +import Chainweb.Ranked +import Chainweb.Storage.Table +import Chainweb.Storage.Table.Map +import Chainweb.Storage.Table.RocksDB +import Chainweb.Time +import Chainweb.Utils +import Chainweb.Version +import Configuration.Utils hiding (Error) +import Control.Concurrent +import Control.Concurrent.Async +import Control.Concurrent.STM +import Control.Exception.Safe +import Control.Lens hiding ((.=)) +import Control.Monad +import Control.Monad.Trans.Resource hiding (throwM) +import Control.Monad.Writer +import Data.ByteString.Short qualified as BS +import Data.HashMap.Strict qualified as HM +import Data.List qualified as L +import Data.LogMessage +import Data.Maybe +import Data.PQueue +import Data.Singletons +import Data.Text qualified as T +import Ethereum.Misc +import Ethereum.Misc qualified as EVM +import Ethereum.Misc qualified as Ethereum +import Ethereum.RLP +import Ethereum.Receipt +import GHC.Generics (Generic) +import GHC.TypeNats (fromSNat) +import Network.HTTP.Client qualified as HTTP +import Network.URI +import Network.URI.Static +import P2P.Session (ClientEnv) +import P2P.TaskQueue +import System.LogLevel +import Servant.Client (ClientM) + +-- -------------------------------------------------------------------------- -- +-- Payload Database + +type PayloadDb tbl = EvmDB.PayloadDb tbl + +initPayloadDb :: EvmDB.Configuration -> IO (EvmDB.PayloadDb_ a RocksDbTable) +initPayloadDb = EvmDB.initPayloadDb + +payloadDbConfiguration + :: HasVersion + => HasChainId c + => c + -> RocksDb + -> EVM.Header + -> EvmDB.Configuration +payloadDbConfiguration = EvmDB.configuration + +-- -------------------------------------------------------------------------- -- +-- Configuration + +pJwtSecret :: ChainId -> OptionParser JwtSecret +pJwtSecret cid = textOption + % prefixLongCid cid "evm-jwt-secret" + <> helpCid cid "JWT secret for the EVM Engine API" + +pMinerAddress :: ChainId -> OptionParser EVM.Address +pMinerAddress cid = textOption + % prefixLongCid cid "evm-miner-address" + <> helpCid cid "Miner address for new EVM blocks" + +newtype EngineUri = EngineUri { _engineUri :: URI } + deriving (Show, Eq, Generic) + deriving (ToJSON, FromJSON) via (JsonTextRepresentation "EngineUri" EngineUri) + deriving newtype (HasTextRepresentation) + +pEngineUri :: ChainId -> OptionParser EngineUri +pEngineUri cid = textOption + % prefixLongCid cid "evm-uri" + <> helpCid cid "EVM Engine URI" + +data EvmProviderConfig = EvmProviderConfig + { _evmConfEngineUri :: !EngineUri + , _evmConfEngineJwtSecret :: !JwtSecret + , _evmConfMinerAddress :: !(Maybe EVM.Address) + } + deriving (Show, Eq, Generic) + +makeLenses ''EvmProviderConfig + +defaultEvmProviderConfig :: EvmProviderConfig +defaultEvmProviderConfig = EvmProviderConfig + { _evmConfEngineUri = EngineUri [uri|http://localhost:8551|] + , _evmConfEngineJwtSecret = unsafeFromText "0000000000000000000000000000000000000000000000000000000000000000" + , _evmConfMinerAddress = Nothing + } + +validateEvmProviderConfig :: HasVersion => ChainId -> ConfigValidation EvmProviderConfig [] +validateEvmProviderConfig cid conf = do + when (euri == _evmConfEngineUri defaultEvmProviderConfig) $ tell + [ "EVM Engine URI for " <> sshow cid + <> " is to the default value: " <> sshow euri + <> ". This is likely to fail if more than one EVM chain is configured" + ] + when (jwt == _evmConfEngineJwtSecret defaultEvmProviderConfig) $ tell + [ "EVM Engine JWT secret for " <> sshow cid + <> " is to the default value: " <> sshow jwt + <> ". This value is not a secure JWT secret." + ] + when (isNothing $ _evmConfMinerAddress conf) $ tell + [ "EVM miner address is not set for " <> sshow cid + <> ". This means that payload production is disabled." + ] + where + euri = _evmConfEngineUri conf + jwt = _evmConfEngineJwtSecret conf + +instance ToJSON EvmProviderConfig where + toJSON o = object + [ "engineUri" .= _evmConfEngineUri o + , "engineJwtSecret" .= _evmConfEngineJwtSecret o + , "minerAddress" .= _evmConfMinerAddress o + ] + +instance FromJSON EvmProviderConfig where + parseJSON = withObject "EvmProviderConfig" $ \o -> EvmProviderConfig + <$> o .: "engineUri" + <*> o .: "engineJwtSecret" + <*> o .: "minerAddress" + +instance FromJSON (EvmProviderConfig -> EvmProviderConfig) where + parseJSON = withObject "EvmProviderConfig" $ \o -> id + <$< evmConfEngineUri ..: "engineUri" % o + <*< evmConfEngineJwtSecret ..: "engineJwtSecret" % o + <*< evmConfMinerAddress ..: "minerAddress" % o + +pEvmProviderConfig :: ChainId -> MParser EvmProviderConfig +pEvmProviderConfig cid = id + <$< evmConfEngineUri .:: pEngineUri cid + <*< evmConfEngineJwtSecret .:: pJwtSecret cid + <*< evmConfMinerAddress .:: fmap Just % pMinerAddress cid + +-- -------------------------------------------------------------------------- -- +-- EVM Payload Provider + +-- | EVM Payload Provider +-- +-- The EVM EL has to perform the following Chainweb specific validation tasks +-- on each EL header: +-- +-- 1. The miner reward in coinbase is correct +-- 2. The payload hash is the Merkle root of the EL header. +-- 3. EL time = CL parent time +-- +data EvmPayloadProvider logger = EvmPayloadProvider + { _evmChainId :: !ChainId + , _evmLogger :: !logger + , _evmPayloadStore :: !(PayloadStore (PayloadDb RocksDbTable) Payload) + -- ^ The BlockPayloadHash in the ConsensusState is different from the + -- EVM BlockHash that the EVM knows about. + -- + -- For new blocks that are not yet known to the EVM we need to provide + -- the EVM BlockHash. We compute this hash from the respective EVM + -- Header. The header is queried via the Chainweb consensus P2P (which + -- is also used to synchronize Pact payloads). + -- + -- After validating the EVM header against the corresponding evaluation + -- context we call engine_forkchoiceUpdated on it which synchronizes the + -- EVM to the respective block. After that we can obtain the EVM header + -- of the canonical chain from the EVM via JSON RPC API via the block + -- number. + -- + -- However, it is not clear how we can obtain non-canonical EVM headers + -- without knowing their EVM block hashes. This is needed to resolve + -- reorgs without having the synchronize the headers again from the P2P + -- network. For that reason we also stored the EVM headers (redundantly) + -- in the Payload Provider. + -- + -- Strictly, just storing the mapping from Chainweb BlockPayloadHash to + -- the EVM BlockHash would be sufficient to resolve reorgs (for headers + -- which had been validated against the evaluation context before). But + -- for simplicity we store the full EVM Header indexed by block height + -- and block payload hash. + -- + -- In the future we may consider teaching the EVM about Chainweb + -- BlockPayloadHashes. + , _evmCandidatePayloads :: !(MapTable RankedBlockPayloadHash Payload) + -- ^ FIXME: should this be moved into the Payload Store? + -- + -- At the moment this is not really used at all. + + , _evmEngineCtx :: !JsonRpcHttpCtx + -- ^ The JSON RPC context that provides the connection the Engine API of + -- the EVM. + , _evmMinerAddress :: !(Maybe Ethereum.Address) + -- ^ The miner address. If this is Nothing, payload creation is + -- disabled. + + -- Internal State: + + , _evmState :: !(TVar (T2 ConsensusState (Maybe NewBlockCtx))) + -- ^ The current consensus state and new block ctx of the EVM. + -- + -- The new block context is included so that new payload ID can be + -- requested in case the previous one got lost. + + , _evmPayloadId :: !(TMVar PayloadId) + -- ^ The payload ID along with the respective SyncState to which it + -- corresponds. If this is set it always corresponds to the current + -- consensus state. + + , _evmPayloadVar :: !(TMVar (T2 EVM.BlockHash NewPayload)) + -- ^ The most recent new payload + , _evmLock :: !(MVar ()) + -- ^ Not sure if we really need this. Users could race, but not sure + -- whether we actually care... + -- + -- FIXME: if we actually need or want this, we should probably use a + -- queue, or even better preempt earlier operations. + } + +stateIO :: EvmPayloadProvider logger -> IO (T2 ConsensusState (Maybe NewBlockCtx)) +stateIO = readTVarIO . _evmState + +latestStateIO :: EvmPayloadProvider logger -> IO SyncState +latestStateIO = fmap (_consensusStateLatest . sfst) . stateIO + +_isPayloadRequestedIO :: EvmPayloadProvider logger -> IO Bool +_isPayloadRequestedIO p = case _evmMinerAddress p of + Nothing -> return False + Just _ -> isJust . ssnd <$> stateIO p + +_newBlockCtxIO :: EvmPayloadProvider logger -> IO (Maybe NewBlockCtx) +_newBlockCtxIO p = case _evmMinerAddress p of + Nothing -> return Nothing + Just _ -> ssnd <$> stateIO p + +evmPayloadDb :: Getter (EvmPayloadProvider l) (PayloadDb RocksDbTable) +evmPayloadDb = to (_payloadStoreTable . _evmPayloadStore) + +evmPayloadQueue :: Getter (EvmPayloadProvider l) (PQueue (Task ClientEnv Payload)) +evmPayloadQueue = to (_payloadStoreQueue . _evmPayloadStore) + +instance HasChainId (EvmPayloadProvider logger) where + _chainId = _evmChainId + +-- | Expose the /local/ payload table. +-- +-- NOTE, this does /not/ look for payloads in P2P network. Data available in +-- this table is guaranteed to be fully validated, both by the execution client +-- as well as against the evaluation context. +-- +instance + ReadableTable (EvmPayloadProvider logger) RankedBlockPayloadHash Payload + where + tableLookup = tableLookup . _evmPayloadStore + tableLookupBatch' s = tableLookupBatch' (_evmPayloadStore s) + tableMember = tableMember . _evmPayloadStore + +-- | Expose the /local/ payload table. +-- +-- NOTE, this does /not/ look for payloads in P2P network. Data available in +-- this table is guaranteed to be fully validated, both by the execution client +-- as well as against the evaluation context. +-- +instance + Table (EvmPayloadProvider logger) RankedBlockPayloadHash Payload + where + tableInsert = tableInsert . _evmPayloadStore + tableInsertBatch s = tableInsertBatch (_evmPayloadStore s) + tableDelete s = tableDelete (_evmPayloadStore s) + tableDeleteBatch s = tableDeleteBatch (_evmPayloadStore s) + +-- | +-- +-- IMPORTANT NOTE: this takes into account the candidate store. This means +-- results can't be trusted to be evaluated. +-- +-- Candidates must be inserted in the candidate store only after they are +-- validated against the evaluation context. +-- +lookupConsensusState + :: ReadableTable tbl RankedBlockPayloadHash Payload + => tbl + -> ConsensusState + -> [(RankedBlockPayloadHash, Payload)] + -> IO (Maybe ForkchoiceStateV1) +lookupConsensusState p cs plds = do + r0 <- tableLookupBatch p + [ latestRankedBlockPayloadHash cs + , safeRankedBlockPayloadHash cs + , finalRankedBlockPayloadHash cs + ] + + -- Fill in payloads that are missing in the database from the candidate + -- payloads. + -- + case go <$> zip [lrh, srh, frh] r0 of + [Nothing, _, _] -> do + return Nothing + [Just l, Just s, Just f] -> return $ Just ForkchoiceStateV1 + { _forkchoiceHeadBlockHash = EVM._hdrHash $ _payloadHeader l + , _forkchoiceSafeBlockHash = EVM._hdrHash $ _payloadHeader s + , _forkchoiceFinalizedBlockHash = EVM._hdrHash $ _payloadHeader f + } + x -> error $ "corrupted database: " <> sshow x + -- FIXME throw proper error + -- + -- FIXME: I guess this can happen with shallow nodes? + -- The invariant is that if a block is in the db all predecessors + -- are valid, but they are not necessarily available. + where + go (k, Nothing) = lookup k plds + go (_, x) = x + lrh = latestRankedBlockPayloadHash cs + srh = safeRankedBlockPayloadHash cs + frh = finalRankedBlockPayloadHash cs + +loggS + :: Logger logger + => EvmPayloadProvider logger + -> T.Text + -- ^ sub-component name + -> LogLevel + -> T.Text + -> IO () +loggS p s = logFunctionText logger + where + logger = _evmLogger p & addLabel ("sub-component", s) + +logg + :: Logger logger + => EvmPayloadProvider logger + -> LogLevel + -> T.Text + -> IO () +logg p = logFunctionText (_evmLogger p) + +-- -------------------------------------------------------------------------- -- +-- Exceptions + +data EvmExecutionEngineException + = EvmChainIdMismatch (Expected EVM.ChainId) (Actual EVM.ChainId) + | EvmInvalidGenesisHeader (Expected BlockPayloadHash) (Actual BlockPayloadHash) + deriving (Eq, Generic) + +instance Show EvmExecutionEngineException where + show = displayException + +instance Exception EvmExecutionEngineException where + displayException (EvmChainIdMismatch e a) = + "Mismatched chain IDs: " <> sshow e <> ", " <> sshow a + <> ". The most probable cause is a mismatch between chainweb network-id and chainspec files." + displayException (EvmInvalidGenesisHeader e a) = + "Invalid genesis header: " <> sshow e <> ", " <> sshow a + <> ". The most probable cause is a mismatch between chainweb network-id and chainspec files." + +-- | Raised when an EVM header ca nnot be found +data EvmHeaderNotFoundException + = EvmHeaderNotFoundByNumber DefaultBlockParameter + | EvmHeaderNotFoundByHash EVM.BlockHash + | EvmHeaderNotFoundByPayloadHash BlockPayloadHash + deriving (Eq, Show, Generic) +instance Exception EvmHeaderNotFoundException + +data InvalidEvmState + = EvmGenesisHeaderNotFound + deriving (Eq, Show, Generic) +instance Exception InvalidEvmState + +newtype UnexpectedForkchoiceUpdatedResponseException + = UnexpectedForkchoiceUpdatedResponseException PayloadStatusV1 + deriving (Eq, Show, Generic) +instance Exception UnexpectedForkchoiceUpdatedResponseException + +newtype ForkchoiceUpdatedTimeoutException = ForkchoiceUpdatedTimeoutException Micros + deriving (Eq, Show, Generic) +instance Exception ForkchoiceUpdatedTimeoutException + +data ForkchoiceSyncFailedException = ForkchoiceSyncFailedException + { forkchoiceSyncFailedTarget :: ForkchoiceStateV1 + , forkchoiceSyncFailedActual :: EVM.Header + } + deriving (Eq, Show, Generic) +instance Exception ForkchoiceSyncFailedException + +-- | Thrown on an invalid payload status. +-- +-- The semantics of the first paramter depends on the context: +-- +-- In case block validation was attempted and failed, the second parameter is +-- the latest valid payload hash that is an ancestor of the payload hash for +-- which validation failed. +-- +-- In case of a newPayload request, if the new payload is not on the canonical +-- chain, no validation is attempted and the latest valid hash parameter is +-- 'Nothing'. +-- +data InvalidPayloadException = InvalidPayloadException + { _invalidPayloadExceptionLatestValidHash :: !(Maybe EVM.BlockHash) + , _invalidPayloadExceptionMessage :: !(Maybe T.Text) + } + deriving (Eq, Show, Generic) +instance Exception InvalidPayloadException + +newtype UnexpectedNewPayloadResponseException + = UnexpectedNewPayloadResponseException PayloadStatusV1 + deriving (Eq, Show, Generic) +instance Exception UnexpectedNewPayloadResponseException + +newtype NewPayloadTimeoutException = NewPayloadTimeoutException Micros + deriving (Eq, Show, Generic) +instance Exception NewPayloadTimeoutException + +-- -------------------------------------------------------------------------- -- + +-- | Initializes a new EVM Payload provider +-- +-- Note, that an exception is raised if the execution client is not available. +-- +-- The function blocks while trying to connect to the execution client. It is +-- therefor advisable that this function is called asynchronously. +-- +-- FIXME: +-- +-- Verify that the genesis headers form the execution client match what is +-- stored in the chainweb version. +-- +withEvmPayloadProvider + :: Logger logger + => HasVersion + => HasChainId c + => logger + -> c + -> RocksDb + -> Maybe HTTP.Manager + -- ^ P2P Network manager. This is supposed to be shared among all P2P + -- network clients. + -- + -- It is /not/ used for communication with the execution engine client. + -> EvmProviderConfig + -> ResourceT IO (EvmPayloadProvider logger) +withEvmPayloadProvider logger c rdb mgr conf + | FromSing @_ @p (SEvmProvider ecid) <- payloadProviderTypeForChain c = do + engineCtx <- liftIO $ mkEngineCtx (_evmConfEngineJwtSecret conf) (_engineUri $ _evmConfEngineUri conf) + + SomeChainwebVersionT @v _ <- return someChainwebVersionVal + SomeChainIdT @c _ <- return $ someChainIdVal c + + let pldCli = Rest.payloadClient @v @c @p + let pldCliBatch = mkPayloadBatchClient @v @c + + genPld <- liftIO $ checkExecutionClient logger c engineCtx (EVM.ChainId (fromSNat ecid)) + liftIO $ logFunctionText logger Info $ "genesis payload block hash: " <> sshow (EVM._hdrPayloadHash genPld) + liftIO $ logFunctionText logger Debug $ "genesis payload from execution client: " <> sshow genPld + pdb <- liftIO $ initPayloadDb $ payloadDbConfiguration c rdb genPld + store <- liftIO $ newPayloadStore mgr (logFunction pldStoreLogger) pdb pldCli pldCliBatch + pldVar <- liftIO newEmptyTMVarIO + pldIdVar <- liftIO newEmptyTMVarIO + candidates <- liftIO emptyTable + stateVar <- liftIO $ newTVarIO (T2 (genesisState c) Nothing) + lock <- liftIO $ newMVar () + let p = EvmPayloadProvider + { _evmChainId = _chainId c + , _evmLogger = logger + , _evmState = stateVar + , _evmPayloadStore = store + , _evmCandidatePayloads = candidates + , _evmEngineCtx = engineCtx + , _evmMinerAddress = _evmConfMinerAddress conf + , _evmPayloadId = pldIdVar + , _evmPayloadVar = pldVar + , _evmLock = lock + } + + listenerAsync <- withAsyncR (payloadListener p) + liftIO $ link listenerAsync + liftIO $ + logg p Info $ + "EVM payload provider started for Ethereum network id " <> sshow (fromSNat ecid) + return p + + | otherwise = + error "Chainweb.PayloadProvider.Evm.configuration: chain does not use EVM provider" + where + pldStoreLogger = addLabel ("sub-component", "payloadStore") logger + +mkPayloadBatchClient + :: forall (v :: ChainwebVersionT) (c :: ChainIdT) + . KnownChainwebVersionSymbol v + => KnownChainIdSymbol c + => [RankedBlockPayloadHash] + -> ClientM [Maybe Payload] +mkPayloadBatchClient rhs = do + rs <- _payloadList <$> Rest.payloadBatchClient @v @c @(EvmProvider _) rhs + let rs' = HM.fromList $ (\pld -> (_pldRankedBlockPayloadHash pld, pld)) <$> rs + return $ (`HM.lookup` rs') <$> rhs + +-- | Checks the availability of the Execution Client +-- +-- - asserts API availability +-- - asserts the EVM chain id matches the chainweb version and chainweb chain id +-- - asserts that the Genesis header is available +-- +-- Returns the genesis header. +-- +checkExecutionClient + :: HasVersion + => Logger logger + => HasChainId c + => logger + -> c + -> JsonRpcHttpCtx + -> EVM.ChainId + -- ^ expected Ethereum Network ID + -> IO EVM.Header +checkExecutionClient logger c ctx expectedEcid = do + ecid <- try @_ @SomeException (callMethodHttp @Eth_ChainId ctx Nothing) >>= \case + Left err -> do + logFunctionText logger Error + $ "Exception while initially connecting to EVM on chain " <> toText (_chainId c) <> ": " + <> T.pack (displayException err) + error "Error connecting to EVM" + Right ecid -> return ecid + unless (expectedEcid == ecid) $ + throwM $ EvmChainIdMismatch (Expected expectedEcid) (Actual ecid) + callMethodHttp @Eth_GetBlockByNumber ctx (DefaultBlockNumber 0, False) >>= \case + Nothing -> throwM EvmGenesisHeaderNotFound + Just h -> do + unless (EVM._hdrPayloadHash h == expectedGenesisHeader) $ + throwM $ EvmInvalidGenesisHeader + (Expected expectedGenesisHeader) + (Actual $ EVM._hdrPayloadHash h) + return h + where + expectedGenesisHeader = genesisBlockPayloadHash (_chainId c) + +-- -------------------------------------------------------------------------- -- +-- Payload Listener + +-- | Base rate for new payload requests. +-- +getPayloadRate :: Int +getPayloadRate = 1_000_000 + +getPayloadBurst :: Int +getPayloadBurst = 4 + +-- | minimum delay between requests for new payloads +-- +getPayloadMinDelay :: Int +getPayloadMinDelay = 10_000 + +-- | If we don't receive a new payload ID with this time, we assume that the +-- EVM is not available and log an error. This is implemented in the +-- 'awaitNewPayload' function. +-- +-- FIXME: consider raising an actual error. +-- +getPayloadTimeout :: Int +getPayloadTimeout = 30_000_000 + +-- | Scheduler for listening for new payloads. +-- +payloadListener :: (Logger logger, HasVersion) => EvmPayloadProvider logger -> IO () +payloadListener p = case _evmMinerAddress p of + Nothing -> do + lf Info "New payload creation is disabled." + return () + Just addr -> runForeverThrottled lf "EVM Provider Payload Listener" (int getPayloadBurst) (int getPayloadRate) $ do + lf Info $ "Start payload listener with miner address " <> toText addr + + -- This is small delay compared to the base rate. So we just always add + -- it. It is only relevant during bursts. + threadDelay $ int getPayloadMinDelay + awaitNewPayload p + where + lf = loggS p "payloadListener" + +-- -------------------------------------------------------------------------- -- +-- Engine Calls + +-- | Updates the forkchoice state of the EVM. Does not initiate payload +-- production. +-- +-- This must be called only after validating the evaluation context for all +-- blocks that lead from the current state to the target state. +-- +-- When new payload production was requested the state of the payload id +-- variable is updated. Otherwise the state of the payload id variable is set to +-- empty. +-- +-- Returns: new EVM BlockHash +-- +-- Throws: +-- +-- * ForkchoiceUpdatedTimeoutException +-- * UnexpectedForkchoiceUpdatedResponseException +-- * InvalidPayloadException +-- +-- * Engine RPC failures +-- * Eth RPC failures +-- * JSON RPC failure +-- +forkchoiceUpdate + :: Logger logger + => EvmPayloadProvider logger + -> Micros + -- ^ Timeout in microseconds + -> ForkchoiceStateV1 + -- ^ the requested fork choice state + -> Maybe PayloadAttributesV3 + -> IO (Maybe PayloadId) +forkchoiceUpdate p t fcs attr = do + try @_ @(RPC.Error EngineServerErrors EngineErrors) + (RPC.callMethodHttp @Engine_ForkchoiceUpdatedV3 (_evmEngineCtx p) request) + >>= \r -> case r of + Right s -> case _forkchoiceUpdatedV1ResponsePayloadStatus s of + -- Syncing: we need to call eth_syncing to find out when the sync is + -- done, then check that we're where we expect. + -- if we are where we expect, we still need to request a payload ID + -- with a subsequent FCU. + PayloadStatusV1 Syncing Nothing Nothing -> go t + + -- If the status is VALID, the latest hash is what was requested. + -- + -- In particular, if the status is VALID the return latest hash + -- is never an ancestor of the requested hash. + -- + -- If payload creation was requested the payload id is null only + -- if no payload attributes were provided. (If the payload + -- attributes are invalid an error is returned, even thought the + -- forkchoice state *is* updated.) + -- + -- IMPORTANT NOTE: + -- + -- The Engine API specification demands that, if the requested + -- hash was not the latest hash on the (selected) canonical + -- chain this returns the latest hash on the canonical chain. It + -- will not initiate payload creation. This behavior is not + -- acceptable for Chainweb consensus. + -- + -- Therefore will have to patch the EVM client such that the + -- latest hash will be the requested hash and payload production + -- is initiated if it was requested. + -- + PayloadStatusV1 Valid (Just _) Nothing -> do + lf Info "forkchoiceUpdate succeeded with VALID status" + return (_forkchoiceUpdatedV1ResponsePayloadId s) + + -- Validation failed permenently. + -- + -- FIXME: list precise list of possible reasons. + -- + PayloadStatusV1 Invalid (Just h) e -> + throwM $ InvalidPayloadException (Just h) e + + -- If the status is INVALID and no latest valid predecessor + -- can be determined. + -- + -- This means probably means that the block for which + -- the upddate is requested is detached from the canonical + -- history. + -- + -- FIXME: We should probably point that out in the exception + -- and possibly react to this scenario by banning the source + -- of the block. + -- + -- (Note this could possibly also happen for shallow nodes + -- that are not yet fully synced.) + -- + e@(PayloadStatusV1 Invalid Nothing _) -> + throwM $ UnexpectedForkchoiceUpdatedResponseException e + + -- Something else when wrong. + -- + e -> + throwM $ UnexpectedForkchoiceUpdatedResponseException e + + -- According to Engine Spec [8, point 7] + -- {error: {code: -38003, message: "Invalid payload attributes"}} + -- is returned even when forkchoiceState has been updated, but + -- payload attributes were invalid. + -- + -- NOTE: we must MUST address this case and update the state! + -- + Left (RPC.Error (RPC.ApplicationError InvalidPayloadAttributes) msg Nothing) -> do + + -- FIXME: + -- how to we signal this to caller, in particular, + -- consensus? If this goes undetected mining may get stuck. + -- If this is due to a timestamp being the same as the + -- previous block, we'll have to figure out what to do about + -- it. Maybe patching reth? + -- + -- For now we log an Error. + -- + T2 cur _ <- stateIO p + lf Error $ msg <> ": forkchoiceUpdate succeeded but no payload is produced, because of invalid payload attributes. This is most likely due to a non-increasing timestamp" + lf Error $ encodeToText $ object + [ "forkchoiceState" .= fcs + , "payloadAttributes" .= attr + , "previousState" .= cur + , "response" .= r + ] + return Nothing + + Left e -> throwM e + where + request = ForkchoiceUpdatedV3Request fcs attr + lf = loggS p "forkchoiceUpdate" + waitTime = Micros 100_000 + go remaining + | remaining <= 0 = do + lf Warn "forkchoiceUpdate timed out while EVM is syncing" + throwM $ ForkchoiceUpdatedTimeoutException t + | otherwise = do + lf Info $ briefJson $ object + [ "remainingTime" .= remaining + , "forkchoiceState" .= fcs + , "payloadAttributes" .= attr + ] + + r <- RPC.callMethodHttp @Eth_Syncing (_evmEngineCtx p) Nothing + case r of + SyncingStatusFalse -> do + -- we're not syncing anymore, but that doesn't guarantee that we're at our target. + -- poll the current consensus state of the EVM. + Just evmLatest <- callMethodHttp @Eth_GetBlockByNumber (_evmEngineCtx p) (DefaultBlockLatest, False) + if EVM._hdrHash evmLatest == _forkchoiceHeadBlockHash fcs + then do + -- we're synced! do another FCU to get the payload ID if needed. + -- make sure not to reset the timeout by accident :) + case attr of + Nothing -> return Nothing + Just _ -> forkchoiceUpdate p remaining fcs attr + else do + -- we're not synced, but the sync is done! sync must + -- have failed, report an error. + throwM $ ForkchoiceSyncFailedException fcs evmLatest + SyncingStatus {} -> do + lf Info $ "EVM is SYNCING. Waiting for " <> sshow waitTime <> " microseconds" + threadDelay $ int waitTime + go (remaining - waitTime) + +-- | Engine NewPayloadV4 +-- +-- cf. https://github.com/ethereum/execution-apis/blob/main/src/engine/paris.md#engine_newpayloadv1 +-- cf. https://github.com/ethereum/execution-apis/blob/main/src/engine/shanghai.md#engine_newpayloadv2 +-- cf. https://github.com/ethereum/execution-apis/blob/main/src/engine/cancun.md#engine_newpayloadv3 +-- cf. https://github.com/ethereum/execution-apis/blob/main/src/engine/prague.md#engine_newpayloadv4 +-- +newPayload + :: Logger logger + => EvmPayloadProvider logger + -> Micros + -- ^ Global Timeout in microseconds + -> NewPayloadV4Request + -- ^ The request to the EVM Engine API. + -> IO () +newPayload p t request = go t + where + lf = loggS p "newPayload" + waitTime = Micros 500_000 + go remaining + | remaining <= 0 = do + lf Warn "newPayload timed out while EVM is syncing" + + -- FIXME FIXME FIXME + -- this is an experiment. Check comment in validatePayload for + -- details. It seems that when reth returns SYNCING we are actually + -- stuck (it does not resolve itself). So, we try to force it to + -- sync and hope that when we come back the newPaylaod call is + -- successful. + -- updateEvm p trgState Nothing [] + + throwM $ NewPayloadTimeoutException t + | otherwise = do + lf Info $ briefJson $ object + [ "remainingTime" .= remaining + , "request" .= request + ] + r <- try @_ @(RPC.Error EngineServerErrors EngineErrors) $ + RPC.callMethodHttp @Engine_NewPayloadV4 (_evmEngineCtx p) + request + case r of + -- If the status is VALID, the latest hash is what was requested. + -- + -- In particular, if the status is VALID the return latest hash + -- is never an ancestor of the requested hash. + -- + -- The payload *MUST* be validated if the payload extends the + -- canonical chain and all requisite data is available. + -- + -- IMPORTANT NOTE: + -- + -- The Engine API specification demands that, if the requested + -- hash was not the latest hash on the (selected) canonical + -- chain this returns the latest hash on the canonical chain. It + -- will not initiate payload creation. This behavior is not + -- acceptable for Chainweb consensus. + -- + -- Therefore will have to patch the EVM client such that the + -- latest hash will be the requested hash and payload production + -- is initiated if it was requested. + -- + Right (PayloadStatusV1 Valid (Just _) Nothing) -> do + lf Info "newPayload succeeded with VALID status" + + -- The following conditions are met: + -- + -- - all transactions have non-zero length + -- - the blockHash of the payload is valid + -- - the payload doesn't extend the canonical chain + -- - the payload hasn't been fully validated + -- - ancestors of a payload are known and comprise a well-formed chain. + -- - the versioned block hashes match the values in the block + -- - the request commitments match the values in the block + -- + Right (PayloadStatusV1 Accepted Nothing Nothing) -> + lf Info "newPayload succeeded with ACCEPTED status" + + -- Syncing: retry + -- + -- A sync process *MAY* be initiated if requesite data for + -- payload validation is missing. + -- + -- Certain checks are performed before a sync process is + -- initiated. However, the specification is not clear with + -- respect to this. + -- + Right (PayloadStatusV1 Syncing Nothing Nothing) -> do + -- wait 500ms + lf Warn $ "newPayload: EVM is SYNCING. Waiting for " <> sshow waitTime <> " microseconds" + threadDelay $ int waitTime + go (remaining - waitTime) + + -- The new payload is invalid. This includes + -- + -- - transactions contains zero length or invalid entries + -- - block hash validation fails + -- - the versioned blob hashes do not match + -- - the request commitments do not match + -- - Validation was attempted but failed and the EL cannot determine + -- the latest valid hash that is an ancestor of the payload. + -- + Right (PayloadStatusV1 Invalid Nothing e) -> + throwM $ InvalidPayloadException Nothing e + + -- Validation was attempted but failed. + -- + -- The latest valid hash is the latest valid ancestor of the + -- payload hash. + -- + Right (PayloadStatusV1 Invalid (Just h) e) -> + throwM $ InvalidPayloadException (Just h) e + + Right e -> + throwM $ UnexpectedNewPayloadResponseException e + + Left (RPC.Error (RPC.ApplicationError InvalidPayloadAttributes) msg Nothing) -> do + T2 cur _ <- stateIO p + lf Error $ msg <> ": newPayload succeeded but no payload is produced, because of invalid payload attributes. This is most likely due to a non-increasing timestamp" + lf Error $ encodeToText $ object + [ "method" .= ("newPayloadV4" :: T.Text) + , "request" .= request + , "response" .= r + , "currentConsensusState" .= cur + ] + + Left e -> throwM e + +-- | Calls forkchoiceUpdate and updates the provider state. +-- +-- NOTE: This must be called only for consensus states that have been validated +-- against the evaluation context. In particular, this is the case for the +-- @_evmState@ and for any payload in the payload db. +-- +-- NOTE: If the result status is VALID the returned latest valid hash is always +-- the requested for the requested block. A different latest valid hash may be +-- returned if and only if the result status is INVALID. +-- +updateEvm + :: Logger logger + => EvmPayloadProvider logger + -> ConsensusState + -- ^ the requested fork choice state. This state *MUST* have been + -- validated with respect to the evaluation context. + -> Maybe NewBlockCtx + -> [(RankedBlockPayloadHash, Payload)] + -- ^ Payloads that are added to the database if EVM validation succeeds. + -- These payloads must already be validated with respect to the + -- evaluation context. + -- + -- FIXME: add a newtype wrapper for (Pre-)Validated Payloads and guard + -- forkchoiceUpdate and database insertion by it. + -- + -> IO () +updateEvm p state nctx plds = lookupConsensusState p state plds >>= \case + Nothing -> do + lf Info $ "Consensus state lookup returned nothing for" <> briefJson state + return () + Just fcs -> do + lf Info $ "Calling forkChoiceUpdate on state " + <> briefJson state <> " with " <> briefJson fcs + pt <- parentTimestamp + _ <- atomically $ tryTakeTMVar (_evmPayloadId p) + pid <- forkchoiceUpdate p forkchoiceUpdatedTimeout fcs (attr pt) + + -- forkchoiceUpdate throws if it does not succeed. + + -- add new payloads to payload database + lf Info $ "new payloads added to database: " <> sshow (length plds) + mapM_ (uncurry (tableInsert (_evmPayloadStore p))) plds + + -- Update State and Payload Id: + -- There is a race here: If we fail updating the variable + -- the EVM is ahead. That could cause payload updates to + -- fail and possibly stale mining. + lf Info "update state and payload ID variable" + lf Debug $ briefJson $ object + [ "newState" .= state + , "newBlockCtx" .= nctx + , "newPayloadId" .= pid + ] + void $ atomically $ do + -- update state + writeTVar (_evmState p) (T2 state nctx) + -- update payloadId + forM_ pid $ writeTMVar (_evmPayloadId p) + where + lf = loggS p "updateEvm" + attr pt = mkPayloadAttributes (_latestHeight state) (_latestBlockHash state) pt + <$> _evmMinerAddress p + <*> nctx + + -- This is available either from the provided new payloads or from the + -- database. In any case, it /must/ be a source that has been validated with + -- respect to the evaluation context. + parentTimestamp = do + let lrh = latestRankedBlockPayloadHash state + pld <- case lookup lrh plds of + Just x -> return x + Nothing -> tableLookup p lrh >>= \case + Nothing -> error $ "Chainweb.PayloadProvider.EVM.updateEvm: failed to find EVM payload header for target " <> sshow lrh + Just x -> return x + return $ EVM._hdrTimestamp $ _payloadHeader pld + +mkPayloadAttributes + :: BlockHeight + -- ^ ParentBlockHeight, i.e. the Chainweb block height of the parent of + -- the new block. + -> Chainweb.BlockHash + -- ^ ParentBeaconBlockRoot, i.e. the Chainweb block hash of the parent of + -- the new block. + -> Timestamp + -- ^ The timestamp of the /parent/ EVM header. + -> EVM.Address + -> NewBlockCtx + -> PayloadAttributesV3 +mkPayloadAttributes pheight phash parentTimestamp addr nctx = PayloadAttributesV3 + { _payloadAttributesV3parentBeaconBlockRoot = EVM.chainwebBlockHashToBeaconBlockRoot phash + , _payloadAttributesV2 = PayloadAttributesV2 + { _payloadAttributesV2Withdrawals = [withdrawal] + , _payloadAttributesV1 = PayloadAttributesV1 + { _payloadAttributesV1Timestamp = et + , _payloadAttributesV1SuggestedFeeRecipient = addr + , _payloadAttributesV1PrevRandao = randao + } + } + } + where + MinerReward reward = _newBlockCtxMinerReward nctx + withdrawal = WithdrawalV1 + { _withdrawalValidatorIndex = 0 + , _withdrawalIndex = int pheight + 1 + , _withdrawalAmount = int reward + , _withdrawalAddress = addr + } + + -- FIXME: are there an assumptions about this value? + -- I guess, for now this fine -- better than something that looks random. + randao = Utils.Randao (Ethereum.encodeLeN 0) + + et = EVM.timestamp parentTimestamp (unwrapParent $ _newBlockCtxParentCreationTime nctx) + +-- -------------------------------------------------------------------------- -- +-- Await New Payload + +data EvmNewPayloadExeception + = BlobsNotSupported + | InvalidNewPayloadHeight (Expected BlockHeight) (Actual BlockHeight) + | InconsistentNewPayloadFees + { _inconsistentPayloadBlockValue :: !BlockValue + , _inconsistentPayloadFees :: !Stu + } + | InconsistentNewPayloadHash (Expected EVM.BlockHash) (Actual EVM.BlockHash) + deriving (Show, Eq, Generic) + +instance Exception EvmNewPayloadExeception + +-- | If a payload id is available, new payloads for it. +-- +-- This is called only if payload creation is enabled in the configuration. +-- +awaitNewPayload :: (Logger logger, HasVersion) => EvmPayloadProvider logger -> IO () +awaitNewPayload p = do + lf Debug "await new payload ID" + awaitPid >>= \case + Nothing -> do + lf Error "timeout while waiting for new payloadID" + + -- DEBUG + T2 state bctx <- stateIO p + pld <- latestPayloadIO p + + lf Warn $ "timeout while waiting for new payloadID" + <> ": consensus state: " <> briefJson state + <> ", new block ctx: " <> briefJson bctx + <> ", latest payload: " <> briefJson pld + -- FIXME + -- We are probalby stuck. What can we do? Call forkchoiceUpdate + -- again? Or we just do nothing? Maybe it should be the job of + -- consensus to reissue a syncToBlock and get things going again? + -- + -- Well, let's just give it a try. + -- + -- Again, there is a race here, but we are already in trouble. So, + -- let's just ignore it for now. + -- T2 s nbctx <- readTVarIO (_evmState p) + -- updateEvm p s nbctx [] + + -- FIXME FIXME FIXME but let's also make sure that we actally need + -- this whole timeout thing. + + Just x -> go x + where + lf = loggS p "awaitNewPayload" + ctx = _evmEngineCtx p + cid = _chainId p + + -- GasUsed is demoninated in Gwei, BaseFeePerGas is in Wei. + -- Wei in Ethereum is equivalent to Stu in Chainweb. + gweiToWei x = x * 1_000_000_000 + + fees v1 = Stu $ bf * gweiToWei gu + where + EVM.BaseFeePerGas bf = _executionPayloadV1BaseFeePerGas v1 + GasUsed gu = _executionPayloadV1GasUsed v1 + + -- Wait for payload from the exeution client + -- FIXME not sure if the timeout is a good idea... + awaitPid = do + timeout <- registerDelay getPayloadTimeout + atomically $ + Nothing <$ (readTVar timeout >>= guard) + <|> + Just <$> readTMVar (_evmPayloadId p) + + -- process the new payload + go pid = do + + lf Debug $ "got payload ID " <> encodeToText [pid] + resp <- RPC.callMethodHttp @Engine_GetPayloadV4 ctx [pid] + lf Debug $ "got execution payload for payload ID " <> toText pid + + -- FIXME if this fails with unknown payload, we need to issues a new + -- forkchoiceUpdate in order to obtain a new payload. Otherwise mining gets + -- stuck. + + -- Response data + let v3 = _getPayloadV4ResponseExecutionPayload resp + v2 = _executionPayloadV2 v3 + v1 = _executionPayloadV1 v2 + h = EVM.numberToHeight $ _executionPayloadV1BlockNumber v1 + newEvmBlockHash = _executionPayloadV1BlockHash v1 + + -- check that this is a new payload + atomically (tryReadTMVar (_evmPayloadVar p)) >>= \case + Just (T2 curEvmBlockHash _) + | curEvmBlockHash == newEvmBlockHash -> do + lf Info "The new execution payload is the same as the current payload. No update." + x -> do + lf Debug $ "checking new execution payload for " <> toText pid + <> "; execution payload: " <> briefJson resp + + sstate <- latestStateIO p + + -- FIXME is this ok the get the parent from the state? What if + -- the pid and the state are not in sync? Can that happen? + -- Should we store the parent along with the pid + let phdr = _syncStateBlockHash sstate + pheight = _syncStateHeight sstate + pbhdr = EVM.chainwebBlockHashToBeaconBlockRoot phdr + pld = getPayloadV4ResponseToPayload pbhdr resp + pldHdr = _payloadHeader pld + + -- get revision number (zero if this is the first payload) + let n = maybe 0 (succ . _newPayloadNumber . ssnd) x + + -- check that Blobs bundle is empty + unless (null $ _blobsBundleV1Blobs $ _getPayloadV4ResponseBlobsBundle resp) $ + throwM BlobsNotSupported + + -- Check that the block height matches the expected height + unless ((_syncStateHeight sstate + 1) == h) $ + throwM $ InvalidNewPayloadHeight (Expected (_syncStateHeight sstate + 1)) (Actual h) + + -- Check that the fees of the execution paylod match the block + -- value of the response. + -- FXIME: the fee computation is wrong. I think, the block value + -- is not the base fee per gas times the gas used. It's probably + -- a lower bound, but not 100% sure. + -- + -- unless (EVM._blockValueStu (_getPayloadV4ResponseBlockValue resp) == fees v1) $ + -- throwM InconsistentNewPayloadFees + -- { _inconsistentPayloadBlockValue = _getPayloadV4ResponseBlockValue resp + -- , _inconsistentPayloadFees = fees v1 + -- } + + -- Check that the computed block hash matches the hash from the + -- response + unless (newEvmBlockHash == EVM._hdrHash pldHdr) $ do + lf Warn $ "Inconsitent new payload hash for " <> brief (phdr, pheight) + throwM $ InconsistentNewPayloadHash + (Expected newEvmBlockHash) + (Actual (EVM._hdrHash pldHdr)) + + lf Info $ "got new payload " <> briefJson pld + + -- The actual payload header is included in the NewBlock + -- structure as EncodedPayloadData. + lf Debug $ "write new payload to payload var for evm hash " <> briefJson newEvmBlockHash + atomically $ writeTMVar (_evmPayloadVar p) $ T2 newEvmBlockHash NewPayload + { _newPayloadTxCount = int $ length (_executionPayloadV1Transactions v1) + , _newPayloadSize = int $ sum $ BS.length . _transactionBytes + <$> _executionPayloadV1Transactions v1 + , _newPayloadParentHeight = Parent $ _syncStateHeight sstate + , _newPayloadParentHash = Parent $ _syncStateBlockHash sstate + , _newPayloadBlockPayloadHash = EVM._hdrPayloadHash pldHdr + , _newPayloadOutputSize = 0 + , _newPayloadNumber = n + , _newPayloadFees = fees v1 + , _newPayloadEncodedPayloadOutputs = Nothing + , _newPayloadEncodedPayloadData = Just (EncodedPayloadData $ putRlpByteString pld) + , _newPayloadChainId = cid + } + +-- -------------------------------------------------------------------------- -- +-- Sync To Block + +withLock :: MVar () -> IO a -> IO a +withLock l a = withMVar l (const a) + +-- | Timeout for evmSyncToBlock +-- +forkchoiceUpdatedTimeout :: Micros +forkchoiceUpdatedTimeout = 3_000_000 + +-- | Synchronize the EL to the given block. +-- +-- This function must *must* validate that all EL-headers up to the target block +-- are valid. +-- +-- In order to validate any EL header we need to map the Chainweb block hash +-- and/or payload hash to the respective Eth block hash. This requires that the +-- EVM provider must synchronize payload informatin along with the block headers +-- that is sufficient for this lookup. +-- +-- Also, the evaluation context is not known to the EVM and thus it can not tell +-- if a block is invalid with respect to the evluation context. It is our job to +-- make sure that those payloads are all consistent with the evluation context. +-- We must do this check /before/ we actually let the EVM update its state, so +-- that (1.) users don't observe invalid states and (2.) we can recover from a +-- bad block (the EVM is monotonic for the canoncial chain). +-- +-- The EVM EL header structure provides sufficient information to validate an EL +-- block against the evluation context. +-- +-- If we are given a singleton evaluation context along with the respective EL +-- header we +-- +-- 1. validate that the contex is consistent with the EL header and +-- 2. request the EVM to sync to that header, which will cause the EVM to query +-- respective full execution payload and transition to the new state. +-- +-- If we validate more than a single blokc at a time, the EL queries the +-- respective EL payloads autonomously. We *must* ensure ahead of calling the +-- EVM that any full execution payload satifies the respective evaluation +-- context. +-- +-- We can do this as follows: +-- +-- 1. Eth block hash of the previous latest valid state is contained in any root +-- of the the target state (either the eth hash or Chainweb block hash or +-- Chainweb payload hash), +-- 2. Each Eth header +-- TODO +-- +-- Hard requirements are that +-- +-- 1. We keep track what EL blocks have already been validated against their +-- respecitve evaluation context. +-- 2. We never only ask for validation of blocks for which we have the EL header +-- available. +-- +evmSyncToBlock + :: Logger logger + => HasVersion + => EvmPayloadProvider logger + -> Maybe Hints + -> ForkInfo + -> IO ConsensusState +evmSyncToBlock p hints forkInfo = withLock (_evmLock p) $ do + T2 curState _ <- stateIO p + lf Debug $ "current state: " <> briefJson curState <> "; target state: " <> briefJson trgState + if trgState == curState + then do + + -- We are are already at the target state, but maybe payload production + -- is requested. + -- + -- FIXME do this only when new payload building is requested + -- + lf Info $ "current state requested: " <> brief (_consensusStateLatest curState) + updateEvm p curState pctx [] + + else do + -- Otherwise we'll take a look at the forkinfo trace + + -- lookup the fork info base payload hash + -- + -- NOTE we must query the local store directly and not use the P2P + -- network. + -- + let rankedBaseHash = _forkInfoBaseRankedPayloadHash forkInfo + tableLookup p (unwrapParent rankedBaseHash) >>= \case + + -- If we don't know that base, there's nothing we can do + Nothing -> do + lf Warn $ "unknown base " <> brief rankedBaseHash + lf Info $ encodeToText forkInfo + + Just _ -> case trace of + -- Case of an empty trace: + -- + -- The base is the same as the target. The table lookup could + -- only succeed if we evaluated the target state before. If it + -- is in our database we can attempt to sync to it, which may + -- either succeed or fail. + -- + [] -> do + lf Debug "empty trace" + updateEvm p trgState pctx [] + + l -> do + -- in case of a non-empty trace, we lookup the first entry in + -- the trace. (FIXME We could be smarted and search for the + -- latest know payload, but we skip that optimization for now) + -- + -- If we don't know the first entry, we fail. Otherwise, we + -- validate all headers in the context. If validation succeeds + -- we call syncToBlock. If that succeeds we add the headers to + -- the database. + -- + -- It could also make sense to check the empty trace case first + -- and skip any ctx validation. + + ctxBlockHashes <- tableLookupBatch p (_evaluationCtxRankedPayloadHash <$> l) + let (knowns', unknowns') = span (isJust . snd) $ zip l ctxBlockHashes + + -- assert db invariant + unless (all (isNothing . snd) unknowns') $ + error "Chainweb.PayloadProviders.EVM.syncToBlock: detected corrupted payload database" + + let knowns = fst <$> knowns' + let unknowns = fst <$> unknowns' + + lf Debug $ "unknown blocks in context: " <> sshow (length unknowns) + lf Debug $ "known blocks in context: " <> sshow (length knowns) + + -- fetch all unknown payloads + -- + -- FIXME do the right thing here. Ideally, fetch all + -- unknowns in batches without redundant local lookups. Then + -- validate all payloads together before sending them to the + -- EVM and inserting them into the DB. + + + -- Before we proceed to the validation we need to make sure + -- that the EVM has synced all payloads that are known to + -- the payload provider. Normally that happens at startup. + -- However, at startup that happens only up to the latest + -- cut. But there is no guarantee that the latest cut isn't + -- behind the latest known payload of the provider (e.g. + -- when the cut got reset). In those cases it can happen + -- that during catchup we encounter blocks that are known to + -- the provider but not yet to the EVM. To resolve this we + -- check that the last known payload is known to the EVM + -- according to the current EVM state. + -- + -- The ForkInfo trace is based on the forkpoint with the + -- payload provider and not the EVM state. Therefore when + -- the EVM state is behind we need to advance the EVM to the + -- fork point first. We call evmUpdate whenever the first + -- trace entry is ahead of the evm state. + -- + case unknowns of + (firstUnknown:_) -> do + let lastKnownPayloadHash = case reverse knowns of + [] -> unwrapParent $ _forkInfoBasePayloadHash forkInfo + (lastKnown:_) -> _consensusPayloadHash $ _evaluationCtxPayload lastKnown + + let lastKnownHeight = firstUnknown._evaluationCtxParentHeight.unwrapParent + let lastKnownHash = firstUnknown._evaluationCtxParentHash.unwrapParent + when (_latestHeight curState < lastKnownHeight) $ do + lf Warn $ "Chainweb.PayloadProviders.EVM.syncToBlock: last known block in the trace is ahead of the current EVM state" + <> "; last known height: " <> sshow lastKnownHeight + <> "; last known hash: " <> brief lastKnownHash + <> "; current state height: " <> sshow (_latestHeight curState) + <> "; current state hash: " <> brief (_latestBlockHash curState) + + -- call evmUpdate to update the EVM to the last unknown + -- block without providing any payload attributes or + -- payloads, so the validation state does not change. + -- + -- We are updating consensus here but that is ok, + -- because it is still below the head of the canonical + -- chain that we go asked to update to. It is also still + -- within the range of known to be valid blocks. We do + -- not update the safe or final state at this point. + let lastKnownConsensusState = ConsensusState + { _consensusStateLatest = SyncState + { _syncStateHeight = lastKnownHeight + , _syncStateBlockHash = lastKnownHash + , _syncStateBlockPayloadHash = lastKnownPayloadHash + } + , _consensusStateSafe = curState._consensusStateSafe + , _consensusStateFinal = curState._consensusStateFinal + } + updateEvm p lastKnownConsensusState Nothing [] + _ -> return () + + -- If we have more than one unknown we first try to fetch + -- all payloads in a batch and inject them into the + -- candidate store. This will insert them into the candidate + -- table. After this the getPayloadForContext call below + -- should be not hit the network any more. This is currently + -- only beneficial when synchronizing long forks or a with a + -- consensus that is ahead, like during replay or + -- reinitialization of the payload provider. + -- + when (length unknowns > 1) $ + void $ getPayloadsForConsensusPayloads p hints + (_evaluationCtxRankedPayload <$> unknowns) + + plds <- forM unknowns $ \ctx -> do + pld <- getPayloadForContext p hints ctx + + -- The follwoing can result in timeouts. Even on empty + -- blocks. But why? Well, see the comment about + -- synchronizing the EVM with the payload provider + -- above! + -- + -- The issue is when we have a header in the payload db + -- (we know it) but the EVM does not yet know about it. + -- That's a corner case that can happen when syncing + -- after the EVM and the payload provider got out of + -- sync. In those cases it is the best to update the EVM + -- first. Normally, that happens at startup, but when + -- the cut got reset, the payload provider may know + -- validated blocks beyond the latest cut. Whe consensus + -- moves the cut beyond the latest block that is known + -- to the EVM, but the payload provider already knows + -- those blocks we get into a situation where the blocks + -- in the fork info trace do not cover the missing + -- blocks in the EVM. + -- + -- At the moment this is solved by the code above that + -- calls updateEvm to move the EVM state up to the last + -- unknown block in the trace. + -- + -- Can we skip the newPayload call during validation -- + -- at least sometimes? If we instruct the EVM to just go + -- to those blocks it will sync all by itself. However, + -- we still must guarantee that we validated the + -- Chainweb Merkle root of all payloads that the payload + -- provider knows about. + -- + validatePayload p pld ctx + return (_evaluationCtxRankedPayloadHash ctx, pld) + + lf Debug $ "fetched payloads for unknowns: " <> sshow (length plds) + + updateEvm p trgState pctx plds + + -- remove plds from canidate cache (anything in the db + -- shoudl be removed) + + newState <- sfst <$> stateIO p + lf Debug $ "done validating payloads. New state is " <> briefJson newState + + -- TODO cleeanup. In particular prune candidate store + pruneCandidates p + sfst <$> stateIO p + where + lf = loggS p "syncToBlock" + trgState = _forkInfoTargetState forkInfo + trace = _forkInfoTrace forkInfo + pctx = _forkInfoNewBlockCtx forkInfo + +-- | The depth at which the candidate cache is pruned. We prune after each +-- successful syncToBlock call. Most of the time this cache is very small and +-- pruning should be very fast. +-- +-- * In normal operation, that just extends the chain, the a pruning depth of 0 is +-- fine +-- * For "normal" reorgs the diameter of the graph is sufficient. +-- +-- FIXME Make this depend on the catchup step size. +-- +-- * Remove items from this cache that are in the validated database. +-- +-- * For reorgs that are due to network forks/partitions the depth of the +-- catchup would be optimal, which is bounded by the reorg limit. For now we +-- ignore that case. We want a solution where we don't have permanent cost +-- overhead for this exceptional scenario. +-- +candidatePruningDepth :: HasVersion => EvmPayloadProvider logger -> BlockHeight -> BlockHeight +candidatePruningDepth _p h = int $ diameter (chainGraphAt h) + +pruneCandidates :: HasVersion => EvmPayloadProvider logger -> IO () +pruneCandidates p = do + lrh <- latestRankedBlockPayloadHash . sfst <$> stateIO p + let h = _rankedHeight lrh + deleteLt (_evmCandidatePayloads p) lrh + { _rankedHeight = h - candidatePruningDepth p h + } + +-- | Fetch the payload for a given evaluation context. +-- +-- FIXME: +-- This is inefficient for various reasons: +-- +-- 1. When we call this function we did already establish which payloads are +-- available localy and have been validated before. There is no need to try +-- to look them up locally again. (Although, it is probably pretty cheap) +-- 2. This function fetches payloads one by one. Instead we should query them +-- in chunks using the existing batch endpoints. (This is usually only +-- relevant during catchup. Otherwise we anyways go block by block.) +-- 3. With the EVM provider we can validate the payloads with respect to the +-- evaluation contexts in batches before sending them to the execution +-- client. +-- +getPayloadForContext + :: Logger logger + => EvmPayloadProvider logger + -> Maybe Hints + -> EvaluationCtx ConsensusPayload + -> IO Payload +getPayloadForContext p h ctx = do + mapM_ insertPayloadData (_consensusPayloadData $ _evaluationCtxPayload ctx) + pld <- getPayload + (_evmPayloadStore p) + (_evmCandidatePayloads p) + (Priority $ negate $ int $ _evaluationCtxCurrentHeight ctx) + (_hintsOrigin <$> h) + (_evaluationCtxRankedPayloadHash ctx) + tableInsert (_evmCandidatePayloads p) rh pld + return pld + where + rh = _evaluationCtxRankedPayloadHash ctx + + insertPayloadData epld = case decodePayloadData epld of + Right pld -> tableInsert (_evmCandidatePayloads p) rh pld + Left e -> do + lf Warn $ "failed to decode encoded payload from evaluation ctx: " <> sshow e + + lf :: LogFunctionText + lf = loggS p "getPayloadForContext" + +-- | Fetch payloads for a list of evaluation contexts. +-- +_getPayloadForContexts + :: Logger logger + => EvmPayloadProvider logger + -> Maybe Hints + -> [EvaluationCtx ConsensusPayload] + -> IO [(RankedBlockPayloadHash, Payload)] +_getPayloadForContexts p h ctxs = + getPayloadsForConsensusPayloads p h $ _evaluationCtxRankedPayload <$> ctxs + +getPayloadsForConsensusPayloads + :: Logger logger + => EvmPayloadProvider logger + -> Maybe Hints + -> [Ranked ConsensusPayload] + -> IO [(RankedBlockPayloadHash, Payload)] +getPayloadsForConsensusPayloads p h cps = do + insertPayloadDataBatch (_evmCandidatePayloads p) + plds <- getPayloads + (_evmPayloadStore p) + (_evmCandidatePayloads p) + (Priority $ negate $ int $ _rankedHeight $ head cps) + (_hintsOrigin <$> h) + (fmap _consensusPayloadHash <$> cps) + tableInsertBatch (_evmCandidatePayloads p) plds + return plds + where + insertPayloadDataBatch tbl = do + plds <- mapM decodePld cps + tableInsertBatch tbl $ catMaybes plds + + decodePld rcp@(Ranked _ cp) = case mapM decodePayloadData $ _consensusPayloadData cp of + Right pld -> + return $ (_consensusPayloadHash <$> rcp,) <$> pld + Left e -> do + lf Warn $ "failed to decode encoded payloads from evaluation ctx: " <> sshow e + return Nothing + + lf :: LogFunctionText + lf = loggS p "getPayloadsForConsensusPayloads" + +newPayloadTimeout :: Micros +newPayloadTimeout = 30_000_000 + +-- | FIXME: +-- +-- Do the actual validation. In particular, validate the whole chain of payloads +-- from the context in one go. +-- +validatePayload + :: Logger logger + => EvmPayloadProvider logger + -> Payload + -> EvaluationCtx ConsensusPayload + -> IO () +validatePayload p pld _ctx = do + + -- FIXME: this requires that we have the full evaluation context available, + -- which includes all transactions. This is potentially expensive. + -- + -- Announce the payload to the EVM via new Payload. This does some EVM + -- specific validation. + -- + -- If the new block extends the canonical chain and all requisites are + -- available the EVM will fully validate the payload. + -- + -- If the call returns and the block is *not* fully validated it is accepted + -- by the EVM which guarantees that the payload header is valid and the + -- payload is syntactically correct. + -- + -- The forkchoice state is *NOT* updated. + -- + -- This call may take a some time (the timeout is 8 seconds) + -- + -- FIXME: It is not clear if this is the best place to make this call. + -- FXIME: It may make sense to issue this call asynchronously -- but it + -- would complicate the overall validation logic. So, we keep that as future + -- work. + -- + -- For now this throws if we get a timeout or any other error. + -- + _ <- case payloadToNewPayloadV4Request pld of + Nothing -> return () + Just epld -> do + newPayload p newPayloadTimeout epld + + return () + +-- -------------------------------------------------------------------------- -- +-- Payload Provider API Instance + +instance Logger logger => PayloadProvider (EvmPayloadProvider logger) where + prefetchPayloads = evmPrefetchPayloads + syncToBlock = evmSyncToBlock + latestPayloadSTM p = ssnd <$> readTMVar (_evmPayloadVar p) + eventProof = getSpvProof + +evmPrefetchPayloads + :: HasVersion + => Logger logger + => EvmPayloadProvider logger + -> Maybe Hints + -> [Ranked ConsensusPayload] + -> IO () +evmPrefetchPayloads p h ps = do + lf Info $ "query: " <> sshow (length ps) + rs <- getPayloadsForConsensusPayloads p h ps + lf Info $ "got: " <> sshow (length rs) + where + lf = loggS p "prefetchPayloads" + +-- -------------------------------------------------------------------------- -- +-- SPV + +-- | Obtains all RpcReceipts for a block. It is an exception if the block can +-- not be found. +-- +-- Returns: a list of EVM RpcReceipts +-- +-- Throws: +-- +-- * EvmHeaderNotFoundException +-- * Eth RPC failures +-- * JSON RPC failures +-- +-- FIXME: filter for topic +-- +getLogEntries + :: EvmPayloadProvider logger + -> EVM.BlockNumber + -> IO [RpcLogEntry] +getLogEntries p n = do + callMethodHttp + @Eth_GetLogs (_evmEngineCtx p) + [ object + [ "fromBlock" .= DefaultBlockNumber n + , "toBlock" .= DefaultBlockNumber n + ] + ] + +getLogEntry + :: EvmPayloadProvider logger + -> XEventId + -> IO LogEntry +getLogEntry p e = do + -- it would be nice if we could just use the log entry index, but that is + -- over the whole block and not just the tx + logs <- getLogEntries p (int $ _xEventBlockHeight e) + case filter ftx logs of + [] -> throwM $ InvalidTransactionIndex e + tx -> case tx L.!? int (_xEventEventIndex e) of + Nothing -> throwM $ InvalidEventIndex e + Just l -> return $ fromRpcLogEntry l + where + ftx RpcLogEntry { _rpcLogEntryTransactionIndex = TransactionIndex l } = + l == int (_xEventTransactionIndex e) + +getSpvProof + :: Logger logger + => HasVersion + => EvmPayloadProvider logger + -> XEventId + -> IO SpvProof +getSpvProof p e = do + entry <- getLogEntry p e + lf Info $ "got logEntry: " <> encodeToText entry + ld <- parseXLogData e entry + lf Info $ "got logData: " <> sshow ld + return $ SpvProof $ object + [ "origin" .= object + [ "chainId" .= _chainId p + , "contract" .= _xLogDataSenderAddress ld + , "height" .= _xEventBlockHeight e + , "transactionIdx" .= _xEventTransactionIndex e + , "eventIdx" .= _xEventEventIndex e + ] + , "targetChainId" .= _xLogDataTargetChain ld + , "targetContract" .= _xLogDataTargetContract ld + , "operationName" .= _xLogDataOperationName ld + , "data" .= _xLogDataMessage ld + ] + where + lf = loggS p "getSpvProof" + +-- -------------------------------------------------------------------------- -- +-- Utils + +_latestNumber :: ConsensusState -> EVM.BlockNumber +_latestNumber = EVM.heightToNumber . _latestHeight + +_safeNumber :: ConsensusState -> EVM.BlockNumber +_safeNumber = EVM.heightToNumber . _safeHeight + +_finalNumber :: ConsensusState -> EVM.BlockNumber +_finalNumber = EVM.heightToNumber . _finalHeight + +_encodedPayloadData :: Payload -> EncodedPayloadData +_encodedPayloadData = EncodedPayloadData . putRlpByteString + +decodePayloadData :: MonadThrow m => EncodedPayloadData -> m Payload +decodePayloadData (EncodedPayloadData bs) = decodeRlpM bs + +-- -------------------------------------------------------------------------- -- +-- ATTIC +-- -------------------------------------------------------------------------- -- + +-- -------------------------------------------------------------------------- -- +-- Engine Calls + +_getHashByNumber + :: JsonRpcHttpCtx + -> DefaultBlockParameter + -> IO (Maybe EVM.BlockHash) +_getHashByNumber ctx p = fmap EVM._hdrHash <$> + callMethodHttp @Eth_GetBlockByNumber ctx (p, False) + +-- | Obtains a block by EVM block hash. It is an exception if the block can not +-- be found. +-- +-- Returns: EVM Header +-- +-- Throws: +-- +-- * EvmHeaderNotFoundException +-- * Eth RPC failures +-- * JSON RPC failures +-- +_getBlockByHash + :: EvmPayloadProvider pdf + -> EVM.BlockHash + -> IO EVM.Header +_getBlockByHash p h = do + r <- RPC.callMethodHttp + @Eth_GetBlockByHash (_evmEngineCtx p) (h, False) + case r of + Just hdr -> return hdr + Nothing -> throwM $ EvmHeaderNotFoundByHash h + +-- | Obtains a block by number. It is an exception if the block can not be +-- found. +-- +-- Returns: EVM Header +-- +-- Throws: +-- +-- * EvmHeaderNotFoundException +-- * Eth RPC failures +-- * JSON RPC failures +-- +_getBlockAtNumber + :: EvmPayloadProvider pdf + -> EVM.BlockNumber + -> IO EVM.Header +_getBlockAtNumber p n = do + r <- RPC.callMethodHttp + @Eth_GetBlockByNumber (_evmEngineCtx p) (DefaultBlockNumber n, False) + case r of + Just h -> return h + Nothing -> throwM $ EvmHeaderNotFoundByNumber (DefaultBlockNumber n) + +-- | Returns the EVM genesis block. +-- +-- Returns: EVM Header +-- +-- Throws: +-- +-- * InvalidEvmState +-- * Eth RPC failures +-- * JSON RPC failures +-- +_getGenesisHeader + :: EvmPayloadProvider pdf + -> IO EVM.Header +_getGenesisHeader p = try (_getBlockAtNumber p 0) >>= \case + Left (EvmHeaderNotFoundByNumber _) -> throwM EvmGenesisHeaderNotFound + Left e -> throwM e + Right x -> return x + +-- -------------------------------------------------------------------------- -- +-- Utils for querying EVM block details for a consensus state + +-- | Get the header for the latest block in a consensus state from the EVM. +-- +-- Throws: +-- +-- * EvmHeaderNotFoundException with +-- * EvmHeaderNotFoundByNumber if there is no block for the given number. This +-- usually means that consensus state references a block that has not been +-- validated before. +-- * EvmHeaderNotFoundByPayloadHash if the block on the given number does not +-- match the block in the payload state. This usually means that the +-- referenced block is on different fork. +-- +_getLatestHdr + :: EvmPayloadProvider pdb + -> ConsensusState + -> IO EVM.Header +_getLatestHdr p s = do + hdr <- _getBlockAtNumber p (_latestNumber s) + unless (view EVM.hdrPayloadHash hdr == _latestPayloadHash s) $ + throwM $ EvmHeaderNotFoundByPayloadHash (_latestPayloadHash s) + return hdr + +-- | Get the header for the safe block in a consensus state. +-- +-- Throws: +-- +-- * EvmHeaderNotFoundException with +-- * EvmHeaderNotFoundByNumber if there is no block for the given number. This +-- usually means that consensus state references a block that has not been +-- validated before. This can happen only if the latest block has not been +-- evaluted yet neither. +-- * EvmHeaderNotFoundByPayloadHash if the block on the given number does not +-- match the block in the payload state. This usually means that the +-- referenced block is on different fork. For this to happen the latest +-- block must be on a different fork, too. +-- +_getSafeHdr + :: EvmPayloadProvider pdb + -> ConsensusState + -> IO EVM.Header +_getSafeHdr p s = do + hdr <- _getBlockAtNumber p (_safeNumber s) + unless (view EVM.hdrPayloadHash hdr == _safePayloadHash s) $ + throwM $ EvmHeaderNotFoundByPayloadHash (_safePayloadHash s) + return hdr + +-- | Get the header for the final block in a consensus state. +-- +-- Throws: +-- +-- * EvmHeaderNotFoundException with +-- * EvmHeaderNotFoundByNumber if there is no block for the given number. This +-- usually means that consensus state references a block that has not been +-- validated before. This can happen only if the latest and safe blocks have +-- not been evaluted yet neither. +-- * EvmHeaderNotFoundByPayloadHash if the block on the given number does not +-- match the block in the payload state. This usually means that the +-- referenced block is on different fork. For this to happen the latest and +-- safe block must be on a different fork, too. +-- +_getFinalHdr + :: EvmPayloadProvider pdb + -> ConsensusState + -> IO EVM.Header +_getFinalHdr p s = do + hdr <- _getBlockAtNumber p (_finalNumber s) + unless (view EVM.hdrPayloadHash hdr == _finalPayloadHash s) $ + throwM $ EvmHeaderNotFoundByPayloadHash (_finalPayloadHash s) + return hdr + +-- | Get the hash for the latest block in a consensus state. +-- +-- Cf. 'getLatestHeader' for details. +-- +_getLatestHash + :: EvmPayloadProvider pdb + -> ConsensusState + -> IO EVM.BlockHash +_getLatestHash p = fmap (view EVM.hdrHash) . _getLatestHdr p + +-- | Get the hash for the safe block in a consensus state. +-- +-- Cf. 'getSafeHeader' for details. +-- +_getSafeHash + :: EvmPayloadProvider pdb + -> ConsensusState + -> IO EVM.BlockHash +_getSafeHash p = fmap (view EVM.hdrHash) . _getSafeHdr p + +-- | Get the hash for the final block in a consensus state. +-- +-- Cf. 'getFinalHeader' for details. +-- +_getFinalHash + :: EvmPayloadProvider pdb + -> ConsensusState + -> IO EVM.BlockHash +_getFinalHash p = fmap (view EVM.hdrHash) . _getFinalHdr p diff --git a/src/Chainweb/PayloadProvider/EVM/EngineAPI.hs b/src/Chainweb/PayloadProvider/EVM/EngineAPI.hs new file mode 100644 index 0000000000..61baa3fcc1 --- /dev/null +++ b/src/Chainweb/PayloadProvider/EVM/EngineAPI.hs @@ -0,0 +1,1406 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE DeriveFunctor #-} + +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE StandaloneKindSignatures #-} +{-# LANGUAGE TypeOperators #-} + +-- | +-- Module: Chainweb.PayloadProvider.EVM.EngineAPI +-- Copyright: Copyright © 2024 Kadena LLC. +-- License: MIT +-- Maintainer: Lars Kuhtz +-- Stability: experimental +-- +-- Ethereum Engine API: +-- +-- https://ethereum.org/en/developers/docs/apis/json-rpc/ +-- https://github.com/ethereum/execution-apis +-- https://ethereum.github.io/execution-apis/api-documentation/ +-- +-- There are currently four versions of the Engine API: +-- +-- - Paris: First version that is used during the "merge". It covers several +-- details of the transition from PoW to PoS that are not relevant in the +-- context of Chainweb. +-- +-- - Shanghai: Introduces support for Withdrawals and adds +-- - WithdrawalsV1 +-- - ExecutionPayloadBodyV1 +-- - engine_getPayloadBodiesByHashV1 +-- - engine_getPayloadBodiesByRangeV1 +-- +-- - Cancun: Introduces support for Blobs and adds +-- - BlobsBundleV1 +-- - BlobAndProofV1 +-- - engine_getBlobsV1 +-- +-- - Prague: Introduces support for ExecutionRequests +-- +-- The implementation does not cover all features from all versions. +-- +-- IMPORTANT NOTE: +-- +-- Consensus Layer client software MUST wait for a specified timeout before +-- aborting the call. In such an event, the Consensus Layer client software +-- SHOULD retry the call when it is needed to keep progressing. +-- +-- Consensus Layer client software MAY wait for response longer than it is +-- specified by the timeout parameter. +-- +module Chainweb.PayloadProvider.EVM.EngineAPI +( WithdrawalV1(..) +, withdrawlsRoot +, ForkchoiceStateV1(..) +, DefaultBlockParameter(..) +, EngineServerErrors(..) +, EngineErrors(..) +, PayloadId(..) +, PayloadStatusV1(..) +, TransactionBytes(..) +, transactionsRoot + +-- * Payload Attributes +, PayloadAttributesV1(..) +, PayloadAttributesV2(..) +, PayloadAttributesV3(..) +, PayloadStatusStatus(..) + +-- * Forkchoice Update +, ForkchoiceUpdatedV3Request(..) +, ForkchoiceUpdatedV1Response(..) + +-- * Execution Payload +, ExecutionPayloadV1(..) +, ExecutionPayloadV2(..) +, ExecutionPayloadV3(..) +, NewPayloadV4Request(..) + +-- * Get Payload Response +, Blob(..) +, KzgProof(..) +, KzgCommitment(..) +, BlobsBundleV1(..) +, VersionedHash(..) +, versionedHashes +, BlockValue(..) +, GetPayloadV2Response(..) +, GetPayloadV3Response(..) +, GetPayloadV4Response(..) + +-- * Authentication and Client Context +, JwtSecret(..) +, jwtToken +, getJwtToken +, mkSimpleEngineCtx +, mkEngineCtx + +-- * Engine API Methods +, type Engine_GetPayloadV2 +, type Engine_GetPayloadV3 +, type Engine_GetPayloadV4 +, type Engine_ForkchoiceUpdatedV3 +, type Engine_NewPayloadV4 +) where + +import Chainweb.PayloadProvider.EVM.Header +import Chainweb.PayloadProvider.EVM.JsonRPC +import Chainweb.PayloadProvider.EVM.Utils +import Chainweb.Utils +import Control.Monad.Catch +import Crypto.Hash.Algorithms (SHA256) +import Crypto.MAC.HMAC +import Data.Aeson +import Data.Bifunctor +import Data.ByteArray qualified as BA +import Data.ByteString.Short qualified as BS +import Data.Foldable +import Data.Hashable (Hashable) +import Data.Text qualified as T +import Data.Text.Encoding qualified as T +import Data.Time.Clock.POSIX (getPOSIXTime, POSIXTime) +import Data.Word +import Ethereum.Misc qualified as E +import Ethereum.RLP (RLP (..), putRlpByteString, getRlpL, putRlpL, label) +import Ethereum.Trie +import Ethereum.Utils hiding (int, natVal_) +import Foreign.Storable (Storable) +import GHC.Generics (Generic) +import GHC.TypeLits +import Network.HTTP.Client qualified as HTTP +import Network.URI +import Network.URI.Static (uri) +import System.IO.Unsafe (unsafePerformIO) +import Data.Hash.SHA2 +import Data.Coerce + +-- -------------------------------------------------------------------------- -- +-- Forkchoice State V1 + +-- | Forkchoice state object V1 +-- +-- This structure encapsulates the fork choice state. +-- +-- cf. https://github.com/ethereum/execution-apis/blob/main/src/engine/paris.md#forkchoicestatev1 +-- +data ForkchoiceStateV1 = ForkchoiceStateV1 + { _forkchoiceHeadBlockHash :: !E.BlockHash + -- ^ headBlockHash: DATA, 32 Bytes - block hash of the head of the + -- canonical chain + , _forkchoiceSafeBlockHash :: !E.BlockHash + -- ^ safeBlockHash: DATA, 32 Bytes - the "safe" block hash of the + -- canonical chain under certain synchrony and honesty assumptions. This + -- value MUST be either equal to or an ancestor of headBlockHash + , _forkchoiceFinalizedBlockHash :: !E.BlockHash + -- ^ finalizedBlockHash: DATA, 32 Bytes - block hash of the most recent + -- finalized block + } + deriving (Show, Eq, Generic) + +instance ToJSON ForkchoiceStateV1 where + toEncoding o = pairs + $ "headBlockHash" .= _forkchoiceHeadBlockHash o + <> "safeBlockHash" .= _forkchoiceSafeBlockHash o + <> "finalizedBlockHash" .= _forkchoiceFinalizedBlockHash o + {-# INLINE toEncoding #-} + + toJSON o = object + [ "headBlockHash" .= _forkchoiceHeadBlockHash o + , "safeBlockHash" .= _forkchoiceSafeBlockHash o + , "finalizedBlockHash" .= _forkchoiceFinalizedBlockHash o + ] + {-# INLINE toJSON #-} + +instance FromJSON ForkchoiceStateV1 where + parseJSON = withObject "ForkchoiceStateV1" $ \o -> ForkchoiceStateV1 + <$> o .: "headBlockHash" + <*> o .: "safeBlockHash" + <*> o .: "finalizedBlockHash" + {-# INLINE parseJSON #-} + +-- -------------------------------------------------------------------------- -- +-- Payload Status Status + +-- | Payload validation status +-- +-- Set of possible values is restricted to +-- "VALID" | "INVALID" | "SYNCING" | "ACCEPTED" | "INVALID_BLOCK_HASH" +-- +-- cf. https://github.com/ethereum/execution-apis/blob/main/src/engine/paris.md#payloadstatusv1 +-- +data PayloadStatusStatus + = Valid + | Invalid + | Syncing + | Accepted + | InvalidBlockHash + deriving (Show, Eq, Generic, Enum, Bounded) + deriving (ToJSON, FromJSON) via (JsonTextRepresentation "PayloadStatusStatus" PayloadStatusStatus) + +instance HasTextRepresentation PayloadStatusStatus where + toText Valid = "VALID" + toText Invalid = "INVALID" + toText Syncing = "SYNCING" + toText Accepted = "ACCEPTED" + toText InvalidBlockHash = "INVALID_BLOCK_HASH" + {-# INLINE toText #-} + + fromText "VALID" = return Valid + fromText "INVALID" = return Invalid + fromText "SYNCING" = return Syncing + fromText "ACCEPTED" = return Accepted + fromText "INVALID_BLOCK_HASH" = return InvalidBlockHash + fromText x = throwM $ TextFormatException $ "Invalid PayloadStatusStatus: " <> x + {-# INLINE fromText #-} + +-- -------------------------------------------------------------------------- -- +-- Payload Status V1 + +-- | Payload Status V1 +-- +-- This structure contains the result of processing a payload. +-- +-- cf. https://github.com/ethereum/execution-apis/blob/main/src/engine/paris.md#payloadstatusv1 +-- +data PayloadStatusV1 = PayloadStatusV1 + { _payloadStatusV1Status :: !PayloadStatusStatus + -- ^ Status of the payload + , _payloadStatusV1LatestValidHash :: !(Maybe E.BlockHash) + -- ^ DATA|null, 32 Bytes - the hash of the most recent valid block in + -- the branch defined by payload and its ancestors + , _payloadStatusV1ValidationError :: !(Maybe T.Text) + -- ^ String|null - a message providing additional details on the + -- validation error if the payload is classified as INVALID or + -- INVALID_BLOCK_HASH. + } + deriving (Eq, Show, Generic) + +payloadStatusV1Properties + :: KeyValue e kv + => PayloadStatusV1 + -> [kv] +payloadStatusV1Properties o = + [ "status" .= _payloadStatusV1Status o + , "latestValidHash" .= _payloadStatusV1LatestValidHash o + , "validationError" .= _payloadStatusV1ValidationError o + ] +{-# INLINE payloadStatusV1Properties #-} + +instance ToJSON PayloadStatusV1 where + toEncoding = pairs . mconcat . payloadStatusV1Properties + toJSON = object . payloadStatusV1Properties + {-# INLINE toEncoding #-} + {-# INLINE toJSON #-} + +instance FromJSON PayloadStatusV1 where + parseJSON = withObject "PayloadStatusV1" $ \o -> PayloadStatusV1 + <$> o .: "status" + <*> o .: "latestValidHash" + <*> o .: "validationError" + {-# INLINE parseJSON #-} + +-- -------------------------------------------------------------------------- -- +-- Withdrawal V1 + +-- | Withdrawal object V1 +-- +-- This structure maps onto the validator withdrawal object from the beacon +-- chain spec. +-- +-- Note: the amount value is represented on the beacon chain as a little-endian +-- value in units of Gwei, whereas the amount in this structure MUST be +-- converted to a big-endian value in units of Gwei. +-- +-- https://github.com/ethereum/execution-apis/blob/main/src/engine/shanghai.md#withdrawalv1 +-- +data WithdrawalV1 = WithdrawalV1 + { _withdrawalIndex :: !Word64 + -- ^ index: QUANTITY, 64 Bits + , _withdrawalValidatorIndex :: !Word64 + -- ^ validatorIndex: QUANTITY, 64 Bits + , _withdrawalAddress :: !E.Address + -- ^ address: DATA, 20 Bytes + , _withdrawalAmount :: !Word64 + -- ^ amount: QUANTITY, 64 Bits + } + deriving (Show, Eq, Generic) + +instance ToJSON WithdrawalV1 where + toEncoding o = pairs + $ "index" .= HexQuantity (_withdrawalIndex o) + <> "validatorIndex" .= HexQuantity (_withdrawalValidatorIndex o) + <> "address" .= _withdrawalAddress o + <> "amount" .= HexQuantity (_withdrawalAmount o) + {-# INLINE toEncoding #-} + + toJSON o = object + [ "index" .= HexQuantity (_withdrawalIndex o) + , "validatorIndex" .= HexQuantity (_withdrawalValidatorIndex o) + , "address" .= _withdrawalAddress o + , "amount" .= HexQuantity (_withdrawalAmount o) + ] + {-# INLINE toJSON #-} + +instance FromJSON WithdrawalV1 where + parseJSON = withObject "Withdrawal" $ \o -> WithdrawalV1 + <$> fmap fromHexQuanity (o .: "index") + <*> fmap fromHexQuanity (o .: "validatorIndex") + <*> o .: "address" + <*> fmap fromHexQuanity (o .: "amount") + {-# INLINE parseJSON #-} + +instance RLP WithdrawalV1 where + putRlp w = putRlpL + [ putRlp $ _withdrawalIndex w + , putRlp $ _withdrawalValidatorIndex w + , putRlp $ _withdrawalAddress w + , putRlp $ _withdrawalAmount w + ] + + getRlp = label "WithdrawalV1" $ getRlpL $ + WithdrawalV1 + <$> getRlp -- index + <*> getRlp -- validator index + <*> getRlp -- address + <*> getRlp -- amount + +withdrawlsRoot :: [WithdrawalV1] -> WithdrawalsRoot +withdrawlsRoot l = unsafePerformIO $ do + store <- mkHashMapStore + Trie (E.Keccak256Hash !t) <- trie (_trieStoreAdd store) + $ bimap putRlpByteString putRlpByteString <$> zip [0::Natural ..] l + return (WithdrawalsRoot t) + +-- -------------------------------------------------------------------------- -- +-- Blobs Bundle V1 + +type BYTES_PER_FIELD_ELEMENT :: Natural +type BYTES_PER_FIELD_ELEMENT = 32 + +type FIELD_ELEMENTS_PER_BLOB :: Natural +type FIELD_ELEMENTS_PER_BLOB = 4096 + +type BLOB_SIZE :: Natural +type BLOB_SIZE = FIELD_ELEMENTS_PER_BLOB GHC.TypeLits.* BYTES_PER_FIELD_ELEMENT + +versionedHashVersionKzg :: Word8 +versionedHashVersionKzg = 0x01 + +-- | EIP-4844 Versioned Hash +-- +newtype VersionedHash = VersionedHash { _versionedHash :: E.BytesN 32 } + deriving (Show, Eq, Ord) + deriving newtype (RLP, E.Bytes, Storable, Hashable) + deriving (ToJSON, FromJSON) via (HexBytes (E.BytesN 32)) + +-- | EIP-4844 KZG Commitment +-- +newtype KzgCommitment = KzgCommitment { _kzgCommitment :: E.BytesN 48 } + deriving (Show, Eq, Ord) + deriving newtype (RLP, E.Bytes, Storable, Hashable) + deriving (ToJSON, FromJSON) via (HexBytes (E.BytesN 48)) + +-- | EIP-4844 KZG Proof +-- +newtype KzgProof = KzgProof { _kzgProof :: E.BytesN 48 } + deriving (Show, Eq, Ord) + deriving newtype (RLP, E.Bytes, Storable, Hashable) + deriving (ToJSON, FromJSON) via (HexBytes (E.BytesN 48)) + +-- | EIP-4844 Blob +-- +newtype Blob = Blob { _blob :: E.BytesN BLOB_SIZE } + deriving (Show, Eq, Ord) + deriving newtype (RLP, E.Bytes, Storable, Hashable) + deriving (ToJSON, FromJSON) via (HexBytes (E.BytesN BLOB_SIZE)) + +-- | Blobs Bundle V1 +-- +-- * commitments: Array of DATA - Array of KZGCommitment as defined in EIP-4844, +-- 48 bytes each (DATA). +-- * proofs: Array of DATA - Array of KZGProof as defined in EIP-4844, 48 bytes +-- each (DATA). +-- * blobs: Array of DATA - Array of blobs, each blob is FIELD_ELEMENTS_PER_BLOB +-- * BYTES_PER_FIELD_ELEMENT = 4096 * 32 = 131072 bytes (DATA) representing a +-- SSZ-encoded Blob as defined in EIP-4844 +-- +-- All of the above three arrays MUST be of same length. +-- +-- cf. https://github.com/ethereum/execution-apis/blob/main/src/engine/cancun.md#blobsbundlev1 +-- +data BlobsBundleV1 = BlobsBundleV1 + { _blobsBundleV1Commitments :: ![KzgCommitment] + -- ^ commitments: Array of DATA - Array of KZGCommitment as defined in + -- EIP-4844, 48 bytes each (DATA). + , _blobsBundleV1Proofs :: ![KzgProof] + -- ^ proofs: Array of DATA - Array of KZGProof as defined in EIP-4844, + -- 48 bytes each (DATA). + , _blobsBundleV1Blobs :: ![Blob] + -- ^ blobs: Array of DATA - Array of blobs, each blob is + -- FIELD_ELEMENTS_PER_BLOB * BYTES_PER_FIELD_ELEMENT = 4096 * 32 = 131072 + -- bytes (DATA) representing a SSZ-encoded Blob as defined in EIP-4844 + } + deriving (Show, Eq, Generic) + +blobsBundleV1Properties + :: KeyValue e kv + => BlobsBundleV1 + -> [kv] +blobsBundleV1Properties o = + [ "commitments" .= _blobsBundleV1Commitments o + , "proofs" .= _blobsBundleV1Proofs o + , "blobs" .= _blobsBundleV1Blobs o + ] + +instance ToJSON BlobsBundleV1 where + toEncoding = pairs . mconcat . blobsBundleV1Properties + toJSON = object . blobsBundleV1Properties + {-# INLINE toEncoding #-} + {-# INLINE toJSON #-} + +instance FromJSON BlobsBundleV1 where + parseJSON = withObject "BlobsBundleV1" $ \o -> BlobsBundleV1 + <$> o .: "commitments" + <*> o .: "proofs" + <*> o .: "blobs" + {-# INLINE parseJSON #-} + +-- | Compute versioned hash for a blob +-- +-- cf. https://eips.ethereum.org/EIPS/eip-4844#helpers +-- +-- VERSIONED_HASH_VERSION_KZG + sha256(commitment)[1:] +-- +versionedHash :: KzgCommitment -> VersionedHash +versionedHash (KzgCommitment c) = VersionedHash + $ E.unsafeBytesN @32 + $ BS.singleton versionedHashVersionKzg + <> BS.drop 1 (coerce $ hashShortByteString_ @Sha2_256 $ E._getBytesN c) + +versionedHashes :: BlobsBundleV1 -> [VersionedHash] +versionedHashes (BlobsBundleV1 cs _ _) = map versionedHash cs + +-- -------------------------------------------------------------------------- -- +-- Execution Payload V1 + +newtype TransactionBytes = TransactionBytes + { _transactionBytes :: BS.ShortByteString } + deriving (Show, Eq, Ord, Generic) + deriving newtype (Hashable, E.Bytes, RLP) + +instance ToJSON TransactionBytes where + toEncoding (TransactionBytes a) = toEncoding (HexBytes a) + toJSON (TransactionBytes a) = toJSON (HexBytes a) + {-# INLINE toEncoding #-} + {-# INLINE toJSON #-} + +instance FromJSON TransactionBytes where + parseJSON v = TransactionBytes <$> do + HexBytes b <- parseJSON v + return b + {-# INLINE parseJSON #-} + +transactionsRoot :: [TransactionBytes] -> E.TransactionsRoot +transactionsRoot l = unsafePerformIO $ do + store <- mkHashMapStore + Trie !t <- trie (_trieStoreAdd store) + $ bimap putRlpByteString E.bytes <$> zip [0::Natural ..] l + return (E.TransactionsRoot t) + +-- | Execution Payload V1 +-- +-- This structure maps on the ExecutionPayload structure of the beacon chain +-- spec. +-- +-- * parentHash: DATA, 32 Bytes +-- * feeRecipient: DATA, 20 Bytes +-- * stateRoot: DATA, 32 Bytes +-- * receiptsRoot: DATA, 32 Bytes +-- * logsBloom: DATA, 256 Bytes +-- * prevRandao: DATA, 32 Bytes +-- * blockNumber: QUANTITY, 64 Bits +-- * gasLimit: QUANTITY, 64 Bits +-- * gasUsed: QUANTITY, 64 Bits +-- * timestamp: QUANTITY, 64 Bits +-- * extraData: DATA, 0 to 32 Bytes +-- * baseFeePerGas: QUANTITY, 256 Bits +-- * blockHash: DATA, 32 Bytes +-- * transactions: Array of DATA - Array of transaction objects, each object is +-- a byte list (DATA) representing TransactionType || TransactionPayload or +-- LegacyTransaction as defined in EIP-2718 +-- +-- cf. https://github.com/ethereum/execution-apis/blob/main/src/engine/paris.md#executionpayloadv1 +-- +data ExecutionPayloadV1 = ExecutionPayloadV1 + { _executionPayloadV1ParentHash :: !E.ParentHash + -- ^ parentHash: DATA, 32 Bytes + , _executionPayloadV1FeeRecipient :: !E.Beneficiary + -- ^ feeRecipient: DATA, 20 Bytes + , _executionPayloadV1StateRoot :: !E.StateRoot + -- ^ stateRoot: DATA, 32 Bytes + , _executionPayloadV1ReceiptsRoot :: !E.ReceiptsRoot + -- ^ receiptsRoot: DATA, 32 Bytes + , _executionPayloadV1LogsBloom :: !E.Bloom + -- ^ logsBloom: DATA, 256 Bytes + , _executionPayloadV1PrevRandao :: !Randao + -- ^ prevRandao: DATA, 32 Bytes + , _executionPayloadV1BlockNumber :: !E.BlockNumber + -- ^ blockNumber: QUANTITY, 64 Bits + , _executionPayloadV1GasLimit :: !E.GasLimit + -- ^ gasLimit: QUANTITY, 64 Bits + , _executionPayloadV1GasUsed :: !E.GasUsed + -- ^ gasUsed: QUANTITY, 64 Bits + -- Denoted in GWei + , _executionPayloadV1Timestamp :: !E.Timestamp + -- ^ timestamp: QUANTITY, 64 Bits + , _executionPayloadV1ExtraData :: !E.ExtraData + -- ^ extraData: DATA, 0 to 32 Bytes + , _executionPayloadV1BaseFeePerGas :: !BaseFeePerGas + -- ^ baseFeePerGas: QUANTITY, 256 Bits + , _executionPayloadV1BlockHash :: !E.BlockHash + -- ^ blockHash: DATA, 32 Bytes + , _executionPayloadV1Transactions :: ![TransactionBytes] + -- ^ transactions: Array of DATA - Array of transaction objects, each + -- object is a byte list (DATA) representing TransactionType || + -- TransactionPayload or LegacyTransaction as defined in EIP-2718 + } + deriving (Show, Eq, Generic) + +executionPayloadV1Properties + :: KeyValue e kv + => ExecutionPayloadV1 + -> [kv] +executionPayloadV1Properties o = + [ "parentHash" .= _executionPayloadV1ParentHash o + , "feeRecipient" .= _executionPayloadV1FeeRecipient o + , "stateRoot" .= _executionPayloadV1StateRoot o + , "receiptsRoot" .= _executionPayloadV1ReceiptsRoot o + , "logsBloom" .= _executionPayloadV1LogsBloom o + , "prevRandao" .= _executionPayloadV1PrevRandao o + , "blockNumber" .= _executionPayloadV1BlockNumber o + , "gasLimit" .= _executionPayloadV1GasLimit o + , "gasUsed" .= _executionPayloadV1GasUsed o + , "timestamp" .= _executionPayloadV1Timestamp o + , "extraData" .= _executionPayloadV1ExtraData o + , "baseFeePerGas" .= _executionPayloadV1BaseFeePerGas o + , "blockHash" .= _executionPayloadV1BlockHash o + , "transactions" .= _executionPayloadV1Transactions o + ] + +instance ToJSON ExecutionPayloadV1 where + toEncoding = pairs . mconcat . executionPayloadV1Properties + toJSON = object . executionPayloadV1Properties + {-# INLINE toEncoding #-} + {-# INLINE toJSON #-} + +instance FromJSON ExecutionPayloadV1 where + parseJSON = withObject "ExecutionPayloadV2" $ \o -> ExecutionPayloadV1 + <$> o .: "parentHash" + <*> o .: "feeRecipient" + <*> o .: "stateRoot" + <*> o .: "receiptsRoot" + <*> o .: "logsBloom" + <*> o .: "prevRandao" + <*> o .: "blockNumber" + <*> o .: "gasLimit" + <*> o .: "gasUsed" + <*> o .: "timestamp" + <*> o .: "extraData" + <*> o .: "baseFeePerGas" + <*> o .: "blockHash" + <*> o .: "transactions" + {-# INLINE parseJSON #-} + +-- -------------------------------------------------------------------------- -- +-- Execution Payload V2 + +-- | Execution Payload V2 +-- +-- This structure has the syntax of ExecutionPayloadV1 and appends a single +-- field: withdrawals. +-- +-- * withdrawals: Array of WithdrawalV1 - Array of withdrawals, each object is +-- an OBJECT containing the fields of a WithdrawalV1 structure. +-- +-- cf. https://github.com/ethereum/execution-apis/blob/main/src/engine/shanghai.md#executionpayloadv2 +-- +data ExecutionPayloadV2 = ExecutionPayloadV2 + { _executionPayloadV1 :: !ExecutionPayloadV1 + , _executionPayloadV2Withdrawals :: ![WithdrawalV1] + -- ^ withdrawals: Array of WithdrawalV1 - Array of withdrawals, each + -- object is an OBJECT containing the fields of a WithdrawalV1 structure. + } + deriving (Show, Eq, Generic) + +executionPayloadV2Properties + :: KeyValue e kv + => ExecutionPayloadV2 + -> [kv] +executionPayloadV2Properties o = + executionPayloadV1Properties (_executionPayloadV1 o) <> + [ "withdrawals" .= _executionPayloadV2Withdrawals o + ] +{-# INLINABLE executionPayloadV2Properties #-} + +instance ToJSON ExecutionPayloadV2 where + toEncoding = pairs . mconcat . executionPayloadV2Properties + toJSON = object . executionPayloadV2Properties + {-# INLINE toEncoding #-} + {-# INLINE toJSON #-} + +instance FromJSON ExecutionPayloadV2 where + parseJSON = withObject "ExecutionPayloadV2" $ \o -> ExecutionPayloadV2 + <$> parseJSON (Object o) + <*> o .: "withdrawals" + {-# INLINE parseJSON #-} + +-- -------------------------------------------------------------------------- -- +-- Execution Payload V3 + +-- | Execution Payload V3 +-- +-- This structure has the syntax of ExecutionPayloadV2 and appends the new +-- fields: blobGasUsed and excessBlobGas. +-- +-- * blobGasUsed: QUANTITY, 64 Bits +-- * excessBlobGas: QUANTITY, 64 Bits +-- +-- cf. https://github.com/ethereum/execution-apis/blob/main/src/engine/cancun.md#executionpayloadv3 +-- +data ExecutionPayloadV3 = ExecutionPayloadV3 + { _executionPayloadV2 :: !ExecutionPayloadV2 + , _executionPayloadV3BlobGasUsed :: !BlobGasUsed + -- ^ QUANTITY, 64 Bits + , _executionPayloadV3ExcessBlobGas :: !ExcessBlobGas + -- ^ QUANTITY, 64 Bits + } + deriving (Show, Eq, Generic) + +executionPayloadV3Properties + :: KeyValue e kv + => ExecutionPayloadV3 + -> [kv] +executionPayloadV3Properties o = + executionPayloadV2Properties (_executionPayloadV2 o) <> + [ "blobGasUsed" .= _executionPayloadV3BlobGasUsed o + , "excessBlobGas" .= _executionPayloadV3ExcessBlobGas o + ] +{-# INLINABLE executionPayloadV3Properties #-} + +instance ToJSON ExecutionPayloadV3 where + toEncoding = pairs . mconcat . executionPayloadV3Properties + toJSON = object . executionPayloadV3Properties + {-# INLINE toEncoding #-} + {-# INLINE toJSON #-} + +instance FromJSON ExecutionPayloadV3 where + parseJSON = withObject "ExecutionPayloadV3" $ \o -> ExecutionPayloadV3 + <$> parseJSON (Object o) + <*> o .: "blobGasUsed" + <*> o .: "excessBlobGas" + +-- -------------------------------------------------------------------------- -- +-- Full Execution Payload + +-- | This is the "full" execution payload that is used in the engine_newPayloadV4 +-- requests. +-- +-- Method parameter list is extended with executionRequests. +-- +-- cf. https://github.com/ethereum/execution-apis/blob/main/src/engine/prague.md#request +-- +data NewPayloadV4Request = NewPayloadV4Request + { _newPayloadV4RequestExecutionPayloadV3 :: !ExecutionPayloadV3 + , _newPayloadV4RequestExpectedBlobVersionedHashes :: ![VersionedHash] + -- ^ Array of DATA, 32 Bytes - Array of expected blob versioned hashes + -- to validate. + , _newPayloadV4RequestParentBeaconBlockRoot :: !ParentBeaconBlockRoot + -- ^ DATA, 32 Bytes - Root of the parent beacon block. + , _newPayloadV4RequestRequests :: ![ExecutionRequest] + -- ^ Array of DATA - List of execution layer triggered requests. Each + -- list element is a requests byte array as defined by EIP-7685. The + -- first byte of each element is the request_type and the remaining + -- bytes are the request_data. Elements of the list MUST be ordered by + -- request_type in ascending order. Elements with empty request_data + -- MUST be excluded from the list. If the list has no elements, the + -- expected array MUST be []. If any element is out of order, has a + -- length of 1-byte or shorter, or more than one element has the same + -- type byte, or the param is null, client software MUST return -32602: + -- Invalid params error. + } + deriving (Eq, Show, Generic) + +instance ToJSON NewPayloadV4Request where + toEncoding o = toEncoding + ( _newPayloadV4RequestExecutionPayloadV3 o + , _newPayloadV4RequestExpectedBlobVersionedHashes o + , _newPayloadV4RequestParentBeaconBlockRoot o + , _newPayloadV4RequestRequests o + ) + toJSON o = toJSON + ( _newPayloadV4RequestExecutionPayloadV3 o + , _newPayloadV4RequestExpectedBlobVersionedHashes o + , _newPayloadV4RequestParentBeaconBlockRoot o + , _newPayloadV4RequestRequests o + ) + {-# INLINE toEncoding #-} + {-# INLINE toJSON #-} + +instance FromJSON NewPayloadV4Request where + parseJSON = withArray "NewPayloadV4Request" $ \v -> do + case toList v of + [a, b, c, d] -> NewPayloadV4Request + <$> parseJSON a + <*> parseJSON b + <*> parseJSON c + <*> parseJSON d + l -> fail $ "invalid NewPayloadV4Request: expected 4 parameters but got " <> show (length l) + {-# INLINE parseJSON #-} + +-- -------------------------------------------------------------------------- -- +-- Payload Attributes V1 + +-- | Payload Attributes V1 +-- +-- This structure contains the attributes required to initiate a payload build +-- process in the context of an engine_forkchoiceUpdated call. +-- +-- cf. https://github.com/ethereum/execution-apis/blob/main/src/engine/paris.md#payloadattributesv1 +-- +data PayloadAttributesV1 = PayloadAttributesV1 + { _payloadAttributesV1Timestamp :: !E.Timestamp + -- ^ timestamp: QUANTITY, 64 Bits - value for the timestamp field of the + -- new payload + , _payloadAttributesV1PrevRandao :: !Randao + -- ^ prevRandao: DATA, 32 Bytes - value for the prevRandao field of the + -- new payload. + , _payloadAttributesV1SuggestedFeeRecipient :: !E.Address + -- ^ suggestedFeeRecipient: DATA, 20 Bytes - suggested value for the + -- feeRecipient field of the new payload + } + deriving (Show, Eq, Generic) + +payloadAttributesV1Properties + :: KeyValue e kv + => PayloadAttributesV1 + -> [kv] +payloadAttributesV1Properties o = + [ "timestamp" .= _payloadAttributesV1Timestamp o + , "prevRandao" .= _payloadAttributesV1PrevRandao o + , "suggestedFeeRecipient" .= _payloadAttributesV1SuggestedFeeRecipient o + ] + +instance ToJSON PayloadAttributesV1 where + toEncoding = pairs . mconcat . payloadAttributesV1Properties + toJSON = object . payloadAttributesV1Properties + {-# INLINE toEncoding #-} + {-# INLINE toJSON #-} + +instance FromJSON PayloadAttributesV1 where + parseJSON = withObject "PayloadAttributesV1" $ \o -> PayloadAttributesV1 + <$> o .: "timestamp" + <*> o .: "prevRandao" + <*> o .: "suggestedFeeRecipient" + {-# INLINE parseJSON #-} + +-- -------------------------------------------------------------------------- -- +-- Payload Atributes V2 + +-- | Payload Attributes V2 +-- +-- This structure has the syntax of PayloadAttributesV1 and appends a single +-- field: withdrawals +-- +-- cf. https://github.com/ethereum/execution-apis/blob/main/src/engine/shanghai.md#payloadattributesv2 +-- +data PayloadAttributesV2 = PayloadAttributesV2 + { _payloadAttributesV1 :: !PayloadAttributesV1 + , _payloadAttributesV2Withdrawals :: ![WithdrawalV1] + -- ^ withdrawals: Array of WithdrawalV1 - Array of withdrawals, each + -- object is an OBJECT containing the fields of a WithdrawalV1 + -- structure. + } + deriving (Show, Eq, Generic) + +payloadAttributesV2Properties + :: KeyValue e kv + => PayloadAttributesV2 + -> [kv] +payloadAttributesV2Properties o = + payloadAttributesV1Properties (_payloadAttributesV1 o) <> + [ "withdrawals" .= _payloadAttributesV2Withdrawals o + ] + +instance ToJSON PayloadAttributesV2 where + toEncoding = pairs . mconcat . payloadAttributesV2Properties + toJSON = object . payloadAttributesV2Properties + {-# INLINE toEncoding #-} + {-# INLINE toJSON #-} + +instance FromJSON PayloadAttributesV2 where + parseJSON = withObject "PayloadAttributesV2" $ \o -> PayloadAttributesV2 + <$> parseJSON (Object o) + <*> o .: "withdrawals" + {-# INLINE parseJSON #-} + +-- -------------------------------------------------------------------------- -- +-- Payload Attributes V3 + +-- | Payload Attributes Object V3 +-- +-- This structure has the syntax of PayloadAttributesV2 and appends a single +-- field: parentBeaconBlockRoot. +-- +-- cf. https://github.com/ethereum/execution-apis/blob/main/src/engine/cancun.md#payloadattributesv3 +-- +data PayloadAttributesV3 = PayloadAttributesV3 + { _payloadAttributesV2 :: PayloadAttributesV2 + , _payloadAttributesV3parentBeaconBlockRoot :: !ParentBeaconBlockRoot + -- ^ parentBeaconBlockRoot: DATA, 32 Bytes - Root of the parent beacon + -- block. + } + deriving (Show, Eq, Generic) + +payloadAttributeV3Properties + :: KeyValue e kv + => PayloadAttributesV3 + -> [kv] +payloadAttributeV3Properties o = + payloadAttributesV2Properties (_payloadAttributesV2 o) <> + [ "parentBeaconBlockRoot" .= _payloadAttributesV3parentBeaconBlockRoot o + ] + +instance ToJSON PayloadAttributesV3 where + toEncoding = pairs . mconcat . payloadAttributeV3Properties + toJSON = object . payloadAttributeV3Properties + {-# INLINE toEncoding #-} + {-# INLINE toJSON #-} + +instance FromJSON PayloadAttributesV3 where + parseJSON = withObject "PayloadAttributesV3" $ \o -> PayloadAttributesV3 + <$> parseJSON (Object o) + <*> o .: "parentBeaconBlockRoot" + {-# INLINE parseJSON #-} + +-- -------------------------------------------------------------------------- -- +-- Payload Id + +-- | Payload Id +-- +-- payloadId: DATA|null, 8 Bytes - identifier of the payload build process or +-- null +-- +-- cf. https://github.com/ethereum/execution-apis/blob/main/src/engine/shanghai.md#request-2 +-- +newtype PayloadId = PayloadId { _payloadId :: E.BytesN 8 } + deriving (Show, Eq, Ord, Generic) + deriving (ToJSON, FromJSON) via JsonTextRepresentation "PayloadId" PayloadId + deriving (HasTextRepresentation) via HexBytes (E.BytesN 8) + +-- -------------------------------------------------------------------------- -- +-- Errors + +-- | Engine Errors +-- +-- * -32700 | Parse error | Invalid JSON was received by the server. +-- * -32600 | Invalid Request | The JSON sent is not a valid Request object. +-- * -32601 | Method not found | The method does not exist / is not available. +-- * -32602 | Invalid params | Invalid method parameter(s). +-- * -32603 | Internal error | Internal JSON-RPC error. +-- * -32000 | Server error | Generic client error while processing request. +-- * -38001 | Unknown payload | Payload does not exist / is not available. +-- * -38002 | Invalid forkchoice state | Forkchoice state is invalid / inconsistent. +-- * -38003 | Invalid payload attributes | Payload attributes are invalid / inconsistent. +-- * -38004 | Too large request | Number of requested entities is too large. +-- * -38005 | Unsupported fork | Payload belongs to a fork that is not supported. +-- +-- Each error returns a null data value, except -32000 which returns the data +-- object with a err member that explains the error encountered. +-- +-- cf. https://github.com/ethereum/execution-apis/blob/main/src/engine/common.md#errors +-- +data EngineErrors + = UnknownPayload + | InvalidForkChoiceState + | InvalidPayloadAttributes + | TooLargeRequest + | UnsupportedFork + deriving (Show, Eq, Generic, Enum, Bounded) + +instance HasErrorCode EngineErrors where + toErrorCode UnknownPayload = -38001 + toErrorCode InvalidForkChoiceState = -38002 + toErrorCode InvalidPayloadAttributes = -38003 + toErrorCode TooLargeRequest = -38004 + toErrorCode UnsupportedFork = -38005 + + fromErrorCode (-38001) = pure UnknownPayload + fromErrorCode (-38002) = pure InvalidForkChoiceState + fromErrorCode (-38003) = pure InvalidPayloadAttributes + fromErrorCode (-38004) = pure TooLargeRequest + fromErrorCode (-38005) = pure UnsupportedFork + fromErrorCode n = throwM $ UnknownErrorCodeException n + +data EngineServerErrors + = EngineServerError + deriving (Show, Eq, Generic, Enum, Bounded) + +instance HasErrorCode EngineServerErrors where + toErrorCode EngineServerError = -32000 + fromErrorCode (-32000) = pure EngineServerError + fromErrorCode n = throwM $ UnknownErrorCodeException n + +-- -------------------------------------------------------------------------- -- +-- Forkchoice Update V2 (Shanghai) + +-- | Engine Forkchoice Updated V2 +-- +-- timeout: 8s +-- +-- cf. https://github.com/ethereum/execution-apis/blob/main/src/engine/shanghai.md#engine_forkchoiceupdatedv2 +-- +instance JsonRpcMethod "engine_forkchoiceUpdatedV2" where + type MethodRequest "engine_forkchoiceUpdatedV2" = ForkchoiceUpdatedV2Request + type MethodResponse "engine_forkchoiceUpdatedV2" = ForkchoiceUpdatedV1Response + type ServerErrors "engine_forkchoiceUpdatedV2" = EngineServerErrors + type ApplicationErrors "engine_forkchoiceUpdatedV2" = EngineErrors + responseTimeoutMs = Just 8000 + methodErrors = + [ ApplicationError InvalidForkChoiceState + , ApplicationError InvalidPayloadAttributes + ] + +-- | Engine ForkchoiceUpdatedV2 Request +-- +-- timeout: 8s +-- +-- cf. https://github.com/ethereum/execution-apis/blob/main/src/engine/shanghai.md#request-1 +-- +data ForkchoiceUpdatedV2Request = ForkchoiceUpdatedV2Request + { _forkchoiceUpdatedV2RequestState :: !ForkchoiceStateV1 + -- ^ forkchoiceState: Object - instance of ForkchoiceStateV1 + , _forkchoiceUpdatedV2RequestPayloadAttributes :: !(Maybe PayloadAttributesV2) + -- ^ payloadAttributes: Object|null - PayloadAttributesV2 or null. + -- + -- Client software MUST return -32602: Invalid params error if the wrong + -- version of the structure is used in the method call. + } + deriving (Show, Eq, Generic) + +instance ToJSON ForkchoiceUpdatedV2Request where + toEncoding o = toEncoding + ( _forkchoiceUpdatedV2RequestState o + , _forkchoiceUpdatedV2RequestPayloadAttributes o + ) + toJSON o = toJSON + ( _forkchoiceUpdatedV2RequestState o + , _forkchoiceUpdatedV2RequestPayloadAttributes o + ) + {-# INLINE toEncoding #-} + {-# INLINE toJSON #-} + +instance FromJSON ForkchoiceUpdatedV2Request where + parseJSON = withArray "ForkchoiceUpdatedV2Request" $ \v -> do + case toList v of + [a, b] -> ForkchoiceUpdatedV2Request <$> parseJSON a <*> parseJSON b + l -> fail $ "invalid ForkchoiceUpdatedV2Request: expected 2 parameters but got " <> show (length l) + {-# INLINE parseJSON #-} + + +-- | Engine ForkchoiceUpdatedV1 response +-- +-- cf. https://github.com/ethereum/execution-apis/blob/main/src/engine/paris.md#response-1 +-- +-- error: code and message set in case an exception happens while the validating +-- payload, updating the forkchoice or initiating the payload build process. +-- +data ForkchoiceUpdatedV1Response = ForkchoiceUpdateV1Response + { _forkchoiceUpdatedV1ResponsePayloadStatus :: !PayloadStatusV1 + -- ^ payloadStatus: PayloadStatusV1; values of the status field in the + -- context of this method are restricted to the following subset: + -- "VALID" "INVALID" "SYNCING" + , _forkchoiceUpdatedV1ResponsePayloadId :: !(Maybe PayloadId) + -- ^ payloadId: DATA|null, 8 Bytes - identifier of the payload build + -- process or null + } + deriving (Show, Eq, Generic) + +instance ToJSON ForkchoiceUpdatedV1Response where + toEncoding o = pairs + $ "payloadStatus" .= _forkchoiceUpdatedV1ResponsePayloadStatus o + <> "payloadId" .= _forkchoiceUpdatedV1ResponsePayloadId o + {-# INLINE toEncoding #-} + + toJSON o = object + [ "payloadStatus" .= _forkchoiceUpdatedV1ResponsePayloadStatus o + , "payloadId" .= _forkchoiceUpdatedV1ResponsePayloadId o + ] + {-# INLINE toJSON #-} + +instance FromJSON ForkchoiceUpdatedV1Response where + parseJSON = withObject "ForkchoiceUpdatedV1Response" $ \o -> ForkchoiceUpdateV1Response + <$> o .: "payloadStatus" + <*> o .: "payloadId" + {-# INLINE parseJSON #-} + +-- -------------------------------------------------------------------------- -- +-- Forkchoice Update V3 (Cancun) + +type Engine_ForkchoiceUpdatedV3 = "engine_forkchoiceUpdatedV3" + +-- | Engine Forkchoice Updated V3 +-- +-- cf. https://github.com/ethereum/execution-apis/blob/main/src/engine/cancun.md#engine_forkchoiceupdatedv3 +-- +-- Client software MUST verify that forkchoiceState matches the +-- ForkchoiceStateV1 structure and return -32602: Invalid params on failure. +-- +instance JsonRpcMethod "engine_forkchoiceUpdatedV3" where + type MethodRequest "engine_forkchoiceUpdatedV3" = ForkchoiceUpdatedV3Request + type MethodResponse "engine_forkchoiceUpdatedV3" = ForkchoiceUpdatedV1Response + type ServerErrors "engine_forkchoiceUpdatedV3" = EngineServerErrors + type ApplicationErrors "engine_forkchoiceUpdatedV3" = EngineErrors + responseTimeoutMs = Just 8000 + methodErrors = + [ InvalidParams + , ApplicationError InvalidForkChoiceState + , ApplicationError InvalidPayloadAttributes + , ApplicationError UnsupportedFork + ] + +-- | Engine ForkchoiceUpdatedV3 Request +-- +-- timeout: 8s +-- +-- cf. https://github.com/ethereum/execution-apis/blob/main/src/engine/cancun.md#request-1 +-- +data ForkchoiceUpdatedV3Request = ForkchoiceUpdatedV3Request + { _forkchoiceUpdatedV3RequestState :: !ForkchoiceStateV1 + -- ^ forkchoiceState: ForkchoiceStateV1. + , _forkchoiceUpdatedV3RequestPayloadAttributes :: !(Maybe PayloadAttributesV3) + -- ^ payloadAttributes: Object|null - Instance of PayloadAttributesV3 or null. + } + deriving (Show, Eq, Generic) + +instance ToJSON ForkchoiceUpdatedV3Request where + toEncoding o = toEncoding + ( _forkchoiceUpdatedV3RequestState o + , _forkchoiceUpdatedV3RequestPayloadAttributes o + ) + toJSON o = toJSON + ( _forkchoiceUpdatedV3RequestState o + , _forkchoiceUpdatedV3RequestPayloadAttributes o + ) + +instance FromJSON ForkchoiceUpdatedV3Request where + parseJSON = withArray "ForkchoiceUpdatedV3Request" $ \v -> do + case toList v of + [a, b] -> ForkchoiceUpdatedV3Request <$> parseJSON a <*> parseJSON b + l -> fail $ "invalid ForkchoiceUpdatedV2Request: expected 2 parameters but got " <> show (length l) + +-- -------------------------------------------------------------------------- -- +-- Engine Get Payload V2 (Shanghai) + +type Engine_GetPayloadV2 = "engine_getPayloadV2" + +-- | Engine Get Payload V2 +-- +-- timeout: 1s +-- +-- error: code and message set in case an exception happens while getting the +-- payload. +-- +-- cf. https://github.com/ethereum/execution-apis/blob/main/src/engine/shanghai.md#engine_getpayloadv2 +-- +instance JsonRpcMethod "engine_getPayloadV2" where + type MethodRequest "engine_getPayloadV2" = PayloadId + type MethodResponse "engine_getPayloadV2" = GetPayloadV2Response + type ServerErrors "engine_getPayloadV2" = EngineServerErrors + type ApplicationErrors "engine_getPayloadV2" = EngineErrors + responseTimeoutMs = Just 1000 + methodErrors = + [ ApplicationError UnknownPayload + ] + +-- | Engine Get Payload V2 Response +-- +-- error: code and message set in case an exception happens while getting the +-- payload. +-- +-- cf. https://github.com/ethereum/execution-apis/blob/main/src/engine/shanghai.md#response-2 +-- +data GetPayloadV2Response = GetPayloadV2Response + { _getPayloadV2ResponseExecutionPayload :: !ExecutionPayloadV2 + -- ^ executionPayload: ExecutionPayloadV2 + , _getPayloadV2ResponseBlockValue :: !BlockValue + -- ^ blockValue : QUANTITY, 256 Bits - The expected value to be received + -- by the feeRecipient in wei + } + deriving (Show, Eq, Generic) + +getPayloadV2ResponseProperties + :: KeyValue e kv + => GetPayloadV2Response + -> [kv] +getPayloadV2ResponseProperties o = + [ "executionPayload" .= _getPayloadV2ResponseExecutionPayload o + , "blockValue" .= _getPayloadV2ResponseBlockValue o + ] + +instance ToJSON GetPayloadV2Response where + toEncoding = pairs . mconcat . getPayloadV2ResponseProperties + toJSON = object . getPayloadV2ResponseProperties + {-# INLINE toEncoding #-} + {-# INLINE toJSON #-} + +instance FromJSON GetPayloadV2Response where + parseJSON = withObject "GetPayloadV2Response" $ \o -> GetPayloadV2Response + <$> o .: "executionPayload" + <*> o .: "blockValue" + {-# INLINE parseJSON #-} + +-- -------------------------------------------------------------------------- -- +-- Engine Get Payload V3 (Cancun) + +type Engine_GetPayloadV3 = "engine_getPayloadV3" + +-- | Engine Get Payload V3 +-- +-- The response of this method is extended with BlobsBundleV1 containing the +-- blobs, their respective KZG commitments and proofs corresponding to the +-- versioned_hashes included in the blob transactions of the execution payload. +-- +-- cf. https://github.com/ethereum/execution-apis/blob/main/src/engine/cancun.md#engine_getpayloadv3 +-- +instance JsonRpcMethod "engine_getPayloadV3" where + type MethodRequest "engine_getPayloadV3" = [PayloadId] + type MethodResponse "engine_getPayloadV3" = GetPayloadV3Response + type ServerErrors "engine_getPayloadV3" = EngineServerErrors + type ApplicationErrors "engine_getPayloadV3" = EngineErrors + responseTimeoutMs = Just 1000 + methodErrors = + [ ApplicationError UnknownPayload + , ApplicationError UnsupportedFork + ] + +-- | Engine Get Payload V3 Response +-- +-- error: code and message set in case an exception happens while getting the +-- payload. +-- +-- * blobsBundle: BlobsBundleV1 - Bundle with data corresponding to blob +-- transactions included into executionPayload +-- * shouldOverrideBuilder : BOOLEAN - Suggestion from the execution layer to +-- use this executionPayload instead of an externally provided one +-- +-- cf. https://github.com/ethereum/execution-apis/blob/main/src/engine/shanghai.md#response-2 +-- +data GetPayloadV3Response = GetPayloadV3Response + { _getPayloadV3ResponseExecutionPayload :: !ExecutionPayloadV3 + -- ^ executionPayload: ExecutionPayloadV2 + , _getPayloadV3ResponseBlockValue :: !BlockValue + -- ^ blockValue : QUANTITY, 256 Bits - The expected value to be received + -- by the feeRecipient in wei + , _getPayloadV3ResponseBlobsBundle :: !BlobsBundleV1 + -- ^ blobsBundle: BlobsBundleV1 - Bundle with data corresponding to blob + -- transactions included into executionPayload + , _getPayloadV3ResponseShouldOverrideBuilder :: !Bool + -- ^ shouldOverrideBuilder : BOOLEAN - Suggestion from the execution layer to + -- use this executionPayload instead of an externally provided one + } + deriving (Show, Eq, Generic) + +getPayloadV3ResponseProperties + :: KeyValue e kv + => GetPayloadV3Response + -> [kv] +getPayloadV3ResponseProperties o = + [ "executionPayload" .= _getPayloadV3ResponseExecutionPayload o + , "blockValue" .= _getPayloadV3ResponseBlockValue o + , "blobsBundle" .= _getPayloadV3ResponseBlobsBundle o + , "shouldOverrideBuilder" .= _getPayloadV3ResponseShouldOverrideBuilder o + ] + +instance ToJSON GetPayloadV3Response where + toEncoding = pairs . mconcat . getPayloadV3ResponseProperties + toJSON = object . getPayloadV3ResponseProperties + {-# INLINE toEncoding #-} + {-# INLINE toJSON #-} + +instance FromJSON GetPayloadV3Response where + parseJSON = withObject "GetPayloadV3Response" $ \o -> GetPayloadV3Response + <$> o .: "executionPayload" + <*> o .: "blockValue" + <*> o .: "blobsBundle" + <*> o .: "shouldOverrideBuilder" + {-# INLINE parseJSON #-} + +-- -------------------------------------------------------------------------- -- +-- Engine Get Payload V4 (Prague / Pectra) + +type Engine_GetPayloadV4 = "engine_getPayloadV4" + +-- | Engine Get Payload V4 +-- +-- The response of this method is extended with the executionRequests field. +-- +-- cf. https://github.com/ethereum/execution-apis/blob/main/src/engine/prague.md#engine_getpayloadv4 +-- +instance JsonRpcMethod "engine_getPayloadV4" where + type MethodRequest "engine_getPayloadV4" = [PayloadId] + type MethodResponse "engine_getPayloadV4" = GetPayloadV4Response + type ServerErrors "engine_getPayloadV4" = EngineServerErrors + type ApplicationErrors "engine_getPayloadV4" = EngineErrors + responseTimeoutMs = Just 1000 + methodErrors = + [ ApplicationError UnknownPayload + , ApplicationError UnsupportedFork + ] + +-- | Engine Get Payload V4 Response +-- +-- New fields: +-- +-- * executionRequests +-- +-- cf. https://github.com/ethereum/execution-apis/blob/main/src/engine/prague.md#response-1 +-- +data GetPayloadV4Response = GetPayloadV4Response + { _getPayloadV4ResponseExecutionPayload :: !ExecutionPayloadV3 + -- ^ executionPayload: ExecutionPayloadV2 + , _getPayloadV4ResponseBlockValue :: !BlockValue + -- ^ blockValue : QUANTITY, 256 Bits - The expected value to be received + -- by the feeRecipient in wei + , _getPayloadV4ResponseBlobsBundle :: !BlobsBundleV1 + -- ^ blobsBundle: BlobsBundleV1 - Bundle with data corresponding to blob + -- transactions included into executionPayload + , _getPayloadV4ResponseShouldOverrideBuilder :: !Bool + -- ^ shouldOverrideBuilder : BOOLEAN - Suggestion from the execution layer + -- to use this executionPayload instead of an externally provided one + , _getPayloadV4ResponseExecutionRequests :: ![ExecutionRequest] + -- ^ executionRequests: Array of DATA - Execution layer triggered requests + -- obtained from the executionPayload transaction execution. + } + deriving (Show, Eq, Generic) + +getPayloadV4ResponseProperties + :: KeyValue e kv + => GetPayloadV4Response + -> [kv] +getPayloadV4ResponseProperties o = + [ "executionPayload" .= _getPayloadV4ResponseExecutionPayload o + , "blockValue" .= _getPayloadV4ResponseBlockValue o + , "blobsBundle" .= _getPayloadV4ResponseBlobsBundle o + , "shouldOverrideBuilder" .= _getPayloadV4ResponseShouldOverrideBuilder o + , "executionRequests" .= _getPayloadV4ResponseExecutionRequests o + ] + +instance ToJSON GetPayloadV4Response where + toEncoding = pairs . mconcat . getPayloadV4ResponseProperties + toJSON = object . getPayloadV4ResponseProperties + {-# INLINE toEncoding #-} + {-# INLINE toJSON #-} + +instance FromJSON GetPayloadV4Response where + parseJSON = withObject "GetPayloadV4Response" $ \o -> GetPayloadV4Response + <$> o .: "executionPayload" + <*> o .: "blockValue" + <*> o .: "blobsBundle" + <*> o .: "shouldOverrideBuilder" + <*> o .: "executionRequests" + {-# INLINE parseJSON #-} + +-- -------------------------------------------------------------------------- -- +-- Engine New Payload V1 (Paris) + +-- | Engine New Payload V1 +-- +-- The purpose of this method to inform the execution layer about a new payload +-- without demanding validation in case that it is not extending the current +-- head of the canonical chain. In any case, as long as the hash is valid and +-- ancestors are present, the payload is accepted and cached for possible future +-- validation. +-- +-- timeout: 8s + +-- -------------------------------------------------------------------------- -- +-- Engine New Payload V4 (Prague / Pectra) + +type Engine_NewPayloadV4 = "engine_newPayloadV4" + +-- | Engine New Payload V4 Response +-- +-- cf. https://github.com/ethereum/execution-apis/blob/main/src/engine/prague.md#response +-- +-- This is the same type as PayloadStatusV1, with: +-- +-- result: PayloadStatusV1, values of the status field are restricted in the +-- following way: INVALID_BLOCK_HASH status value is supplanted by INVALID. +-- +-- error: code and message set in case an exception happens while processing the +-- payload. +-- +instance JsonRpcMethod "engine_newPayloadV4" where + type MethodRequest "engine_newPayloadV4" = NewPayloadV4Request + type MethodResponse "engine_newPayloadV4" = PayloadStatusV1 + type ServerErrors "engine_newPayloadV4" = EngineServerErrors + type ApplicationErrors "engine_newPayloadV4" = EngineErrors + responseTimeoutMs = Just 8000 + methodErrors = + [ InvalidParams + , ApplicationError UnsupportedFork + ] + +-- -------------------------------------------------------------------------- -- +-- Authentication + +-- | JSON Web Token (JWT) HMAC+SHA256 (HS256) Secret +-- +-- cf. https://github.com/ethereum/execution-apis/blob/main/src/engine/authentication.md#jwt-specifications +-- +newtype JwtSecret = JwtSecret { _jwtSecret :: E.BytesN 32 } + deriving (Show, Eq, Ord, Generic) + deriving (ToJSON, FromJSON) via (JsonTextRepresentation "JwtSecret" JwtSecret) + +instance HasTextRepresentation JwtSecret where + toText = T.drop 2 . toText . HexBytes . _jwtSecret + fromText = fmap (JwtSecret . fromHexBytes) . fromText . ("0x" <>) + +-- | JSON Web Token (JWT) used by the Ethereum Engine API +-- +-- The only mandatory claim is the "iat" claim. +-- +-- cf. https://github.com/ethereum/execution-apis/blob/main/src/engine/authentication.md#jwt-claims +-- +getJwtToken :: JwtSecret -> IO T.Text +getJwtToken secret = jwtToken secret <$> getPOSIXTime + +jwtToken :: JwtSecret -> POSIXTime -> T.Text +jwtToken (JwtSecret secret) t = + T.intercalate "." [header, claim, signature] + where + header = b64 "{\"alg\":\"HS256\",\"typ\":\"JWT\"}" + claim = b64 $ "{\"iat\":" <> sshow (round @_ @Natural t) <> "}" + signature = b64 + $ BA.convert + $ hmac @_ @_ @SHA256 (E.bytes secret) + $ T.encodeUtf8 + $ T.intercalate "." [header, claim] + b64 = encodeB64UrlNoPaddingText + +-- | Default Engine Context +-- +mkSimpleEngineCtx :: JwtSecret -> IO JsonRpcHttpCtx +mkSimpleEngineCtx secret = do + mgr <- HTTP.newManager HTTP.defaultManagerSettings + return $ JsonRpcHttpCtx + { _jsonRpcHttpCtxManager = mgr + , _jsonRpcHttpCtxURI = [uri|http://localhost:8551|] + , _jsonRpcHttpCtxMakeBearerToken = Just (getJwtToken secret) + } + +-- | Create a new Engine Context +-- +-- This initializes a new connection manager for this context. Hence, there +-- should only ever be a single context used with a given URI. +-- +mkEngineCtx :: JwtSecret -> URI -> IO JsonRpcHttpCtx +mkEngineCtx secret u = do + mgr <- HTTP.newManager HTTP.defaultManagerSettings + return $ JsonRpcHttpCtx + { _jsonRpcHttpCtxManager = mgr + , _jsonRpcHttpCtxURI = u + , _jsonRpcHttpCtxMakeBearerToken = Just (getJwtToken secret) + } + +-- -------------------------------------------------------------------------- -- +-- Example +-- +-- >>> Just s = fromText @JwtSecret "10b45e8907ab12dd750f688733e73cf433afadfd2f270e5b75a6b8fff22dd352" +-- >>> ctx <- mkSimpleEngineCtx s +-- >>> Just hdr <- callMethodHttp @"eth_getBlockByNumber" ctx (DefaultBlockLatest, False) +-- >>> let b = blockHash hdr +-- >>> callMethodHttp @"engine_forkchoiceUpdatedV3" ctx $ ForkchoiceUpdatedV3Request (ForkchoiceStateV1 b b b) Nothing +-- diff --git a/src/Chainweb/PayloadProvider/EVM/EthRpcAPI.hs b/src/Chainweb/PayloadProvider/EVM/EthRpcAPI.hs new file mode 100644 index 0000000000..a1f28c6340 --- /dev/null +++ b/src/Chainweb/PayloadProvider/EVM/EthRpcAPI.hs @@ -0,0 +1,216 @@ +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} + +{-# OPTIONS_GHC -Wno-orphans #-} + +-- | +-- Module: Chainweb.PayloadProvider.EVM.EthRpcAPI +-- Copyright: Copyright © 2024 Kadena LLC. +-- License: MIT +-- Maintainer: Lars Kuhtz +-- Stability: experimental +-- +module Chainweb.PayloadProvider.EVM.EthRpcAPI +( mkRpcCtx +, SyncingStatus(..) + +-- * RPC Methods +, type Eth_ChainId +, type Eth_BlockNumber +, type Eth_GetBlockByNumber +, type Eth_GetBlockByHash +, type Eth_Syncing +, type Eth_Call +, type Eth_GetBlockReceipts +, type Eth_GetLogs +) where + +import Chainweb.PayloadProvider.EVM.Header +import Chainweb.PayloadProvider.EVM.JsonRPC +import Chainweb.PayloadProvider.EVM.Utils + +import Control.Applicative + +import Data.Aeson +import Data.ByteString qualified as B +import Data.Void + +import Ethereum.Misc +import Ethereum.Transaction (Transaction) +import Ethereum.Utils + +import GHC.Generics + +import Network.HTTP.Client qualified as HTTP +import Network.URI.Static (uri) +import Ethereum.Receipt +import Data.Tuple + +-- -------------------------------------------------------------------------- -- +-- Errors + +-- * -39001: Unknown block + +-- -------------------------------------------------------------------------- -- + +-- | Eth Block Number +-- +instance JsonRpcMethod "eth_blockNumber" where + type MethodRequest "eth_blockNumber" = Maybe Void + type MethodResponse "eth_blockNumber" = BlockNumber + type ServerErrors "eth_blockNumber" = Int + type ApplicationErrors "eth_blockNumber" = Int + responseTimeoutMs = Nothing + methodErrors = [] + +type Eth_BlockNumber = "eth_blockNumber" + +instance JsonRpcMethod "eth_chainId" where + type MethodRequest "eth_chainId" = Maybe Void + type MethodResponse "eth_chainId" = ChainId + type ServerErrors "eth_chainId" = Int + type ApplicationErrors "eth_chainId" = Int + responseTimeoutMs = Nothing + methodErrors = [] + +type Eth_ChainId = "eth_chainId" + +-- | Get ETH block header by its block number +-- +-- The second ('Bool') parameter indicates whether the full payload of the block +-- is returned or just its header. +-- +instance JsonRpcMethod "eth_getBlockByNumber" where + type MethodRequest "eth_getBlockByNumber" = (DefaultBlockParameter, Bool) + type MethodResponse "eth_getBlockByNumber" = Maybe Header + type ServerErrors "eth_getBlockByNumber" = Int + type ApplicationErrors "eth_getBlockByNumber" = Int + responseTimeoutMs = Nothing + methodErrors = [] + +type Eth_GetBlockByNumber = "eth_getBlockByNumber" + +instance JsonRpcMethod "eth_getBlockByHash" where + type MethodRequest "eth_getBlockByHash" = (BlockHash, Bool) + type MethodResponse "eth_getBlockByHash" = Maybe Header + type ServerErrors "eth_getBlockByHash" = Int + type ApplicationErrors "eth_getBlockByHash" = Int + responseTimeoutMs = Nothing + methodErrors = [] + +type Eth_GetBlockByHash = "eth_getBlockByHash" + +-- -------------------------------------------------------------------------- -- +-- | Returns the current sync status or false + +-- | Returns an object with data about the sync status or false +-- +instance JsonRpcMethod "eth_syncing" where + type MethodRequest "eth_syncing" = Maybe Void + type MethodResponse "eth_syncing" = SyncingStatus + type ServerErrors "eth_syncing" = Int + type ApplicationErrors "eth_syncing" = Int + responseTimeoutMs = Nothing + methodErrors = [] + +type Eth_Syncing = "eth_syncing" + +data SyncingStatus + = SyncingStatus + { _syncingStatusStartingBlock :: BlockNumber + , _syncingStatusCurrentBlock :: BlockNumber + , _syncingStatusHighestBlock :: BlockNumber + } + | SyncingStatusFalse + deriving (Show, Eq, Ord, Generic) + +instance ToJSON SyncingStatus where + toEncoding SyncingStatusFalse = toEncoding False + toEncoding o = pairs + ( "startingBlock" .= _syncingStatusStartingBlock o + <> "currentBlock" .= _syncingStatusCurrentBlock o + <> "highestBlock" .= _syncingStatusHighestBlock o + ) + toJSON SyncingStatusFalse = toJSON False + toJSON o = object + [ "startingBlock" .= _syncingStatusStartingBlock o + , "currentBlock" .= _syncingStatusCurrentBlock o + , "highestBlock" .= _syncingStatusHighestBlock o + ] + {-# INLINE toEncoding #-} + {-# INLINE toJSON #-} + +instance FromJSON SyncingStatus where + parseJSON v = notSyncing v <|> syncStatus v + where + notSyncing = withBool "SyncingStatus" $ \b -> if not b + then return SyncingStatusFalse + else fail "expected 'false' or object" + syncStatus = withObject "SyncingStatus" $ \o -> SyncingStatus + <$> o .: "startingBlock" + <*> o .: "currentBlock" + <*> o .: "highestBlock" + {-# INLINE parseJSON #-} + +-- -------------------------------------------------------------------------- -- + +instance JsonRpcMethod "eth_call" where + type MethodRequest "eth_call" = (Transaction, DefaultBlockParameter) + type MethodResponse "eth_call" = HexBytes B.ByteString + type ServerErrors "eth_call" = Int + type ApplicationErrors "eth_call" = Int + responseTimeoutMs = Nothing + methodErrors = [] + +type Eth_Call = "eth_call" + +-- -------------------------------------------------------------------------- -- + +instance JsonRpcMethod "eth_getBlockReceipts" where + type MethodRequest "eth_getBlockReceipts" = Solo DefaultBlockParameter + type MethodResponse "eth_getBlockReceipts" = [RpcReceipt] + type ServerErrors "eth_getBlockReceipts" = Int + type ApplicationErrors "eth_getBlockReceipts" = Int + responseTimeoutMs = Nothing + methodErrors = [] + +type Eth_GetBlockReceipts = "eth_getBlockReceipts" + +-- -------------------------------------------------------------------------- -- +-- eth_getLogs + +instance JsonRpcMethod "eth_getLogs" where + type MethodRequest "eth_getLogs" = [Value] -- FIXME FIXME FIXME + type MethodResponse "eth_getLogs" = [RpcLogEntry] + type ServerErrors "eth_getLogs" = Int + type ApplicationErrors "eth_getLogs" = Int + responseTimeoutMs = Nothing + methodErrors = [] + +type Eth_GetLogs = "eth_getLogs" + + +-- -------------------------------------------------------------------------- -- +-- | Default Engine Context +-- + +mkRpcCtx :: IO JsonRpcHttpCtx +mkRpcCtx = do + mgr <- HTTP.newManager HTTP.defaultManagerSettings + return $ JsonRpcHttpCtx + { _jsonRpcHttpCtxManager = mgr + , _jsonRpcHttpCtxURI = [uri|http://localhost:8545|] + , _jsonRpcHttpCtxMakeBearerToken = Nothing + } + +-- -------------------------------------------------------------------------- -- +-- Example + +-- ghci> rpcCtx <- mkRpcCtx +-- ghci> Just hdr <- callMethodHttp @"eth_getBlockByNumber" rpcCtx (DefaultBlockLatest, False) +-- diff --git a/src/Chainweb/PayloadProvider/EVM/ExecutionPayload.hs b/src/Chainweb/PayloadProvider/EVM/ExecutionPayload.hs new file mode 100644 index 0000000000..24fdc651db --- /dev/null +++ b/src/Chainweb/PayloadProvider/EVM/ExecutionPayload.hs @@ -0,0 +1,591 @@ +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE LambdaCase #-} + +-- | +-- Module: Chainweb.PayloadProvider.EVM.ExecutionPayload +-- Copyright: Copyright © 2025 Kadena LLC. +-- License: MIT +-- Maintainer: Lars Kuhtz +-- Stability: experimental +-- +module Chainweb.PayloadProvider.EVM.ExecutionPayload +( ExecutionPayloadData(..) +, executionPayloadDataTransactions +, executionPayloadDataWithdrawals +, executionPayloadDataExpectedBlobVersionedHashes +, executionPayloadDataRequests +, Payload(..) +, payloadHeader +, payloadData +, payloadToNewPayloadV4Request +, getPayloadV4ResponseToPayload +, executionPayloadV3ToHeader + +-- * Getters +, _pldParentHash +, pldParentHash +, _pldOmmersHash +, pldOmmersHash +, _pldBeneficiary +, pldBeneficiary +, _pldStateRoot +, pldStateRoot +, _pldTransactionsRoot +, pldTransactionsRoot +, _pldReceiptsRoot +, pldReceiptsRoot +, _pldLogsBloom +, pldLogsBloom +, _pldDifficulty +, pldDifficulty +, _pldNumber +, pldNumber +, _pldHeight +, pldHeight +, _pldGasLimit +, pldGasLimit +, _pldGasUsed +, pldGasUsed +, _pldTimestamp +, pldTimestamp +, _pldExtraData +, pldExtraData +, _pldPrevRandao +, pldPrevRandao +, _pldNonce +, pldNonce +, _pldBaseFeePerGas +, pldBaseFeePerGas +, _pldWithdrawalsRoot +, pldWithdrawalsRoot +, _pldBlobGasUsed +, pldBlobGasUsed +, _pldExcessBlobGas +, pldExcessBlobGas +, _pldParentBeaconBlockRoot +, pldParentBeaconBlockRoot +, _pldRequestsHash +, pldRequestsHash +, _pldHash +, pldHash +, _pldPayloadHash +, pldPayloadHash +, _pldTransactions +, pldTransactions +, _pldWithdrawals +, pldWithdrawals +, _pldExpectedBlobVersionedHashes +, pldExpectedBlobVersionedHashes +, _pldRequests +, pldRequests +, _pldRankedBlockPayloadHash +, pldRankedBlockPayloadHash +) where + +import Chainweb.PayloadProvider.EVM.EngineAPI +import Chainweb.BlockHeight as Chainweb +import Chainweb.BlockPayloadHash +import Chainweb.PayloadProvider.EVM.Header qualified as EVM +import Chainweb.PayloadProvider.EVM.Utils qualified as EVM +import Chainweb.PayloadProvider.EVM.Utils qualified as Utils +import Control.Lens hiding ((.=)) +import Data.Aeson +import Data.Function (on) +import Data.Hashable +import Data.Word +import Ethereum.Misc +import Ethereum.RLP +import GHC.Generics (Generic) +import Chainweb.Utils (int) + +-- -------------------------------------------------------------------------- -- +-- | Execution Payload Data +-- +-- This data structure contains the execution payload data as it is not already +-- included in the EVM Header. Together with the EVM Header this provides all +-- information needed to make a new payload request to the EVM Engine API. +-- +-- The executiojn payload equals the execution payload header except for the +-- transactions and withdrawals fields, for which the header only contains the +-- respective Merkle roots. Internally we store +-- +-- Deneb Execution Payload: +-- +-- cf. https://github.com/ethereum/consensus-specs/blob/dev/specs/deneb/beacon-chain.md#executionpayload +-- +-- We also include the fields of the newPayloadV4 engine API call from the +-- Pectra (Prague/Electra) fork. +-- +-- cf. https://github.com/ethereum/consensus-specs/blob/dev/specs/electra/beacon-chain.md#modified-newpayloadrequest +-- +data ExecutionPayloadData = ExecutionPayloadData + { _executionPayloadDataTransactions :: ![TransactionBytes] + -- ^ transactions: Array of DATA - Array of transaction objects, each + -- object is a byte list (DATA) representing TransactionType || + -- TransactionPayload or LegacyTransaction as defined in EIP-2718 + , _executionPayloadDataWithdrawals :: ![WithdrawalV1] + -- ^ withdrawals: Array of WithdrawalV1 - Array of withdrawals, each + -- object is an OBJECT containing the fields of a WithdrawalV1 structure. + , _executionPayloadDataExpectedBlobVersionedHashes :: ![VersionedHash] + -- ^ Array of DATA, 32 Bytes - Array of expected blob versioned hashes + -- to validate. + -- + -- The actual blob data is not part of the execution paylaod data + -- (Unlike transactions and withdrawals). + , _executionPayloadDataRequests :: ![EVM.ExecutionRequest] + -- ^ Array of DATA - List of execution layer triggered requests. Each + -- list element is a requests byte array as defined by EIP-7685. The + -- first byte of each element is the request_type and the remaining + -- bytes are the request_data. Elements of the list MUST be ordered by + -- request_type in ascending order. Elements with empty request_data + -- MUST be excluded from the list. If the list has no elements, the + -- expected array MUST be []. If any element is out of order, has a + -- length of 1-byte or shorter, or more than one element has the same + -- type byte, or the param is null, client software MUST return -32602: + -- Invalid params error. + -- + -- This field is new in the Pectra (Prague/Electra) fork. + } + deriving (Show, Eq, Generic) + +makeLenses ''ExecutionPayloadData + +instance RLP ExecutionPayloadData where + putRlp o = putRlpL + [ putRlp $ _executionPayloadDataTransactions o + , putRlp $ _executionPayloadDataWithdrawals o + , putRlp $ _executionPayloadDataExpectedBlobVersionedHashes o + , putRlp $ _executionPayloadDataRequests o + ] + getRlp = label "ExcutionPayloadData" $ getRlpL $ + ExecutionPayloadData + <$> getRlp -- transactions + <*> getRlp -- withdrawals + <*> getRlp -- expectedBlobVersionedHashes + <*> getRlp -- requests + {-# INLINE putRlp #-} + {-# INLINE getRlp #-} + +executionPayloadDataProperties + :: KeyValue e kv + => ExecutionPayloadData + -> [kv] +executionPayloadDataProperties o = + [ "transactions" .= _executionPayloadDataTransactions o + , "withdrawals" .= _executionPayloadDataWithdrawals o + , "expectedBlobVersionedHashes" .= _executionPayloadDataExpectedBlobVersionedHashes o + , "executionRequests" .= _executionPayloadDataRequests o + ] + +instance ToJSON ExecutionPayloadData where + toEncoding = pairs . mconcat . executionPayloadDataProperties + toJSON = object . executionPayloadDataProperties + {-# INLINE toJSON #-} + {-# INLINE toEncoding #-} + +instance FromJSON ExecutionPayloadData where + parseJSON = withObject "ExecutionPayloadData" $ \o -> ExecutionPayloadData + <$> o .: "transactions" + <*> o .: "withdrawals" + <*> o .: "expectedBlobVersionedHashes" + <*> o .: "executionRequests" + {-# INLINE parseJSON #-} + +-- -------------------------------------------------------------------------- -- +-- Payload + +data Payload = Payload + { _payloadHeader :: !EVM.Header + , _payloadData :: !(Maybe ExecutionPayloadData) + } + deriving (Show, Generic) + +makeLenses ''Payload + +instance Eq Payload where + (==) = (==) `on` _payloadHeader + +instance Ord Payload where + compare = compare `on` _payloadHeader + +instance Hashable Payload where + hashWithSalt s = hashWithSalt s . _payloadHeader + +instance RLP Payload where + putRlp (Payload hdr Nothing) = putRlpL + [ putRlp @Word8 0 + , putRlp hdr + ] + putRlp (Payload hdr (Just pld)) = putRlpL + [ putRlp @Word8 1 + , putRlp hdr + , putRlp pld + ] + getRlp = label "Payload" $ getRlpL $ do + getRlp @Word8 >>= \case + 0 -> Payload + <$> getRlp -- header + <*> pure Nothing + 1 -> Payload + <$> getRlp -- header + <*> (Just <$> getRlp) -- data + _ -> fail "Chainweb.PayloadProvider.EVM.ExecutionPayload.getRlp: invalid payload type" + {-# INLINE putRlp #-} + {-# INLINE getRlp #-} + +payloadProperties + :: KeyValue e kv + => Payload + -> [kv] +payloadProperties o = + [ "header" .= _payloadHeader o + , "data" .= _payloadData o + ] + +instance ToJSON Payload where + toEncoding = pairs . mconcat . payloadProperties + toJSON = object . payloadProperties + {-# INLINE toJSON #-} + {-# INLINE toEncoding #-} + +instance FromJSON Payload where + parseJSON = withObject "Payload" $ \o -> Payload + <$> o .: "header" + <*> o .:? "data" + {-# INLINE parseJSON #-} + +payloadToNewPayloadV4Request + :: Payload + -> Maybe NewPayloadV4Request +payloadToNewPayloadV4Request (Payload _ Nothing) = Nothing +payloadToNewPayloadV4Request (Payload hdr (Just d)) = Just $ NewPayloadV4Request + { _newPayloadV4RequestExecutionPayloadV3 = ExecutionPayloadV3 + { _executionPayloadV2 = ExecutionPayloadV2 + { _executionPayloadV1 = ExecutionPayloadV1 + { _executionPayloadV1ParentHash = EVM._hdrParentHash hdr + , _executionPayloadV1FeeRecipient = EVM._hdrBeneficiary hdr + , _executionPayloadV1StateRoot = EVM._hdrStateRoot hdr + , _executionPayloadV1ReceiptsRoot = EVM._hdrReceiptsRoot hdr + , _executionPayloadV1LogsBloom = EVM._hdrLogsBloom hdr + , _executionPayloadV1BlockNumber = EVM._hdrNumber hdr + , _executionPayloadV1GasLimit = EVM._hdrGasLimit hdr + , _executionPayloadV1GasUsed = EVM._hdrGasUsed hdr + , _executionPayloadV1Timestamp = EVM._hdrTimestamp hdr + , _executionPayloadV1ExtraData = EVM._hdrExtraData hdr + , _executionPayloadV1PrevRandao = EVM._hdrPrevRandao hdr + , _executionPayloadV1BaseFeePerGas = EVM._hdrBaseFeePerGas hdr + , _executionPayloadV1BlockHash = EVM._hdrHash hdr + , _executionPayloadV1Transactions = _executionPayloadDataTransactions d + } + , _executionPayloadV2Withdrawals = _executionPayloadDataWithdrawals d + } + , _executionPayloadV3BlobGasUsed = EVM._hdrBlobGasUsed hdr + , _executionPayloadV3ExcessBlobGas = EVM._hdrExcessBlobGas hdr + } + , _newPayloadV4RequestExpectedBlobVersionedHashes + = _executionPayloadDataExpectedBlobVersionedHashes d + , _newPayloadV4RequestParentBeaconBlockRoot = + EVM._hdrParentBeaconBlockRoot hdr + , _newPayloadV4RequestRequests = _executionPayloadDataRequests d + } + +getPayloadV4ResponseToPayload + :: EVM.ParentBeaconBlockRoot + -> GetPayloadV4Response + -> Payload +getPayloadV4ResponseToPayload pbh resp = Payload + { _payloadHeader = executionPayloadV3ToHeader pbh + (_getPayloadV4ResponseExecutionPayload resp) + (_getPayloadV4ResponseExecutionRequests resp) + , _payloadData = Just $ ExecutionPayloadData + { _executionPayloadDataTransactions = _executionPayloadV1Transactions v1 + , _executionPayloadDataWithdrawals = _executionPayloadV2Withdrawals v2 + , _executionPayloadDataExpectedBlobVersionedHashes = + versionedHashes (_getPayloadV4ResponseBlobsBundle resp) + , _executionPayloadDataRequests = _getPayloadV4ResponseExecutionRequests resp + } + } + where + v1 = _executionPayloadV1 v2 + v2 = _executionPayloadV2 v3 + v3 = _getPayloadV4ResponseExecutionPayload resp + +executionPayloadV3ToHeader + :: EVM.ParentBeaconBlockRoot + -> ExecutionPayloadV3 + -> [Utils.ExecutionRequest] + -> EVM.Header +executionPayloadV3ToHeader phdr v3 reqs = hdr + { EVM._hdrHash = EVM.computeBlockHash hdr + , EVM._hdrPayloadHash = EVM.computeBlockPayloadHash hdr + } + where + v2 = _executionPayloadV2 v3 + v1 = _executionPayloadV1 v2 + hdr = EVM.Header + { EVM._hdrParentHash = _executionPayloadV1ParentHash v1 + , EVM._hdrOmmersHash = EVM.ommersHash + , EVM._hdrBeneficiary = _executionPayloadV1FeeRecipient v1 + , EVM._hdrStateRoot = _executionPayloadV1StateRoot v1 + , EVM._hdrTransactionsRoot = transactionsRoot (_executionPayloadV1Transactions v1) + , EVM._hdrReceiptsRoot = _executionPayloadV1ReceiptsRoot v1 + , EVM._hdrLogsBloom = _executionPayloadV1LogsBloom v1 + , EVM._hdrDifficulty = EVM.difficulty + , EVM._hdrNumber = _executionPayloadV1BlockNumber v1 + , EVM._hdrGasLimit = _executionPayloadV1GasLimit v1 + , EVM._hdrGasUsed = _executionPayloadV1GasUsed v1 + , EVM._hdrTimestamp = _executionPayloadV1Timestamp v1 + , EVM._hdrExtraData = _executionPayloadV1ExtraData v1 + , EVM._hdrPrevRandao = _executionPayloadV1PrevRandao v1 + , EVM._hdrNonce = EVM.nonce + , EVM._hdrBaseFeePerGas = _executionPayloadV1BaseFeePerGas v1 + , EVM._hdrWithdrawalsRoot = withdrawlsRoot (_executionPayloadV2Withdrawals v2) + , EVM._hdrBlobGasUsed = _executionPayloadV3BlobGasUsed v3 + , EVM._hdrExcessBlobGas = _executionPayloadV3ExcessBlobGas v3 + , EVM._hdrParentBeaconBlockRoot = phdr + , EVM._hdrRequestsHash = EVM.requestsHash reqs + , EVM._hdrHash = error "Chainweb.PayloadProvider.EVM.executionPayloadV3ToHeader: _hdrHash" + , EVM._hdrPayloadHash = error "Chainweb.PayloadProvider.executionPayloadV3ToHeader: _hdrPayloadHash" + } + +-- -------------------------------------------------------------------------- -- +-- Getters + +_pldParentHash :: Payload -> ParentHash +_pldParentHash = EVM._hdrParentHash . _payloadHeader +{-# INLINE _pldParentHash #-} + +pldParentHash :: Getter Payload ParentHash +pldParentHash = payloadHeader . EVM.hdrParentHash +{-# INLINE pldParentHash #-} + +_pldOmmersHash :: Payload -> OmmersHash +_pldOmmersHash = EVM._hdrOmmersHash . _payloadHeader +{-# INLINE _pldOmmersHash #-} + +pldOmmersHash :: Getter Payload OmmersHash +pldOmmersHash = payloadHeader . EVM.hdrOmmersHash +{-# INLINE pldOmmersHash #-} + +_pldBeneficiary :: Payload -> Beneficiary +_pldBeneficiary = EVM._hdrBeneficiary . _payloadHeader +{-# INLINE _pldBeneficiary #-} + +pldBeneficiary :: Getter Payload Beneficiary +pldBeneficiary = payloadHeader . EVM.hdrBeneficiary +{-# INLINE pldBeneficiary #-} + +_pldStateRoot :: Payload -> StateRoot +_pldStateRoot = EVM._hdrStateRoot . _payloadHeader +{-# INLINE _pldStateRoot #-} + +pldStateRoot :: Getter Payload StateRoot +pldStateRoot = payloadHeader . EVM.hdrStateRoot +{-# INLINE pldStateRoot #-} + +_pldTransactionsRoot :: Payload -> TransactionsRoot +_pldTransactionsRoot = EVM._hdrTransactionsRoot . _payloadHeader +{-# INLINE _pldTransactionsRoot #-} + +pldTransactionsRoot :: Getter Payload TransactionsRoot +pldTransactionsRoot = payloadHeader . EVM.hdrTransactionsRoot +{-# INLINE pldTransactionsRoot #-} + +_pldReceiptsRoot :: Payload -> ReceiptsRoot +_pldReceiptsRoot = EVM._hdrReceiptsRoot . _payloadHeader +{-# INLINE _pldReceiptsRoot #-} + +pldReceiptsRoot :: Getter Payload ReceiptsRoot +pldReceiptsRoot = payloadHeader . EVM.hdrReceiptsRoot +{-# INLINE pldReceiptsRoot #-} + +_pldLogsBloom :: Payload -> Bloom +_pldLogsBloom = EVM._hdrLogsBloom . _payloadHeader +{-# INLINE _pldLogsBloom #-} + +pldLogsBloom :: Getter Payload Bloom +pldLogsBloom = payloadHeader . EVM.hdrLogsBloom +{-# INLINE pldLogsBloom #-} + +_pldDifficulty :: Payload -> Difficulty +_pldDifficulty = EVM._hdrDifficulty . _payloadHeader +{-# INLINE _pldDifficulty #-} + +pldDifficulty :: Getter Payload Difficulty +pldDifficulty = payloadHeader . EVM.hdrDifficulty +{-# INLINE pldDifficulty #-} + +_pldNumber :: Payload -> BlockNumber +_pldNumber = EVM._hdrNumber . _payloadHeader +{-# INLINE _pldNumber #-} + +pldNumber :: Getter Payload BlockNumber +pldNumber = payloadHeader . EVM.hdrNumber +{-# INLINE pldNumber #-} + +_pldHeight :: Payload -> Chainweb.BlockHeight +_pldHeight = EVM._hdrHeight . _payloadHeader +{-# INLINE _pldHeight #-} + +pldHeight :: Getter Payload Chainweb.BlockHeight +pldHeight = payloadHeader . EVM.hdrHeight +{-# INLINE pldHeight #-} + +_pldGasLimit :: Payload -> GasLimit +_pldGasLimit = EVM._hdrGasLimit . _payloadHeader +{-# INLINE _pldGasLimit #-} + +pldGasLimit :: Getter Payload GasLimit +pldGasLimit = payloadHeader . EVM.hdrGasLimit +{-# INLINE pldGasLimit #-} + +_pldGasUsed :: Payload -> GasUsed +_pldGasUsed = EVM._hdrGasUsed . _payloadHeader +{-# INLINE _pldGasUsed #-} + +pldGasUsed :: Getter Payload GasUsed +pldGasUsed = payloadHeader . EVM.hdrGasUsed +{-# INLINE pldGasUsed #-} + +_pldTimestamp :: Payload -> Timestamp +_pldTimestamp = EVM._hdrTimestamp . _payloadHeader +{-# INLINE _pldTimestamp #-} + +pldTimestamp :: Getter Payload Timestamp +pldTimestamp = payloadHeader . EVM.hdrTimestamp +{-# INLINE pldTimestamp #-} + +_pldExtraData :: Payload -> ExtraData +_pldExtraData = EVM._hdrExtraData . _payloadHeader +{-# INLINE _pldExtraData #-} + +pldExtraData :: Getter Payload ExtraData +pldExtraData = payloadHeader . EVM.hdrExtraData +{-# INLINE pldExtraData #-} + +_pldPrevRandao :: Payload -> EVM.Randao +_pldPrevRandao = EVM._hdrPrevRandao . _payloadHeader +{-# INLINE _pldPrevRandao #-} + +pldPrevRandao :: Getter Payload EVM.Randao +pldPrevRandao = payloadHeader . EVM.hdrPrevRandao +{-# INLINE pldPrevRandao #-} + +_pldNonce :: Payload -> Nonce +_pldNonce = EVM._hdrNonce . _payloadHeader +{-# INLINE _pldNonce #-} + +pldNonce :: Getter Payload Nonce +pldNonce = payloadHeader . EVM.hdrNonce +{-# INLINE pldNonce #-} + +_pldBaseFeePerGas :: Payload -> EVM.BaseFeePerGas +_pldBaseFeePerGas = EVM._hdrBaseFeePerGas . _payloadHeader +{-# INLINE _pldBaseFeePerGas #-} + +pldBaseFeePerGas :: Getter Payload EVM.BaseFeePerGas +pldBaseFeePerGas = payloadHeader . EVM.hdrBaseFeePerGas +{-# INLINE pldBaseFeePerGas #-} + +_pldWithdrawalsRoot :: Payload -> EVM.WithdrawalsRoot +_pldWithdrawalsRoot = EVM._hdrWithdrawalsRoot . _payloadHeader +{-# INLINE _pldWithdrawalsRoot #-} + +pldWithdrawalsRoot :: Getter Payload EVM.WithdrawalsRoot +pldWithdrawalsRoot = payloadHeader . EVM.hdrWithdrawalsRoot +{-# INLINE pldWithdrawalsRoot #-} + +_pldBlobGasUsed :: Payload -> EVM.BlobGasUsed +_pldBlobGasUsed = EVM._hdrBlobGasUsed . _payloadHeader +{-# INLINE _pldBlobGasUsed #-} + +pldBlobGasUsed :: Getter Payload EVM.BlobGasUsed +pldBlobGasUsed = payloadHeader . EVM.hdrBlobGasUsed +{-# INLINE pldBlobGasUsed #-} + +_pldExcessBlobGas :: Payload -> EVM.ExcessBlobGas +_pldExcessBlobGas = EVM._hdrExcessBlobGas . _payloadHeader +{-# INLINE _pldExcessBlobGas #-} + +pldExcessBlobGas :: Getter Payload EVM.ExcessBlobGas +pldExcessBlobGas = payloadHeader . EVM.hdrExcessBlobGas +{-# INLINE pldExcessBlobGas #-} + +_pldParentBeaconBlockRoot :: Payload -> EVM.ParentBeaconBlockRoot +_pldParentBeaconBlockRoot = EVM._hdrParentBeaconBlockRoot . _payloadHeader +{-# INLINE _pldParentBeaconBlockRoot #-} + +pldParentBeaconBlockRoot :: Getter Payload EVM.ParentBeaconBlockRoot +pldParentBeaconBlockRoot = payloadHeader . EVM.hdrParentBeaconBlockRoot +{-# INLINE pldParentBeaconBlockRoot #-} + +_pldRequestsHash :: Payload -> EVM.RequestsHash +_pldRequestsHash = EVM._hdrRequestsHash . _payloadHeader +{-# INLINE _pldRequestsHash #-} + +pldRequestsHash :: Getter Payload EVM.RequestsHash +pldRequestsHash = payloadHeader . EVM.hdrRequestsHash +{-# INLINE pldRequestsHash #-} + +_pldHash :: Payload -> BlockHash +_pldHash = EVM._hdrHash . _payloadHeader +{-# INLINE _pldHash #-} + +pldHash :: Getter Payload BlockHash +pldHash = payloadHeader . EVM.hdrHash +{-# INLINE pldHash #-} + +_pldPayloadHash :: Payload -> BlockPayloadHash +_pldPayloadHash = EVM._hdrPayloadHash . _payloadHeader +{-# INLINE _pldPayloadHash #-} + +pldPayloadHash :: Getter Payload BlockPayloadHash +pldPayloadHash = payloadHeader . EVM.hdrPayloadHash +{-# INLINE pldPayloadHash #-} + +_pldTransactions :: Payload -> Maybe [TransactionBytes] +_pldTransactions = fmap _executionPayloadDataTransactions . _payloadData +{-# INLINE _pldTransactions #-} + +pldTransactions :: Getter Payload (Maybe [TransactionBytes]) +pldTransactions = to _pldTransactions +{-# INLINE pldTransactions #-} + +_pldWithdrawals :: Payload -> Maybe [WithdrawalV1] +_pldWithdrawals = fmap _executionPayloadDataWithdrawals . _payloadData +{-# INLINE _pldWithdrawals #-} + +pldWithdrawals :: Getter Payload (Maybe [WithdrawalV1]) +pldWithdrawals = to _pldWithdrawals +{-# INLINE pldWithdrawals #-} + +_pldExpectedBlobVersionedHashes :: Payload -> Maybe [VersionedHash] +_pldExpectedBlobVersionedHashes = fmap _executionPayloadDataExpectedBlobVersionedHashes . _payloadData +{-# INLINE _pldExpectedBlobVersionedHashes #-} + +pldExpectedBlobVersionedHashes :: Getter Payload (Maybe [VersionedHash]) +pldExpectedBlobVersionedHashes = to _pldExpectedBlobVersionedHashes +{-# INLINE pldExpectedBlobVersionedHashes #-} + +_pldRequests :: Payload -> Maybe [EVM.ExecutionRequest] +_pldRequests = fmap _executionPayloadDataRequests . _payloadData +{-# INLINE _pldRequests #-} + +pldRequests :: Getter Payload (Maybe [EVM.ExecutionRequest]) +pldRequests = to _pldRequests +{-# INLINE pldRequests #-} + +_pldRankedBlockPayloadHash :: Payload -> RankedBlockPayloadHash +_pldRankedBlockPayloadHash pld = RankedBlockPayloadHash + { _rankedBlockPayloadHashHeight = int $ EVM._hdrNumber $ _payloadHeader pld + , _rankedBlockPayloadHashHash = EVM._hdrPayloadHash $ _payloadHeader pld + } +{-# INLINE _pldRankedBlockPayloadHash #-} + +pldRankedBlockPayloadHash :: Getter Payload RankedBlockPayloadHash +pldRankedBlockPayloadHash = to _pldRankedBlockPayloadHash +{-# INLINE pldRankedBlockPayloadHash #-} diff --git a/src/Chainweb/PayloadProvider/EVM/Genesis.hs b/src/Chainweb/PayloadProvider/EVM/Genesis.hs new file mode 100644 index 0000000000..7d45b1f511 --- /dev/null +++ b/src/Chainweb/PayloadProvider/EVM/Genesis.hs @@ -0,0 +1,120 @@ +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE LambdaCase #-} + +-- | +-- Module: Chainweb.PayloadProvider.EVM.Genesis +-- Copyright: Copyright © 2025 Kadena LLC. +-- License: MIT +-- Maintainer: Lars Kuhtz +-- Stability: experimental +-- +module Chainweb.PayloadProvider.EVM.Genesis +( genesisBlocks +) where + +import Chainweb.Version +import Chainweb.PayloadProvider.EVM.Header +import Chainweb.Version.EvmTestnet +import Chainweb.Version.EvmDevelopment +import Chainweb.Version.EvmDevelopmentSingleton +import Chainweb.Utils +import Chainweb.PayloadProvider.EVM.Utils (decodeRlpM) +import Data.Text qualified as T + +-- -------------------------------------------------------------------------- -- +-- Genesis Blocks +-- +-- EVM Development headers for chain-0 and chain-1. +-- +-- NOTE that the header value does not depend on the chainId/netId. +-- +-- { +-- "hash": "0x557c3fc4b87c8bce45002e8fe4db07546324caec6459cb67c64389110c9fd942", +-- "parentHash": "0x0000000000000000000000000000000000000000000000000000000000000000", +-- "sha3Uncles": "0x1dcc4de8dec75d7aab85b567b6ccd41ad312451b948a7413f0a142fd40d49347", +-- "miner": "0x0000000000000000000000000000000000000000", +-- "stateRoot": "0x7d2b86c493412a586f03e4aee1ab94837c6a8fff21ff7c6045dc1330d5b0d49e", +-- "transactionsRoot": "0x56e81f171bcc55a6ff8345e692c0f86e5b48e01b996cadc001622fb5e363b421", +-- "receiptsRoot": "0x56e81f171bcc55a6ff8345e692c0f86e5b48e01b996cadc001622fb5e363b421", +-- "logsBloom": "0x00000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000", +-- "difficulty": "0x0", +-- "number": "0x0", +-- "gasLimit": "0x1c9c380", +-- "gasUsed": "0x0", +-- "timestamp": "0x6490fdd2", +-- "totalDifficulty": "0x0", +-- "extraData": "0x", +-- "mixHash": "0x0000000000000000000000000000000000000000000000000000000000000000", +-- "nonce": "0x0000000000000000", +-- "baseFeePerGas": "0x3b9aca00", +-- "withdrawalsRoot": "0x56e81f171bcc55a6ff8345e692c0f86e5b48e01b996cadc001622fb5e363b421", +-- "blobGasUsed": "0x0", +-- "excessBlobGas": "0x0", +-- "parentBeaconBlockRoot": "0x0000000000000000000000000000000000000000000000000000000000000000", +-- "uncles": [], +-- "transactions": [], +-- "size": "0x247", +-- "withdrawals": [] +-- } +-- +-- block payload hash: -EffZgInrtrokWVn5iqO2fuTbtG2-noDdhXr0pHQA4E + +-- | Genesis Headers for the EVM Payload Provider +-- +-- NOTE: These headers must match the block payload hashes in the respective +-- Chainweb.Version.* modules. +-- +-- How to get the headers: +-- +-- 1. Query the EVM genesis header and compute block payload hash and header: +-- +-- @ +-- cabal run cwtools:exe:evm-genesis evm-development +-- @ +-- +genesisBlocks + :: HasVersion + => HasChainId c + => c + -> Header +genesisBlocks c = go (_versionCode implicitVersion) (_chainId c) + where + go v + | v == _versionCode EvmDevelopmentSingleton = \case + ChainId 0 -> f + "-QJfoAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAoB3MTejex116q4W1Z7bM1BrTEkUblIp0E_ChQv1A1JNHlAAAAAAAAAAAAAAAAAAAAAAAAAAAoHsjEEZFVIdzrA-oOTuR_pi_wPJmgq0qX6-M0teV5K5AoFboHxcbzFWm_4NF5pLA-G5bSOAbmWytwAFiL7XjY7QhoFboHxcbzFWm_4NF5pLA-G5bSOAbmWytwAFiL7XjY7QhuQEAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAICAhAHJw4CAhGhMXSqAoAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAiAAAAAAAAAAAhDuaygCgVugfFxvMVab_g0XmksD4bltI4BuZbK3AAWIvteNjtCGAgKAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAKDjsMRCmPwcFJr79MiZb7kkJ65B5GSbk0yklZkbeFK4VQ" + _ -> error $ "unsupported chain: " <> T.unpack (toText (_chainId c)) + | v == _versionCode EvmDevelopmentPair = \case + ChainId 1 -> f + "-QJfoAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAoB3MTejex116q4W1Z7bM1BrTEkUblIp0E_ChQv1A1JNHlAAAAAAAAAAAAAAAAAAAAAAAAAAAoPXtqeg080fa3pjmZQ54atXAGBtwmPK_bQmqYCAom_DLoFboHxcbzFWm_4NF5pLA-G5bSOAbmWytwAFiL7XjY7QhoFboHxcbzFWm_4NF5pLA-G5bSOAbmWytwAFiL7XjY7QhuQEAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAICAhAHJw4CAhGhMXSqAoAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAiAAAAAAAAAAAhDuaygCgVugfFxvMVab_g0XmksD4bltI4BuZbK3AAWIvteNjtCGAgKAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAKDjsMRCmPwcFJr79MiZb7kkJ65B5GSbk0yklZkbeFK4VQ" + _ -> error $ "unsupported chain: " <> T.unpack (toText (_chainId c)) + | v == _versionCode EvmDevelopment = \case + ChainId 20 -> f + "-QJfoAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAoB3MTejex116q4W1Z7bM1BrTEkUblIp0E_ChQv1A1JNHlAAAAAAAAAAAAAAAAAAAAAAAAAAAoFDFmG7LRcte3DwPq2mU_ba0x-Mr9NNC4mDCsocGJAlPoFboHxcbzFWm_4NF5pLA-G5bSOAbmWytwAFiL7XjY7QhoFboHxcbzFWm_4NF5pLA-G5bSOAbmWytwAFiL7XjY7QhuQEAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAICAhAHJw4CAhGhMXSqAoAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAiAAAAAAAAAAAhDuaygCgVugfFxvMVab_g0XmksD4bltI4BuZbK3AAWIvteNjtCGAgKAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAKDjsMRCmPwcFJr79MiZb7kkJ65B5GSbk0yklZkbeFK4VQ" + ChainId 21 -> f + "-QJfoAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAoB3MTejex116q4W1Z7bM1BrTEkUblIp0E_ChQv1A1JNHlAAAAAAAAAAAAAAAAAAAAAAAAAAAoM7pw0jn4gkNaP8a8XruQe90yhqv16r93dzfVGelzaZioFboHxcbzFWm_4NF5pLA-G5bSOAbmWytwAFiL7XjY7QhoFboHxcbzFWm_4NF5pLA-G5bSOAbmWytwAFiL7XjY7QhuQEAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAICAhAHJw4CAhGhMXSqAoAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAiAAAAAAAAAAAhDuaygCgVugfFxvMVab_g0XmksD4bltI4BuZbK3AAWIvteNjtCGAgKAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAKDjsMRCmPwcFJr79MiZb7kkJ65B5GSbk0yklZkbeFK4VQ" + ChainId 22 -> f + "-QJfoAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAoB3MTejex116q4W1Z7bM1BrTEkUblIp0E_ChQv1A1JNHlAAAAAAAAAAAAAAAAAAAAAAAAAAAoGZSaKQTLD2JsNwJwUUxu0QxWAlfVKv4cJQLZalLCZW3oFboHxcbzFWm_4NF5pLA-G5bSOAbmWytwAFiL7XjY7QhoFboHxcbzFWm_4NF5pLA-G5bSOAbmWytwAFiL7XjY7QhuQEAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAICAhAHJw4CAhGhMXSqAoAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAiAAAAAAAAAAAhDuaygCgVugfFxvMVab_g0XmksD4bltI4BuZbK3AAWIvteNjtCGAgKAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAKDjsMRCmPwcFJr79MiZb7kkJ65B5GSbk0yklZkbeFK4VQ" + ChainId 23 -> f + "-QJfoAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAoB3MTejex116q4W1Z7bM1BrTEkUblIp0E_ChQv1A1JNHlAAAAAAAAAAAAAAAAAAAAAAAAAAAoJWlH1pPYbkrCUE5ca0DQiDRhemIU8x6dXFXPfZ_dWo_oFboHxcbzFWm_4NF5pLA-G5bSOAbmWytwAFiL7XjY7QhoFboHxcbzFWm_4NF5pLA-G5bSOAbmWytwAFiL7XjY7QhuQEAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAICAhAHJw4CAhGhMXSqAoAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAiAAAAAAAAAAAhDuaygCgVugfFxvMVab_g0XmksD4bltI4BuZbK3AAWIvteNjtCGAgKAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAKDjsMRCmPwcFJr79MiZb7kkJ65B5GSbk0yklZkbeFK4VQ" + ChainId 24 -> f + "-QJfoAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAoB3MTejex116q4W1Z7bM1BrTEkUblIp0E_ChQv1A1JNHlAAAAAAAAAAAAAAAAAAAAAAAAAAAoBHB-PhTSErVa_nC1-JDEwkvS7XMdw23N5wsSp7oigp4oFboHxcbzFWm_4NF5pLA-G5bSOAbmWytwAFiL7XjY7QhoFboHxcbzFWm_4NF5pLA-G5bSOAbmWytwAFiL7XjY7QhuQEAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAICAhAHJw4CAhGhMXSqAoAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAiAAAAAAAAAAAhDuaygCgVugfFxvMVab_g0XmksD4bltI4BuZbK3AAWIvteNjtCGAgKAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAKDjsMRCmPwcFJr79MiZb7kkJ65B5GSbk0yklZkbeFK4VQ" + _ -> error $ "unsupported chain: " <> T.unpack (toText (_chainId c)) + | v == _versionCode EvmTestnet = \case + ChainId 20 -> f + "-QJfoAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAoB3MTejex116q4W1Z7bM1BrTEkUblIp0E_ChQv1A1JNHlAAAAAAAAAAAAAAAAAAAAAAAAAAAoCTHeI9_GgUd4bjjjAEald4V0u_EMqenZXs0GCcwRz6xoFboHxcbzFWm_4NF5pLA-G5bSOAbmWytwAFiL7XjY7QhoFboHxcbzFWm_4NF5pLA-G5bSOAbmWytwAFiL7XjY7QhuQEAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAICAhAHJw4CAhGhMXSqAoAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAiAAAAAAAAAAAhDuaygCgVugfFxvMVab_g0XmksD4bltI4BuZbK3AAWIvteNjtCGAgKAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAKDjsMRCmPwcFJr79MiZb7kkJ65B5GSbk0yklZkbeFK4VQ" + ChainId 21 -> f + "-QJfoAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAoB3MTejex116q4W1Z7bM1BrTEkUblIp0E_ChQv1A1JNHlAAAAAAAAAAAAAAAAAAAAAAAAAAAoF-hwkBj12gWfQn_kYGVNBQ_SBe3ucEywFCdxkzdAlwToFboHxcbzFWm_4NF5pLA-G5bSOAbmWytwAFiL7XjY7QhoFboHxcbzFWm_4NF5pLA-G5bSOAbmWytwAFiL7XjY7QhuQEAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAICAhAHJw4CAhGhMXSqAoAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAiAAAAAAAAAAAhDuaygCgVugfFxvMVab_g0XmksD4bltI4BuZbK3AAWIvteNjtCGAgKAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAKDjsMRCmPwcFJr79MiZb7kkJ65B5GSbk0yklZkbeFK4VQ" + ChainId 22 -> f + "-QJfoAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAoB3MTejex116q4W1Z7bM1BrTEkUblIp0E_ChQv1A1JNHlAAAAAAAAAAAAAAAAAAAAAAAAAAAoDKLFnX-TIPlT3jRGPEwgGmEendfdeXw2GLb66g9UTXPoFboHxcbzFWm_4NF5pLA-G5bSOAbmWytwAFiL7XjY7QhoFboHxcbzFWm_4NF5pLA-G5bSOAbmWytwAFiL7XjY7QhuQEAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAICAhAHJw4CAhGhMXSqAoAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAiAAAAAAAAAAAhDuaygCgVugfFxvMVab_g0XmksD4bltI4BuZbK3AAWIvteNjtCGAgKAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAKDjsMRCmPwcFJr79MiZb7kkJ65B5GSbk0yklZkbeFK4VQ" + ChainId 23 -> f + "-QJfoAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAoB3MTejex116q4W1Z7bM1BrTEkUblIp0E_ChQv1A1JNHlAAAAAAAAAAAAAAAAAAAAAAAAAAAoBsnLZieDJJ2Bt0qkEHDN08t1ZB83NV0kRH60GLbTaL8oFboHxcbzFWm_4NF5pLA-G5bSOAbmWytwAFiL7XjY7QhoFboHxcbzFWm_4NF5pLA-G5bSOAbmWytwAFiL7XjY7QhuQEAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAICAhAHJw4CAhGhMXSqAoAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAiAAAAAAAAAAAhDuaygCgVugfFxvMVab_g0XmksD4bltI4BuZbK3AAWIvteNjtCGAgKAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAKDjsMRCmPwcFJr79MiZb7kkJ65B5GSbk0yklZkbeFK4VQ" + ChainId 24 -> f + "-QJfoAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAoB3MTejex116q4W1Z7bM1BrTEkUblIp0E_ChQv1A1JNHlAAAAAAAAAAAAAAAAAAAAAAAAAAAoF3-gmUhbm6xlQHDAHKZZcZrnib-AEFCoLMcuLDI53YpoFboHxcbzFWm_4NF5pLA-G5bSOAbmWytwAFiL7XjY7QhoFboHxcbzFWm_4NF5pLA-G5bSOAbmWytwAFiL7XjY7QhuQEAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAICAhAHJw4CAhGhMXSqAoAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAiAAAAAAAAAAAhDuaygCgVugfFxvMVab_g0XmksD4bltI4BuZbK3AAWIvteNjtCGAgKAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAKDjsMRCmPwcFJr79MiZb7kkJ65B5GSbk0yklZkbeFK4VQ" + _ -> error $ "unsupported chain: " <> T.unpack (toText (_chainId c)) + | otherwise = error "requested genesis block for unsupported chain" + + f t = case decodeB64UrlNoPaddingText t >>= decodeRlpM of + Left e -> error $ "Chainweb.PayloadProvider.EVM.genesisBlocks: invalid genesis block: " <> sshow e + Right x -> x diff --git a/src/Chainweb/PayloadProvider/EVM/Header.hs b/src/Chainweb/PayloadProvider/EVM/Header.hs new file mode 100644 index 0000000000..d5c452db03 --- /dev/null +++ b/src/Chainweb/PayloadProvider/EVM/Header.hs @@ -0,0 +1,865 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NumericUnderscores #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +{-# OPTIONS_GHC -Wno-orphans #-} + +-- | +-- Module: Chainweb.PayloadProvider.EVM.Header +-- Copyright: Copyright © 2024 Kadena LLC. +-- License: MIT +-- Maintainer: Lars Kuhtz +-- Stability: experimental +-- +-- Execution Layer Header For Cacun Hardfork +-- +-- For the specification up to the Shanghai Hardfork see: +-- +-- [Yellow Paper (SHANGHAI VERSION f3553dd – 2024-11-04), 4.4 The Block](https://ethereum.github.io/yellowpaper/paper.pdf) +-- +-- For the Cacun specificic addition see: +-- +-- [python execution-specs](https://github.com/ethereum/execution-specs/blob/master/src/ethereum/cancun/blocks.py) +-- +module Chainweb.PayloadProvider.EVM.Header +( Header(..) +, ommersHash +, difficulty +, nonce +, headerProof +, runHeaderProof +, BaseFeePerGas(..) +, BlobGasUsed(..) +, ExcessBlobGas(..) +, WithdrawalsRoot(..) +, ParentBeaconBlockRoot(..) +, chainwebBlockHashToBeaconBlockRoot +, beaconBlockRootToChainwebBlockHash +, computeBlockHash +, computeBlockPayloadHash +, RequestsHash(..) +, requestsHash + +-- * Misc + +, type HeaderCas +, heightToNumber +, numberToHeight +, _hdrHeight +, timestamp + +-- * Getter +, hdrParentHash +, hdrOmmersHash +, hdrBeneficiary +, hdrStateRoot +, hdrTransactionsRoot +, hdrReceiptsRoot +, hdrLogsBloom +, hdrDifficulty +, hdrNumber +, hdrGasLimit +, hdrGasUsed +, hdrTimestamp +, hdrExtraData +, hdrPrevRandao +, hdrNonce +, hdrBaseFeePerGas +, hdrWithdrawalsRoot +, hdrHeight +, hdrBlobGasUsed +, hdrExcessBlobGas +, hdrParentBeaconBlockRoot +, hdrRequestsHash +, hdrHash +, hdrPayloadHash +) where + +import Chainweb.BlockCreationTime qualified as Chainweb +import Chainweb.BlockHash qualified as Chainweb +import Chainweb.BlockHeight qualified as Chainweb +import Chainweb.BlockPayloadHash +import Chainweb.Crypto.MerkleLog +import Chainweb.MerkleLogHash +import Chainweb.MerkleUniverse +import Chainweb.PayloadProvider.EVM.Receipt ({- IsMerkleLogEntry ReceiptsRoot -}) +import Chainweb.PayloadProvider.EVM.Utils +import Chainweb.Storage.Table +import Chainweb.Time +import Chainweb.Utils (sshow) +import Chainweb.Utils.Serialization (runGetS) +import Chainweb.Utils.Serialization qualified as Chainweb +import Control.Lens (Getter, to) +import Control.Monad.Catch +import Data.Aeson +import Data.Aeson.Types (Pair) +import Data.ByteString.Short qualified as BS +import Data.ByteString.Short qualified as SBS +import Data.Function +import Data.Hashable (Hashable(..)) +import Data.MerkleLog qualified as V2 +import Data.Ratio ((%)) +import Data.Void +import Data.Hash.SHA2 +import Ethereum.Misc +import Ethereum.RLP +import Ethereum.Utils +import Foreign.Storable +import GHC.Generics (Generic) +import GHC.TypeNats +import Data.Coerce + +-- -------------------------------------------------------------------------- +-- Utils + +numberToHeight :: BlockNumber -> Chainweb.BlockHeight +numberToHeight n = fromIntegral n + +heightToNumber :: Chainweb.BlockHeight -> BlockNumber +heightToNumber = fromIntegral + +-- -------------------------------------------------------------------------- -- + +-- | Compute the Ethereum Timestamp for a block headder +-- +-- In chainweb the payload time is the block creation of the parent header. It +-- must be strictly monotonically increasing at microsecond precision. +-- +-- The EVM requires that timestamps of EVM payload headers are stricly +-- monotonically increasing at second precision with respect to the parent +-- relation. +-- +-- Chainweb also requires that all data in the preimage of the block payload +-- hash is derived deterministcally from the current payload provider state (as +-- captured by preimage of the previous block payload hash), the user +-- transactions, and the chainweb parent header (the ParentBeaconBlockRoot). +-- +-- In chainweb it can happen that blocks are less than 1s appart. The +-- constraints for timestamps are satisfied by using the smallest integral value +-- that is larger or equal than the block creation time of the chainweb parent +-- timestamp (the ParentBeaconBlockRoot) and strictly larger than the timestamp +-- of the EVM parent header. +-- +timestamp + :: Timestamp + -- ^ Timestamp of the EVM parent header + -> Chainweb.BlockCreationTime + -- ^ BlockCreationTime of the ParentBeaconBlockRoot + -> Timestamp +timestamp (Timestamp e) (Chainweb.BlockCreationTime (Time (TimeSpan (Micros t)))) = + Timestamp $ max (e + 1) cwTimestamp + where + cwTimestamp = ceiling (t % 1_000_000) + +-- ------- ------------------------------------------------------------------- -- +-- Header Fields for Paris Hardfork +-- +-- The mixHash field was repurposed in the Paris hardfork to store the previous +-- RANDAO mix. + +-- | Base Fee Per Gas of a Block in Wei +-- +-- A natural number [cf. yellow paper 4.4.3 (44)] +-- +newtype BaseFeePerGas = BaseFeePerGas Natural + deriving (Show, Eq) + deriving newtype (RLP) + deriving ToJSON via (HexQuantity Natural) + deriving FromJSON via (HexQuantity Natural) + +-- -------------------------------------------------------------------------- -- +-- Header Fields for Shanghai Hardfork + +-- | Withdrawals Root +-- +-- 32 bytes [cf. yellow paper 4.4.3 (44)] +-- +newtype WithdrawalsRoot = WithdrawalsRoot (BytesN 32) + deriving (Show, Eq) + deriving newtype (RLP, Bytes, Storable, Hashable) + deriving ToJSON via (HexBytes (BytesN 32)) + deriving FromJSON via (HexBytes (BytesN 32)) + +-- -------------------------------------------------------------------------- -- +-- Header Fields for Cacun Hardfork + +-- | Parent Beacon Block Root +-- +-- Since Cacun Hardfork +-- +newtype ParentBeaconBlockRoot = ParentBeaconBlockRoot (BytesN 32) + deriving (Show, Eq) + deriving newtype (RLP, Bytes, Storable, Hashable) + deriving ToJSON via (HexBytes (BytesN 32)) + deriving FromJSON via (HexBytes (BytesN 32)) + +chainwebBlockHashToBeaconBlockRoot :: Chainweb.BlockHash -> ParentBeaconBlockRoot +chainwebBlockHashToBeaconBlockRoot bh = ParentBeaconBlockRoot + (unsafeBytesN $ SBS.toShort $ Chainweb.runPutS (Chainweb.encodeBlockHash bh)) + +beaconBlockRootToChainwebBlockHash :: ParentBeaconBlockRoot -> Chainweb.BlockHash +beaconBlockRootToChainwebBlockHash bs = + case runGetS @_ @Chainweb.BlockHash Chainweb.decodeBlockHash (bytes bs) of + Left e -> error $ "Chainweb.PayloadProvider.EVM.Header.beaconBlockRootToChainwebBlockHash. invalid beacon block root: " <> sshow e + Right x -> x + +-- | Gas Used for Blob +-- +-- Since Cacun Hardfork +-- +newtype BlobGasUsed = BlobGasUsed Natural + deriving (Show, Eq) + deriving newtype (RLP) + deriving ToJSON via (HexQuantity Natural) + deriving FromJSON via (HexQuantity Natural) + +-- | Excess Blob Gas +-- +-- Since Cacun Hardfork +-- +newtype ExcessBlobGas = ExcessBlobGas Natural + deriving (Show, Eq) + deriving newtype (RLP) + deriving ToJSON via (HexQuantity Natural) + deriving FromJSON via (HexQuantity Natural) + +-- -- -------------------------------------------------------------------------- +-- Header fields for Pectra (Prague + Electra) Hardfork + +-- | Requests Hash +-- +-- Since Pectra Hardfork (cf. EIP-7685) +-- +newtype RequestsHash = RequestsHash (BytesN 32) + deriving (Show, Eq) + deriving newtype (RLP, Bytes, Storable, Hashable) + deriving ToJSON via (HexBytes (BytesN 32)) + deriving FromJSON via (HexBytes (BytesN 32)) + +requestsHash :: [ExecutionRequest] -> RequestsHash +requestsHash = RequestsHash + . unsafeBytesN + . coerce + . hashShortByteString_ @Sha2_256 + . mconcat + . fmap (coerce . hashShortByteString_ @Sha2_256 . coerce) + +-- -------------------------------------------------------------------------- -- +-- Header + +-- | Execution Layer Header +-- +-- For the specification up to the Shanghai Hardfork see: +-- +-- [Yellow Paper (SHANGHAI VERSION f3553dd – 2024-11-04), 4.4 The Block](https://ethereum.github.io/yellowpaper/paper.pdf) +-- +-- For the Cacun specificic addition see: +-- +-- [python execution-specs](https://github.com/ethereum/execution-specs/blob/master/src/ethereum/cancun/blocks.py) +-- +-- +data Header = Header + { _hdrParentHash :: !ParentHash + -- ^ The Keccak 256-bit hash of the parent block’s header, in its + -- entirety; formally \(H_p\). + , _hdrOmmersHash :: !OmmersHash + -- ^ A 256-bit hash field that is now deprecated due to the replacement + -- of proof of work consensus. It is now to a constant, KEC(RLP(())); + -- formally \(H_o\). + , _hdrBeneficiary :: !Beneficiary + -- ^ The 160-bit address to which priority fees from this block are + -- transferred; formally \(H_c\). + , _hdrStateRoot :: !StateRoot + -- ^ The Keccak 256-bit hash of the root node of the state trie, after + -- all transactions and withdrawals are executed and finalisations + -- applied; formally \(H_r\). + , _hdrTransactionsRoot :: !TransactionsRoot + -- ^ The Keccak 256-bit hash of the root node of the trie structure + -- populated with each transaction in the transactions list portion of + -- the block; formally \(H_t\). + , _hdrReceiptsRoot :: !ReceiptsRoot + -- ^ The Keccak 256-bit hash of the root node of the trie structure + -- populated with the receipts of each transaction in the transactions + -- list portion of the block; formally \(H_e\). + , _hdrLogsBloom :: !Bloom + -- ^ The Bloom filter composed from indexable information (logger + -- address and log topics) contained in each log entry from the receipt + -- of each transaction in the transactions list; formally \(H_b\). + , _hdrDifficulty :: !Difficulty + -- ^ A scalar field that is now deprecated due to the replacement of + -- proof of work consensus. It is set to 0; formally \(H_d\). + , _hdrNumber :: !BlockNumber + -- ^ A scalar value equal to the number of ancestor blocks. The genesis + -- block has a number of zero; formally \(H_i\). + , _hdrGasLimit :: !GasLimit + -- ^ A scalar value equal to the current limit of gas expenditure per + -- block; formally \(H_l\). + , _hdrGasUsed :: !GasUsed + -- ^ A scalar value equal to the total gas used in transactions in this + -- block; formally \(H_g\). + , _hdrTimestamp :: !Timestamp + -- ^ A scalar value equal to the reasonable output of Unix’s time() at + -- this block’s inception; formally \(H_s\). + , _hdrExtraData :: !ExtraData + -- ^ An arbitrary byte array containing data relevant to this block. + -- This must be 32 bytes or fewer; formally \(H_x\). + , _hdrPrevRandao :: !Randao + -- ^ the latest RANDAO mix7 of the post beacon state of the previous + -- block; formally \(H_a\). + , _hdrNonce :: !Nonce + -- ^ A 64-bit value that is now deprecated due to the replacement of + -- proof of work consensus. It is set to 0x0000000000000000; formally + -- \(H_n\). + -- + -- In parts of the API the nonce is interpreded as a Word64 scalar. In + -- RLP serialization it is considered as bytes. Hence, we store it as + -- bytes. Note, however, that it is used in reversed byte order in the + -- Ethhash computation. + , _hdrBaseFeePerGas :: !BaseFeePerGas + -- ^ A scalar value equal to the amount of wei that is burned for each + -- unit of gas consumed; formally \(H_f\). + , _hdrWithdrawalsRoot :: !WithdrawalsRoot + -- ^ The Keccak 256-bit hash of the root node of the trie structure + -- populated with each withdrawal operations pushed by the consensus + -- layer for this block; formally \(H_w\). + + -- The following fields are from the Cacun hard fork which is not yet + -- described in the Yellow Paper. + -- + -- cf. https://github.com/ethereum/execution-specs/blob/master/src/ethereum/cancun/blocks.py + + , _hdrBlobGasUsed :: !BlobGasUsed + , _hdrExcessBlobGas :: !ExcessBlobGas + , _hdrParentBeaconBlockRoot :: !ParentBeaconBlockRoot + + -- The following field was introduced in the Pectra hard fork. It is ignored + -- in legacy headers. + , _hdrRequestsHash :: !RequestsHash + -- ^ The requests hash is the SHA256 hash of the SHA256 hashes of all + -- non-empty hashes in the block ordered by request type. For blocks + -- with no requests this is the empty hash. (cf. EIP-7685) + + -- synthetic fields + , _hdrHash :: {- Lazy -} BlockHash + -- ^ Ethereum Execution Header Block Hash + , _hdrPayloadHash :: {- Lazy -} BlockPayloadHash + -- ^ Chainweb BlockPayloadHash + } + deriving (Show, Generic) + +instance Hashable Header where + hashWithSalt s = hashWithSalt s . _hdrPayloadHash + {-# INLINEABLE hashWithSalt #-} + +instance Eq Header where + (==) = (==) `on` _hdrPayloadHash + +instance Ord Header where + compare = compare `on` (\h -> (_hdrNumber h, _hdrPayloadHash h)) + +instance IsCasValue Header where + type CasKeyType Header = BlockPayloadHash + casKey = _hdrPayloadHash + {-# INLINE casKey #-} + +type HeaderCas tbl = Cas tbl Header + +_hdrHeight :: Header -> Chainweb.BlockHeight +_hdrHeight = numberToHeight . _hdrNumber + +instance Hashable BlockHash where + hashWithSalt s h = let BlockHash r = h in hashWithSalt s r + {-# INLINEABLE hashWithSalt #-} + +-- -------------------------------------------------------------------------- -- +-- Internal Block Hash Computation + +-- | Does not force _hdrHash or _hdrPayloadHash +-- +computeBlockHash :: Header -> BlockHash +computeBlockHash = BlockHash . keccak256 . putRlpByteString +{-# INLINE computeBlockHash #-} + +-- | Does not force _hdrHash or _hdrPayloadHash +-- +computeBlockPayloadHash :: Header -> BlockPayloadHash +computeBlockPayloadHash h = BlockPayloadHash $ MerkleLogHash $ computeMerkleLogRoot h +{-# INLINE computeBlockPayloadHash #-} + +-- -------------------------------------------------------------------------- -- +-- Merkle Proofs +-- +-- Example: +-- +-- ghci> Just p = headerProof @BlockNumber hdr +-- ghci> runHeaderProof p == blockPayloadHash hdr +-- True +-- ghci> proofSubject @_ @_ @BlockNumber p +-- BlockNumber 6373 + +-- | Creates a Merkle proof for a header property of an EVM execution header. +-- +headerProof + :: forall c a m + . MonadThrow m + => a ~ ChainwebMerkleHashAlgorithm + => HasHeader a ChainwebHashTag c (MkLogType a ChainwebHashTag Header) + => Header + -> m (V2.MerkleProof a) +headerProof = headerProofV2 @c +{-# INLINE headerProof #-} + +-- | Runs a header proof. Returns the BlockPayloadHash of the EVM execution +-- header for which inclusion is proven. +-- +runHeaderProof :: V2.MerkleProof ChainwebMerkleHashAlgorithm -> BlockPayloadHash +runHeaderProof = BlockPayloadHash . MerkleLogHash . V2.runProof +{-# INLINE runHeaderProof #-} + +-- -------------------------------------------------------------------------- -- +-- Constant Values after Paris Hardfork + +-- | Since the Paris Hardfork the nonce is KEC(RLP(())) +-- +-- [cf. 4.4.4 (57)](https://ethereum.github.io/yellowpaper/paper.pdf) +-- +ommersHash :: OmmersHash +ommersHash = OmmersHash $ keccak256 $ putRlpByteString () +{-# INLINE ommersHash #-} + +-- | Since the Paris Hardfork the difficulty is 0. +-- +-- [cf. 4.4.4 (58)](https://ethereum.github.io/yellowpaper/paper.pdf) +-- +difficulty :: Difficulty +difficulty = Difficulty 0 +{-# INLINE difficulty #-} + +-- | Since the Paris Hardfork the nonce is 0x0000000000000000. +-- +-- [cf. 4.4.4 (59)](https://ethereum.github.io/yellowpaper/paper.pdf) +-- +nonce :: Nonce +nonce = Nonce $ replicateN 0 +{-# INLINE nonce #-} + +-- -------------------------------------------------------------------------- -- +-- JSON Serialization + +-- | These are the property names of the respective RPC API properties +-- +-- The JSON serialization also includes the block hash. +-- +headerProperties :: KeyValue e kv => Header -> [kv] +headerProperties o = + [ "parentHash" .= _hdrParentHash o + , "sha3Uncles" .= _hdrOmmersHash o + , "miner" .= _hdrBeneficiary o + , "stateRoot" .= _hdrStateRoot o + , "transactionsRoot" .= _hdrTransactionsRoot o + , "receiptsRoot" .= _hdrReceiptsRoot o + , "logsBloom" .= _hdrLogsBloom o + , "difficulty" .= _hdrDifficulty o + , "number" .= _hdrNumber o + , "gasLimit" .= _hdrGasLimit o + , "gasUsed" .= _hdrGasUsed o + , "timestamp" .= _hdrTimestamp o + , "extraData" .= _hdrExtraData o + , "mixHash" .= _hdrPrevRandao o -- legacy property name for prev randao + , "nonce" .= _hdrNonce o + , "baseFeePerGas" .= _hdrBaseFeePerGas o + , "withdrawalsRoot" .= _hdrWithdrawalsRoot o + , "blobGasUsed" .= _hdrBlobGasUsed o + , "excessBlobGas" .= _hdrExcessBlobGas o + , "parentBeaconBlockRoot" .= _hdrParentBeaconBlockRoot o + , "requestsHash" .= _hdrRequestsHash o + , "hash" .= _hdrHash o + ] +{-# INLINE headerProperties #-} +{-# SPECIALIZE headerProperties :: Header -> [Series] #-} +{-# SPECIALIZE headerProperties :: Header -> [Pair] #-} + +instance ToJSON Header where + toEncoding = pairs . mconcat . headerProperties + toJSON = object . headerProperties + {-# INLINE toEncoding #-} + {-# INLINE toJSON #-} + +instance FromJSON Header where + parseJSON v = do + hdr <- flip (withObject "ConsensusHeader") v $ \o -> Header + <$> o .: "parentHash" + <*> o .: "sha3Uncles" + <*> o .: "miner" + <*> o .: "stateRoot" + <*> o .: "transactionsRoot" + <*> o .: "receiptsRoot" + <*> o .: "logsBloom" + <*> o .: "difficulty" + <*> o .: "number" + <*> o .: "gasLimit" + <*> o .: "gasUsed" + <*> o .: "timestamp" + <*> o .: "extraData" + <*> o .: "mixHash" -- legacy property name for prev randao + <*> o .: "nonce" + <*> o .: "baseFeePerGas" + <*> o .: "withdrawalsRoot" + <*> o .: "blobGasUsed" + <*> o .: "excessBlobGas" + <*> o .: "parentBeaconBlockRoot" + <*> o .: "requestsHash" + <*> pure (error "Chainweb.PayloadProvider.EVM.Header: attempt to force _hdrHash JSON during deserialization") + <*> pure (error "Chainweb.PayloadProvider.EVM.Header: attempt to force _hdrPayloadHash JSON during deserialization") + return hdr + { _hdrHash = computeBlockHash hdr + , _hdrPayloadHash = computeBlockPayloadHash hdr + } + {-# INLINE parseJSON #-} + +-- -------------------------------------------------------------------------- -- +-- Serialization + +-- | RLP Encoding for Execution Layer Header +-- +-- For the specification up to the Shanghai Hardfork see: +-- +-- [cf. Yellow Paper 4.4.3 (44)](https://ethereum.github.io/yellowpaper/paper.pdf) +-- +-- LH(H) ≡ (Hp,Ho,Hc,Hr,Ht,He,Hb,Hd,Hi,Hl,Hg,Hs,Hx,Ha,Hn,Hf,Hw) +-- +instance RLP Header where + putRlp hdr = putRlpL + [ putRlp $ _hdrParentHash hdr + , putRlp $ _hdrOmmersHash hdr + , putRlp $ _hdrBeneficiary hdr + , putRlp $ _hdrStateRoot hdr + , putRlp $ _hdrTransactionsRoot hdr + , putRlp $ _hdrReceiptsRoot hdr + , putRlp $ _hdrLogsBloom hdr + , putRlp $ _hdrDifficulty hdr + , putRlp $ _hdrNumber hdr + , putRlp $ _hdrGasLimit hdr + , putRlp $ _hdrGasUsed hdr + , putRlp $ _hdrTimestamp hdr + , putRlp $ _hdrExtraData hdr + , putRlp $ _hdrPrevRandao hdr + , putRlp $ _hdrNonce hdr + , putRlp $ _hdrBaseFeePerGas hdr + , putRlp $ _hdrWithdrawalsRoot hdr + + -- Cancun Hardfork + , putRlp $ _hdrBlobGasUsed hdr + , putRlp $ _hdrExcessBlobGas hdr + , putRlp $ _hdrParentBeaconBlockRoot hdr + + -- Pectra Hardfork + , putRlp $ _hdrRequestsHash hdr + ] + + getRlp = label "Header" $ do + hdr <- getRlpL $ Header + <$> getRlp -- parent hash + <*> getRlp -- ommers hash + <*> getRlp -- beneficiary + <*> getRlp -- state root + <*> getRlp -- transactions root + <*> getRlp -- receipts root + <*> getRlp -- logs bloom + <*> getRlp -- difficulty + <*> getRlp -- number + <*> getRlp -- gas limit + <*> getRlp -- gas used + <*> getRlp -- timestamp + <*> getRlp -- extra data + <*> getRlp -- prev randao + <*> getRlp -- nonce + <*> getRlp -- base fee per gas + <*> getRlp -- withdrawals root + + -- Cancun Hardfork + <*> getRlp -- blob gas used + <*> getRlp -- excess blob gas + <*> getRlp -- parent beacon block root + + -- Pectra Hardfork + <*> getRlp -- requests hash + + <*> pure (error "Chainweb.PayloadProvider.EVM.Header: attempt to force _hdrHash during RLP deserialization") + <*> pure (error "Chainweb.PayloadProvider.EVM.Header: attempt to force _hdrPayloadHash during RLP deserialization") + return hdr + { _hdrHash = computeBlockHash hdr + , _hdrPayloadHash = computeBlockPayloadHash hdr + } + + {-# INLINE putRlp #-} + {-# INLINE getRlp #-} + +-- -------------------------------------------------------------------------- -- +-- MerkleLog Entries + +deriving via (RlpMerkleLogEntry 'EthParentHashTag ParentHash) + instance MerkleHashAlgorithm a => IsMerkleLogEntry a ChainwebHashTag ParentHash + +deriving via (RlpMerkleLogEntry 'EthOmmersHashTag OmmersHash) + instance MerkleHashAlgorithm a => IsMerkleLogEntry a ChainwebHashTag OmmersHash + +deriving via (RlpMerkleLogEntry 'EthBeneficiaryTag Beneficiary) + instance MerkleHashAlgorithm a => IsMerkleLogEntry a ChainwebHashTag Beneficiary + +deriving via (RlpMerkleLogEntry 'EthStateRootTag StateRoot) + instance MerkleHashAlgorithm a => IsMerkleLogEntry a ChainwebHashTag StateRoot + +deriving via (RlpMerkleLogEntry 'EthTransactionsRootTag TransactionsRoot) + instance MerkleHashAlgorithm a => IsMerkleLogEntry a ChainwebHashTag TransactionsRoot + +deriving via (RlpMerkleLogEntry 'EthBloomTag Bloom) + instance MerkleHashAlgorithm a => IsMerkleLogEntry a ChainwebHashTag Bloom + +deriving via (RlpMerkleLogEntry 'EthDifficultyTag Difficulty) + instance MerkleHashAlgorithm a => IsMerkleLogEntry a ChainwebHashTag Difficulty + +deriving via (RlpMerkleLogEntry 'EthBlockNumberTag BlockNumber) + instance MerkleHashAlgorithm a => IsMerkleLogEntry a ChainwebHashTag BlockNumber + +deriving via (RlpMerkleLogEntry 'EthGasLimitTag GasLimit) + instance MerkleHashAlgorithm a => IsMerkleLogEntry a ChainwebHashTag GasLimit + +deriving via (RlpMerkleLogEntry 'EthGasUsedTag GasUsed) + instance MerkleHashAlgorithm a => IsMerkleLogEntry a ChainwebHashTag GasUsed + +deriving via (RlpMerkleLogEntry 'EthTimestampTag Timestamp) + instance MerkleHashAlgorithm a => IsMerkleLogEntry a ChainwebHashTag Timestamp + +deriving via (RlpMerkleLogEntry 'EthExtraDataTag ExtraData) + instance MerkleHashAlgorithm a => IsMerkleLogEntry a ChainwebHashTag ExtraData + +deriving via (RlpMerkleLogEntry 'EthRandaoTag Randao) + instance MerkleHashAlgorithm a => IsMerkleLogEntry a ChainwebHashTag Randao + +deriving via (RlpMerkleLogEntry 'EthNonceTag Nonce) + instance MerkleHashAlgorithm a => IsMerkleLogEntry a ChainwebHashTag Nonce + +deriving via (RlpMerkleLogEntry 'EthBaseFeePerGasTag BaseFeePerGas) + instance MerkleHashAlgorithm a => IsMerkleLogEntry a ChainwebHashTag BaseFeePerGas + +deriving via (RlpMerkleLogEntry 'EthWithdrawalsRootTag WithdrawalsRoot) + instance MerkleHashAlgorithm a => IsMerkleLogEntry a ChainwebHashTag WithdrawalsRoot + +deriving via (RlpMerkleLogEntry 'EthBlobGasUsedTag BlobGasUsed) + instance MerkleHashAlgorithm a => IsMerkleLogEntry a ChainwebHashTag BlobGasUsed + +deriving via (RlpMerkleLogEntry 'EthExcessBlobGasTag ExcessBlobGas) + instance MerkleHashAlgorithm a => IsMerkleLogEntry a ChainwebHashTag ExcessBlobGas + +deriving via (RlpMerkleLogEntry 'EthParentBeaconBlockRootTag ParentBeaconBlockRoot) + instance MerkleHashAlgorithm a => IsMerkleLogEntry a ChainwebHashTag ParentBeaconBlockRoot + +deriving via (RlpMerkleLogEntry 'EthRequestsHashTag RequestsHash) + instance MerkleHashAlgorithm a => IsMerkleLogEntry a ChainwebHashTag RequestsHash + +-- -------------------------------------------------------------------------- -- +-- MerkleLog Instance + +instance HasMerkleLog ChainwebMerkleHashAlgorithm ChainwebHashTag Header where + + -- /IMPORTANT/ a types must occur at most once in this list + type MerkleLogHeader Header = + '[ ParentHash + , OmmersHash + , Beneficiary + , StateRoot + , TransactionsRoot + , ReceiptsRoot + , Bloom + , Difficulty + , BlockNumber + , GasLimit + , GasUsed + , Timestamp + , ExtraData + , Randao + , Nonce + , BaseFeePerGas + , WithdrawalsRoot + , BlobGasUsed + , ExcessBlobGas + , ParentBeaconBlockRoot + , RequestsHash + ] + type MerkleLogBody Header = Void + + toLog h = newMerkleLog @ChainwebMerkleHashAlgorithm entries + where + entries + = _hdrParentHash h + :+: _hdrOmmersHash h + :+: _hdrBeneficiary h + :+: _hdrStateRoot h + :+: _hdrTransactionsRoot h + :+: _hdrReceiptsRoot h + :+: _hdrLogsBloom h + :+: _hdrDifficulty h + :+: _hdrNumber h + :+: _hdrGasLimit h + :+: _hdrGasUsed h + :+: _hdrTimestamp h + :+: _hdrExtraData h + :+: _hdrPrevRandao h + :+: _hdrNonce h + :+: _hdrBaseFeePerGas h + :+: _hdrWithdrawalsRoot h + :+: _hdrBlobGasUsed h + :+: _hdrExcessBlobGas h + :+: _hdrParentBeaconBlockRoot h + :+: _hdrRequestsHash h + :+: emptyBody + + fromLog l = hdr + { _hdrHash = computeBlockHash hdr + , _hdrPayloadHash = computeBlockPayloadHash hdr + } + where + hdr = Header + { _hdrParentHash = hParentHash + , _hdrOmmersHash = hOmmersHash + , _hdrBeneficiary = hBeneficiary + , _hdrStateRoot = hStateRoot + , _hdrTransactionsRoot = hTransactionsRoot + , _hdrReceiptsRoot = hReceiptsRoot + , _hdrLogsBloom = hLogsBloom + , _hdrDifficulty = hDifficulty + , _hdrNumber = hNumber + , _hdrGasLimit = hGasLimit + , _hdrGasUsed = hGasUsed + , _hdrTimestamp = hTimestamp + , _hdrExtraData = hExtraData + , _hdrPrevRandao = hPrevRandao + , _hdrNonce = hNonce + , _hdrBaseFeePerGas = hBaseFeePerGas + , _hdrWithdrawalsRoot = hWithdrawalsRoot + , _hdrBlobGasUsed = hBlobGasUsed + , _hdrExcessBlobGas = hExcessBlobGas + , _hdrParentBeaconBlockRoot = hParentBeaconBlockRoot + , _hdrRequestsHash = hRequestsHash + , _hdrHash = error "Chainweb.PayloadProvider.EVM.Header: attempt to force _hdrHash during MerkleLog deserialization" + , _hdrPayloadHash = error "Chainweb.PayloadProvider.EVM.Header: attempt to force _hdrPayloadHash during MerkleLog deserialization" + } + ( hParentHash + :+: hOmmersHash + :+: hBeneficiary + :+: hStateRoot + :+: hTransactionsRoot + :+: hReceiptsRoot + :+: hLogsBloom + :+: hDifficulty + :+: hNumber + :+: hGasLimit + :+: hGasUsed + :+: hTimestamp + :+: hExtraData + :+: hPrevRandao + :+: hNonce + :+: hBaseFeePerGas + :+: hWithdrawalsRoot + :+: hBlobGasUsed + :+: hExcessBlobGas + :+: hParentBeaconBlockRoot + :+: hRequestsHash + :+: _ + ) = _merkleLogEntries l + +-- -------------------------------------------------------------------------- -- +-- Getter + +hdrParentHash :: Getter Header ParentHash +hdrParentHash = to _hdrParentHash + +hdrOmmersHash :: Getter Header OmmersHash +hdrOmmersHash = to _hdrOmmersHash + +hdrBeneficiary :: Getter Header Beneficiary +hdrBeneficiary = to _hdrBeneficiary + +hdrStateRoot :: Getter Header StateRoot +hdrStateRoot = to _hdrStateRoot + +hdrTransactionsRoot :: Getter Header TransactionsRoot +hdrTransactionsRoot = to _hdrTransactionsRoot + +hdrReceiptsRoot :: Getter Header ReceiptsRoot +hdrReceiptsRoot = to _hdrReceiptsRoot + +hdrLogsBloom :: Getter Header Bloom +hdrLogsBloom = to _hdrLogsBloom + +hdrDifficulty :: Getter Header Difficulty +hdrDifficulty = to _hdrDifficulty + +hdrNumber :: Getter Header BlockNumber +hdrNumber = to _hdrNumber + +hdrGasLimit :: Getter Header GasLimit +hdrGasLimit = to _hdrGasLimit + +hdrGasUsed :: Getter Header GasUsed +hdrGasUsed = to _hdrGasUsed + +hdrTimestamp :: Getter Header Timestamp +hdrTimestamp = to _hdrTimestamp + +hdrExtraData :: Getter Header ExtraData +hdrExtraData = to _hdrExtraData + +hdrPrevRandao :: Getter Header Randao +hdrPrevRandao = to _hdrPrevRandao + +hdrNonce :: Getter Header Nonce +hdrNonce = to _hdrNonce + +hdrBaseFeePerGas :: Getter Header BaseFeePerGas +hdrBaseFeePerGas = to _hdrBaseFeePerGas + +hdrWithdrawalsRoot :: Getter Header WithdrawalsRoot +hdrWithdrawalsRoot = to _hdrWithdrawalsRoot + +hdrHeight :: Getter Header Chainweb.BlockHeight +hdrHeight = to _hdrHeight + +hdrBlobGasUsed :: Getter Header BlobGasUsed +hdrBlobGasUsed = to _hdrBlobGasUsed + +hdrExcessBlobGas :: Getter Header ExcessBlobGas +hdrExcessBlobGas = to _hdrExcessBlobGas + +hdrParentBeaconBlockRoot :: Getter Header ParentBeaconBlockRoot +hdrParentBeaconBlockRoot = to _hdrParentBeaconBlockRoot + +hdrRequestsHash :: Getter Header RequestsHash +hdrRequestsHash = to _hdrRequestsHash + +hdrHash :: Getter Header BlockHash +hdrHash = to _hdrHash + +hdrPayloadHash :: Getter Header BlockPayloadHash +hdrPayloadHash = to _hdrPayloadHash diff --git a/src/Chainweb/PayloadProvider/EVM/HeaderDB.hs b/src/Chainweb/PayloadProvider/EVM/HeaderDB.hs new file mode 100644 index 0000000000..4363d7c021 --- /dev/null +++ b/src/Chainweb/PayloadProvider/EVM/HeaderDB.hs @@ -0,0 +1,282 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuantifiedConstraints #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +-- | +-- Module: Chainweb.PayloadProvider.EVM.HeaderDB +-- Copyright: Copyright © 2024 Kadena LLC. +-- License: MIT +-- Maintainer: Lars Kuhtz +-- Stability: experimental +-- +-- FIXME: this module is very similar to the respective module for the minimal +-- payload provider. Maybe we can unify both? +-- +module Chainweb.PayloadProvider.EVM.HeaderDB +( +-- * EVM Header DB + Configuration(..) +, configuration +, type HeaderDb +, HeaderDb_(..) +, initHeaderDb +, closeHeaderDb +, withHeaderDb + +, type RankedHeaderCas + +-- * Insertion +, insertHeaderDb +, unsafeInsertHeaderDb + +-- * Internal Types +, RankedHeader(..) +, BlockRank(..) +, encodeRankedHeader +, decodeRankedHeader +) where + +import Chainweb.BlockHeight +import Chainweb.BlockPayloadHash +import Chainweb.ChainId +import Chainweb.MerkleUniverse +import Chainweb.PayloadProvider.EVM.Header +import Chainweb.Storage.Table +import Chainweb.Storage.Table.RocksDB +import Chainweb.Utils hiding (Codec) +import Chainweb.Utils.Serialization +import Chainweb.Version +import Control.DeepSeq +import Control.Lens hiding (children) +import Control.Monad +import Control.Monad.Catch +import Data.Aeson +import Data.ByteString qualified as B +import Data.Function +import Data.Hashable +import Data.Text.Encoding qualified as T +import Ethereum.RLP +import GHC.Generics +import Numeric.Additive +import Prelude hiding (lookup) +import GHC.Stack +import Chainweb.PayloadProvider.EVM.Utils (decodeRlpM) + +-- -------------------------------------------------------------------------- -- +-- Exceptions + +-- type HeaderNotFoundException = HeaderNotFoundException_ ChainwebMerkleHashAlgorithm +-- +-- newtype HeaderNotFoundException_ a = HeaderNotFoundException (BlockPayloadHash_ a) +-- deriving (Show, Eq, Ord, Generic) +-- deriving anyclass (NFData, Hashable) +-- +-- instance Exception HeaderNotFoundException + +-- -------------------------------------------------------------------------- -- +-- | Configuration of the EVM Header DB. +-- + +data Configuration = Configuration + { _configChainId :: ChainId + , _configGenesis :: !Header + , _configRocksDb :: !RocksDb + } + +configuration + :: HasCallStack + => HasVersion + => HasChainId c + => c + -> RocksDb + -> Header + -> Configuration +configuration c rdb gen + | not isEvmProvider = + error "Chainweb.PayloadProvider.Evm.HeaderDB.configuration: chain does not use evm provider" + | otherwise = Configuration + { _configChainId = _chainId c + , _configRocksDb = rdb + , _configGenesis = gen + } + where + isEvmProvider = case payloadProviderTypeForChain c of + EvmProvider{} -> True + _ -> False + +instance HasChainId Configuration where + _chainId = _configChainId + +-- -------------------------------------------------------------------------- -- +-- Ranked Block Header (only used internally) + +newtype RankedHeader = RankedHeader { _getRankedHeader :: Header } + deriving (Show, Generic) + deriving newtype (Eq, Ord, Hashable, ToJSON, FromJSON, RLP) + +instance IsCasValue RankedHeader where + type CasKeyType RankedHeader = RankedBlockPayloadHash + casKey (RankedHeader bh) + = RankedBlockPayloadHash (view hdrHeight bh) (view hdrPayloadHash bh) + {-# INLINE casKey #-} + +type RankedHeaderCas tbl = Cas tbl RankedHeader + +-- -------------------------------------------------------------------------- -- +-- BlockRank (only used internally) + +newtype BlockRank = BlockRank { _getBlockRank :: BlockHeight } + deriving (Show, Generic) + deriving anyclass (NFData) + deriving newtype + ( Eq, Ord, Hashable, ToJSON, FromJSON + , AdditiveSemigroup, AdditiveAbelianSemigroup, AdditiveMonoid + , Num, Integral, Real, Enum + ) + +-- -------------------------------------------------------------------------- -- +-- Internal + +encodeRankedHeader :: RankedHeader -> B.ByteString +encodeRankedHeader = putRlpByteString . _getRankedHeader +{-# INLINE encodeRankedHeader #-} + +decodeRankedHeader :: MonadThrow m => B.ByteString -> m RankedHeader +decodeRankedHeader = decodeRlpM +{-# INLINE decodeRankedHeader #-} + +-- -------------------------------------------------------------------------- -- +-- Header DB + +type HeaderDb tbl = HeaderDb_ ChainwebMerkleHashAlgorithm tbl + +data HeaderDb_ a tbl = HeaderDb + { _headerDbChainId :: !ChainId + , _headerDbTable :: !(tbl RankedBlockPayloadHash RankedHeader) + } + +instance HasChainId (HeaderDb_ a tbl) where + _chainId = _headerDbChainId + {-# INLINE _chainId #-} + +instance ReadableTable1 tbl => ReadableTable (HeaderDb_ a tbl) RankedBlockPayloadHash Header where + tableLookup db k = fmap _getRankedHeader <$> tableLookup (_headerDbTable db) k + {-# INLINE tableLookup #-} + +instance Table1 tbl => Table (HeaderDb_ a tbl) RankedBlockPayloadHash Header where + tableInsert db k v = tableInsert (_headerDbTable db) k (RankedHeader v) + tableDelete db k = tableDelete @_ @_ @RankedHeader (_headerDbTable db) k + {-# INLINE tableInsert #-} + {-# INLINE tableDelete #-} + +-- -------------------------------------------------------------------------- -- +-- Initialization + +-- | Initialize a database handle +-- +initHeaderDb :: Configuration -> IO (HeaderDb_ a RocksDbTable) +initHeaderDb config = do + dbAddChecked db (_configGenesis config) + return db + where + cid = _configChainId config + cidNs = T.encodeUtf8 (toText cid) + + headerTable = newTable + (_configRocksDb config) + (Codec encodeRankedHeader decodeRankedHeader) + (Codec (runPutS . encodeRankedBlockPayloadHash) (runGetS decodeRankedBlockPayloadHash)) + ["EvmHeader", cidNs, "header"] + + !db = HeaderDb + { _headerDbChainId = cid + , _headerDbTable = headerTable + } + +-- | Close a database handle and release all resources +-- +closeHeaderDb :: HeaderDb_ a tbl -> IO () +closeHeaderDb _ = return () + +withHeaderDb + :: RocksDb + -> ChainId + -> Header + -> (HeaderDb_ a RocksDbTable -> IO b) + -> IO b +withHeaderDb db cid genesisHeader = bracket start closeHeaderDb + where + start = initHeaderDb Configuration + { _configChainId = cid + , _configGenesis = genesisHeader + , _configRocksDb = db + } + +-- -------------------------------------------------------------------------- -- +-- Validated Header + +-- NOTE: the constructor of this type is intentionally NOT exported. Value of +-- this type must be only created via functions from this module. +-- +newtype ValidatedHeader = ValidatedHeader Header + deriving (Show, Eq, Generic) + +_validatedHeader :: ValidatedHeader -> Header +_validatedHeader (ValidatedHeader h) = h +{-# INLINE _validatedHeader #-} + +-- -------------------------------------------------------------------------- -- +-- Insertions + +insertHeaderDb :: Table1 tbl => HeaderDb_ a tbl -> ValidatedHeader -> IO () +insertHeaderDb db = dbAddChecked db . _validatedHeader +{-# INLINE insertHeaderDb #-} + +unsafeInsertHeaderDb :: Table1 tbl => HeaderDb_ a tbl -> Header -> IO () +unsafeInsertHeaderDb = dbAddChecked +{-# INLINE unsafeInsertHeaderDb #-} + +-- -------------------------------------------------------------------------- -- +-- Insert +-- +-- Only functions in this section are allowed to modify values of the Db type. + +-- | A a new entry to the database +-- +-- Updates all indices. +-- +dbAddChecked + :: Table1 tbl -- Cas (tbl RankedBlockPayloadHash Header) Header + => HeaderDb_ a tbl + -> Header + -> IO () +dbAddChecked db e = + unlessM (tableMember db ek) dbAddCheckedInternal + where + ek = RankedBlockPayloadHash (int $ _hdrNumber e) (view hdrPayloadHash e) + + -- Internal helper methods + + -- TODO add validation and check that parent exists (except for height 0). + + -- | Unchecked addition + -- + -- ASSUMES that + -- + -- * Item is not yet in database + -- + dbAddCheckedInternal = casInsert (_headerDbTable db) (RankedHeader e) diff --git a/src/Chainweb/PayloadProvider/EVM/JsonRPC.hs b/src/Chainweb/PayloadProvider/EVM/JsonRPC.hs new file mode 100644 index 0000000000..57640ba678 --- /dev/null +++ b/src/Chainweb/PayloadProvider/EVM/JsonRPC.hs @@ -0,0 +1,377 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE LambdaCase #-} + +-- | +-- Module: Chainweb.PayloadProvider.EVM.JsonRPC +-- Copyright: Copyright © 2024 Kadena LLC. +-- License: MIT +-- Maintainer: Lars Kuhtz +-- Stability: experimental +-- +-- JSON RPC 2.0 over HTTP +-- +-- This is a simplified implementation of JSON RPC 2.0 for use with the +-- Ethereum JSON RPC API. It does not support all features of general JSON RPC. +-- In particular this implementation does not support "Notifications". +-- +-- For the full JSON RPC 2.0 specification see: +-- https://www.jsonrpc.org/specification +-- For the Ethereum JSON RPC API see: +-- https://ethereum.org/en/developers/docs/apis/json-rpc/ +-- +module Chainweb.PayloadProvider.EVM.JsonRPC +( Message(..) +, UnknownErrorCodeException(..) +, HasErrorCode(..) +, ErrorCode(..) +, Error(..) +, Response(..) +, JsonRpcMethodConstraint +, JsonRpcMethod(..) +, type JsonRpcResponse +, type JsonRpcMessage +, JsonRpcHttpCtx(..) +, methodText +, callMethodHttp +) where + +import Control.DeepSeq (NFData) +import Control.Monad +import Control.Monad.Catch + +import Data.Aeson hiding (Error) +import Data.Kind +import Data.Text qualified as T + +import Ethereum.Utils + +import GHC.Generics (Generic) +import GHC.TypeLits +import qualified Network.HTTP.Client as HTTP +import qualified Network.HTTP.Types as HTTP +import qualified Data.ByteString.Lazy as BL +import Chainweb.Utils (EncodingException(DecodeException), encodeB64UrlNoPaddingText) +import Data.Typeable (Typeable) +import System.Random (randomRIO) +import Network.URI +import qualified Data.Text.Encoding as T +import Control.Applicative + +-- -------------------------------------------------------------------------- -- +-- JSON RPC 2.0 Message + +-- | JSON RPC 2.0 Message for use with the Ethereum JSON RPC API. +-- +-- A rpc call is represented by sending a Request object to a Server. +-- +-- The type parameter must be an instance of 'ToJSON' and 'FromJSON'. For the +-- generic case 'Value' can be used. If the value is supposed to be omitted the +-- type 'Maybe Void' can be used. An empty parameter list can be represented as +-- '()'. An option value can be represented as 'Maybe a'. +-- +data Message v = Message + { _messageId :: !(Maybe Natural) + -- ^ An identifier established by the Client that MUST contain a String, + -- Number, or NULL value if included. If it is not included it is + -- assumed to be a notification. The value SHOULD normally not be Null + -- and Numbers SHOULD NOT contain fractional parts. + -- + -- A Notification is a Request object without an "id" member. A Request + -- object that is a Notification signifies the Client's lack of interest + -- in the corresponding Response object, and as such no Response object + -- needs to be returned to the client. The Server MUST NOT reply to a + -- Notification, including those that are within a batch request. + , _messageMethod :: !T.Text + -- ^ A String containing the name of the method to be invoked. Method + -- names that begin with the word rpc followed by a period character + -- (U+002E or ASCII 46) are reserved for rpc-internal methods and + -- extensions and MUST NOT be used for anything else. + , _messageParams :: !v + -- ^ A Structured value that holds the parameter values to be used + -- during the invocation of the method. This member MAY be omitted. + } + deriving (Show, Eq, Generic) + deriving anyclass (NFData) + +instance ToJSON v => ToJSON (Message v) where + toEncoding o = pairs + $ "jsonrpc" .= ("2.0" :: T.Text) + <> "id" .= _messageId o + <> "method" .= _messageMethod o + <> "params" .= _messageParams o + {-# INLINE toEncoding #-} + + toJSON o = object + [ "jsonrpc" .= ("2.0" :: T.Text) + , "id" .= _messageId o + , "method" .= _messageMethod o + , "params" .= _messageParams o + ] + {-# INLINE toJSON #-} + +instance FromJSON v => FromJSON (Message v) where + parseJSON = withObject "Message" $ \o -> do + version <- o .: "jsonrpc" >>= withText "jsonrpc" return + unless (version == "2.0") $ fail "invalid jsonrpc version" + Message + <$> o .:! "id" + <*> o .: "method" + <*> o .: "params" + {-# INLINE parseJSON #-} + +-- -------------------------------------------------------------------------- -- +-- JSON RPC 2.0 Response Errors + +newtype UnknownErrorCodeException = UnknownErrorCodeException Int + deriving (Show, Eq) + +instance Exception UnknownErrorCodeException + +-- | JSON RPC 2.0 Error Codes +-- +-- The first type parameter is the type of server errors. The second type is the +-- type of application errors. For the generic case 'Int' can be used for both +-- parameters. +-- +data ErrorCode s a + = ParseError + | InvalidRequest + | MethodNotFound + | InvalidParams + | InternalError + | ServerError s + | ApplicationError a + deriving (Show, Eq, Generic) + deriving anyclass (NFData) + +class HasErrorCode e where + toErrorCode :: e -> Int + fromErrorCode :: MonadThrow m => Int -> m e + +instance HasErrorCode Int where + toErrorCode = id + fromErrorCode = return + {-# INLINE toErrorCode #-} + {-# INLINE fromErrorCode #-} + +instance (HasErrorCode s, HasErrorCode a) => HasErrorCode (ErrorCode s a) where + toErrorCode ParseError = -32700 + toErrorCode InvalidRequest = -32600 + toErrorCode MethodNotFound = -32601 + toErrorCode InvalidParams = -32602 + toErrorCode InternalError = -32603 + toErrorCode (ServerError s) = toErrorCode s + toErrorCode (ApplicationError a) = toErrorCode a + fromErrorCode (-32700) = return ParseError + fromErrorCode (-32600) = return InvalidRequest + fromErrorCode (-32601) = return MethodNotFound + fromErrorCode (-32602) = return InvalidParams + fromErrorCode (-32603) = return InternalError + fromErrorCode n + | (-32099) <= n && n <= (-32000) = ServerError <$> fromErrorCode n + | otherwise = ApplicationError <$> fromErrorCode n + {-# INLINE toErrorCode #-} + {-# INLINE fromErrorCode #-} + +instance (HasErrorCode s, HasErrorCode a) => ToJSON (ErrorCode s a) where + toEncoding = toEncoding . toErrorCode + toJSON = toJSON . toErrorCode + {-# INLINE toEncoding #-} + {-# INLINE toJSON #-} + +instance (HasErrorCode s, HasErrorCode a) => FromJSON (ErrorCode s a) where + parseJSON = withScientific "ErrorCode" $ \n -> do + n' <- parseJSON @Int (Number n) + case fromErrorCode n' of + Just e -> return e + Nothing -> fail $ "unrecognized error code: " <> show n' + {-# INLINE parseJSON #-} + +data Error e a = Error + { _errorCode :: !(ErrorCode e a) + , _errorMessage :: !T.Text + , _errorData :: !(Maybe Value) + } + deriving (Show, Eq, Generic) + deriving anyclass (NFData) + +instance (Show e, Typeable e, Show a, Typeable a) => Exception (Error e a) + +instance (HasErrorCode s, HasErrorCode a) => ToJSON (Error s a) where + toEncoding o = pairs + $ "code" .= _errorCode o + <> "message" .= _errorMessage o + <> "data" .= _errorData o + {-# INLINE toEncoding #-} + + toJSON o = object + [ "code" .= _errorCode o + , "message" .= _errorMessage o + , "data" .= _errorData o + ] + {-# INLINE toJSON #-} + +instance (HasErrorCode s, HasErrorCode a) => FromJSON (Error s a) where + parseJSON = withObject "Error" $ \o -> Error + <$> o .: "code" + <*> o .: "message" + <*> o .:? "data" + {-# INLINE parseJSON #-} + +-- -------------------------------------------------------------------------- -- +-- JSON RPC 2.0 Response + +data Response s a v = Response + { _responseId :: !Int + , _responseResult :: !(Either (Error s a) v) + } + deriving (Show, Eq, Generic) + deriving anyclass (NFData) + +instance (HasErrorCode s, HasErrorCode a, ToJSON v) => ToJSON (Response s a v) where + toEncoding o = pairs + $ "jsonrpc" .= ("2.0" :: T.Text) + <> "id" .= _responseId o + <> case _responseResult o of + Left e -> "error" .= e + Right v -> "result" .= v + {-# INLINE toEncoding #-} + + toJSON o = object + [ "jsonrpc" .= ("2.0" :: T.Text) + , "id" .= _responseId o + , case _responseResult o of + Left e -> "error" .= e + Right v -> "result" .= v + ] + {-# INLINE toJSON #-} + +instance (HasErrorCode s, HasErrorCode a, FromJSON v) => FromJSON (Response s a v) where + parseJSON = withObject "Response" $ \o -> do + version <- o .: "jsonrpc" >>= withText "jsonrpc" return + unless (version == "2.0") $ fail "invalid jsonrpc version" + Response + <$> o .: "id" + <*> (parseResult o <|> parseError o) + where + parseError o = Left <$> o .: "error" + parseResult o = Right <$> o .: "result" + {-# INLINE parseJSON #-} + +-- -------------------------------------------------------------------------- -- +-- JSON RPC 2.0 Method + +type JsonRpcMethodConstraint (a :: Symbol) = + ( KnownSymbol a + , ToJSON (MethodRequest a) + , ToJSON (MethodResponse a) + , FromJSON (MethodRequest a) + , FromJSON (MethodResponse a) + , HasErrorCode (ServerErrors a) + , HasErrorCode (ApplicationErrors a) + , Show (ServerErrors a) + , Show (ApplicationErrors a) + , Typeable (ServerErrors a) + , Typeable (ApplicationErrors a) + ) + +-- | We could implement function overloading by making the request type +-- parameter of the class. +-- +class JsonRpcMethodConstraint a => JsonRpcMethod (a :: Symbol) where + type MethodRequest a :: Type + type MethodResponse a :: Type + type ServerErrors a :: Type + type ApplicationErrors a :: Type + methodErrors :: [ErrorCode (ServerErrors a) (ApplicationErrors a)] + responseTimeoutMs :: Maybe Natural + +type JsonRpcResponse m = Response (ServerErrors m) (ApplicationErrors m) (MethodResponse m) +type JsonRpcMessage m = Message (MethodRequest m) + +methodText :: forall a . JsonRpcMethod a => T.Text +methodText = T.pack $ symbolVal_ @a +{-# INLINE methodText #-} + +mkMessage + :: forall (a :: Symbol) + . JsonRpcMethod a + => Int + -> MethodRequest a + -> JsonRpcMessage a +mkMessage i p = Message + { _messageId = Just $ fromIntegral i + , _messageMethod = methodText @a + , _messageParams = p + } + +-- -------------------------------------------------------------------------- -- +-- JSON RPC Context + +data JsonRpcHttpCtx = JsonRpcHttpCtx + { _jsonRpcHttpCtxManager :: HTTP.Manager + , _jsonRpcHttpCtxURI :: URI + , _jsonRpcHttpCtxMakeBearerToken :: Maybe (IO T.Text) + } + +-- -------------------------------------------------------------------------- -- + +-- | Call a JSON RPC 2.0 method over HTTP +-- +-- FIXME: Proper Error Handling +-- +callMethodHttp + :: forall (m :: Symbol) + . JsonRpcMethod m + => JsonRpcHttpCtx + -> MethodRequest m + -> IO (MethodResponse m) +callMethodHttp ctx m = do + req_ <- HTTP.requestFromURI (_jsonRpcHttpCtxURI ctx) + mid <- randomRIO (1, maxBound) + authHeader <- sequence (_jsonRpcHttpCtxMakeBearerToken ctx) >>= \case + Nothing -> return [] + Just t -> return [("Authorization", "Bearer " <> T.encodeUtf8 t)] + let msg = encode $ mkMessage @m mid m + let req = req_ + { HTTP.method = "POST" + , HTTP.requestBody = HTTP.RequestBodyLBS msg + , HTTP.responseTimeout = timeout + , HTTP.requestHeaders = + [ ("Content-Type", "application/json") + , ("Accept", "application/json") + ] + <> authHeader + } + resp <- HTTP.httpLbs req (_jsonRpcHttpCtxManager ctx) + unless (HTTP.statusIsSuccessful $ HTTP.responseStatus resp) $ + throwM + $ HTTP.HttpExceptionRequest req + $ HTTP.StatusCodeException resp { HTTP.responseBody = () } + (BL.toStrict $ HTTP.responseBody resp) + case eitherDecode $ HTTP.responseBody resp of + Left e -> throwM $ DecodeException + $ T.pack e <> " -- " <> case T.decodeUtf8' (BL.toStrict (HTTP.responseBody resp)) of + Left _ -> "binary response body: " <> encodeB64UrlNoPaddingText (BL.toStrict $ HTTP.responseBody resp) + Right t -> "response body: " <> t + Right (Response _ r :: JsonRpcResponse m) -> case r of + Left e -> throwM e + Right v -> return v + where + timeout = case responseTimeoutMs @m of + Nothing -> HTTP.responseTimeoutDefault + Just ms -> HTTP.responseTimeoutMicro $ int $ ms * 1000 diff --git a/src/Chainweb/PayloadProvider/EVM/PayloadDB.hs b/src/Chainweb/PayloadProvider/EVM/PayloadDB.hs new file mode 100644 index 0000000000..67dbcf2068 --- /dev/null +++ b/src/Chainweb/PayloadProvider/EVM/PayloadDB.hs @@ -0,0 +1,281 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuantifiedConstraints #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +-- | +-- Module: Chainweb.PayloadProvider.EVM.PayloadDB +-- Copyright: Copyright © 2024 Kadena LLC. +-- License: MIT +-- Maintainer: Lars Kuhtz +-- Stability: experimental +-- +-- FIXME: this module is very similar to the respective module for the minimal +-- payload provider. Maybe we can unify both? +-- +module Chainweb.PayloadProvider.EVM.PayloadDB +( +-- * EVM Header DB + Configuration(..) +, configuration +, type PayloadDb +, PayloadDb_(..) +, initPayloadDb +, closePayloadDb +, withPayloadDb + +, type RankedPayloadCas + +-- * Insertion +, insertPayloadDb +, unsafeInsertPayloadDb + +-- * Internal Types +, RankedPayload(..) +, BlockRank(..) +, encodeRankedPayload +, decodeRankedPayload +) where + +import Chainweb.BlockHeight +import Chainweb.BlockPayloadHash +import Chainweb.ChainId +import Chainweb.MerkleUniverse +import Chainweb.PayloadProvider.EVM.Header +import Chainweb.Storage.Table +import Chainweb.Storage.Table.RocksDB +import Chainweb.Utils hiding (Codec) +import Chainweb.Utils.Serialization +import Chainweb.Version +import Control.DeepSeq +import Control.Lens hiding (children) +import Control.Monad +import Control.Monad.Catch +import Data.Aeson +import Data.ByteString qualified as B +import Data.Function +import Data.Hashable +import Data.Text.Encoding qualified as T +import Ethereum.RLP +import GHC.Generics +import Numeric.Additive +import Prelude hiding (lookup) +import GHC.Stack +import Chainweb.PayloadProvider.EVM.Utils (decodeRlpM) +import Chainweb.PayloadProvider.EVM.ExecutionPayload + +-- -------------------------------------------------------------------------- -- +-- Exceptions + +-- type HeaderNotFoundException = HeaderNotFoundException_ ChainwebMerkleHashAlgorithm +-- +-- newtype HeaderNotFoundException_ a = HeaderNotFoundException (BlockPayloadHash_ a) +-- deriving (Show, Eq, Ord, Generic) +-- deriving anyclass (NFData, Hashable) +-- +-- instance Exception HeaderNotFoundException + +-- -------------------------------------------------------------------------- -- +-- | Configuration of the EVM Header DB. +-- + +data Configuration = Configuration + { _configChainId :: ChainId + , _configGenesis :: !Header + , _configRocksDb :: !RocksDb + } + +configuration + :: HasCallStack + => HasVersion + => HasChainId c + => c + -> RocksDb + -> Header + -> Configuration +configuration c rdb gen + | not isEvmProvider = + error "Chainweb.PayloadProvider.Evm.HeaderDB.configuration: chain does not use evm provider" + | otherwise = Configuration + { _configChainId = _chainId c + , _configRocksDb = rdb + , _configGenesis = gen + } + where + isEvmProvider = case payloadProviderTypeForChain c of + EvmProvider{} -> True + _ -> False + +instance HasChainId Configuration where + _chainId = _configChainId + +-- -------------------------------------------------------------------------- -- +-- Ranked Block Payload (only used internally) + +newtype RankedPayload = RankedPayload { _getRankedPayload :: Payload } + deriving (Show, Generic) + deriving newtype (Eq, Ord, Hashable, ToJSON, FromJSON, RLP) + +instance IsCasValue RankedPayload where + type CasKeyType RankedPayload = RankedBlockPayloadHash + casKey (RankedPayload pld) + = RankedBlockPayloadHash (view pldHeight pld) (view pldPayloadHash pld) + {-# INLINE casKey #-} + +type RankedPayloadCas tbl = Cas tbl RankedPayload + +-- -------------------------------------------------------------------------- -- +-- BlockRank (only used internally) + +newtype BlockRank = BlockRank { _getBlockRank :: BlockHeight } + deriving (Show, Generic) + deriving anyclass (NFData) + deriving newtype + ( Eq, Ord, Hashable, ToJSON, FromJSON + , AdditiveSemigroup, AdditiveAbelianSemigroup, AdditiveMonoid + , Num, Integral, Real, Enum + ) + +-- -------------------------------------------------------------------------- -- +-- Internal + +encodeRankedPayload :: RankedPayload -> B.ByteString +encodeRankedPayload = putRlpByteString . _getRankedPayload +{-# INLINE encodeRankedPayload #-} + +decodeRankedPayload :: MonadThrow m => B.ByteString -> m RankedPayload +decodeRankedPayload = decodeRlpM +{-# INLINE decodeRankedPayload #-} + +-- -------------------------------------------------------------------------- -- +-- Header DB + +type PayloadDb tbl = PayloadDb_ ChainwebMerkleHashAlgorithm tbl + +data PayloadDb_ a tbl = PayloadDb + { _payloadDbChainId :: !ChainId + , _payloadDbTable :: !(tbl RankedBlockPayloadHash RankedPayload) + } + +instance HasChainId (PayloadDb_ a tbl) where + _chainId = _payloadDbChainId + {-# INLINE _chainId #-} + +instance ReadableTable1 tbl => ReadableTable (PayloadDb_ a tbl) RankedBlockPayloadHash Payload where + tableLookup db k = fmap _getRankedPayload <$> tableLookup (_payloadDbTable db) k + {-# INLINE tableLookup #-} + +instance Table1 tbl => Table (PayloadDb_ a tbl) RankedBlockPayloadHash Payload where + tableInsert db k v = tableInsert (_payloadDbTable db) k (RankedPayload v) + tableDelete db k = tableDelete @_ @_ @RankedPayload (_payloadDbTable db) k + {-# INLINE tableInsert #-} + {-# INLINE tableDelete #-} + +-- -------------------------------------------------------------------------- -- +-- Initialization + +-- | Initialize a database handle +-- +initPayloadDb :: Configuration -> IO (PayloadDb_ a RocksDbTable) +initPayloadDb config = do + dbAddChecked db (Payload (_configGenesis config) Nothing) + return db + where + cid = _configChainId config + cidNs = T.encodeUtf8 (toText cid) + + payloadTable = newTable + (_configRocksDb config) + (Codec encodeRankedPayload decodeRankedPayload) + (Codec (runPutS . encodeRankedBlockPayloadHash) (runGetS decodeRankedBlockPayloadHash)) + ["EvmPayload", cidNs, "payload"] + + !db = PayloadDb + { _payloadDbChainId = cid + , _payloadDbTable = payloadTable + } + +-- | Close a database handle and release all resources +-- +closePayloadDb :: PayloadDb_ a tbl -> IO () +closePayloadDb _ = return () + +withPayloadDb + :: RocksDb + -> ChainId + -> Header + -> (PayloadDb_ a RocksDbTable -> IO b) + -> IO b +withPayloadDb db cid genesisHeader = bracket start closePayloadDb + where + start = initPayloadDb Configuration + { _configChainId = cid + , _configGenesis = genesisHeader + , _configRocksDb = db + } + +-- -------------------------------------------------------------------------- -- +-- Validated Payloads + +-- NOTE: the constructor of this type is intentionally NOT exported. Value of +-- this type must be only created via functions from this module. +-- +newtype ValidatedPayload = ValidatedPayload Payload + deriving (Show, Eq, Generic) + +_validatedPayload :: ValidatedPayload -> Payload +_validatedPayload (ValidatedPayload h) = h +{-# INLINE _validatedPayload #-} + +-- -------------------------------------------------------------------------- -- +-- Insertions + +insertPayloadDb :: Table1 tbl => PayloadDb_ a tbl -> ValidatedPayload -> IO () +insertPayloadDb db = dbAddChecked db . _validatedPayload +{-# INLINE insertPayloadDb #-} + +unsafeInsertPayloadDb :: Table1 tbl => PayloadDb_ a tbl -> Payload -> IO () +unsafeInsertPayloadDb = dbAddChecked +{-# INLINE unsafeInsertPayloadDb #-} + +-- -------------------------------------------------------------------------- -- +-- Insert +-- +-- Only functions in this section are allowed to modify values of the Db type. + +-- | A a new entry to the database +-- +-- Updates all indices. +-- +dbAddChecked + :: Table1 tbl -- Cas (tbl RankedBlockPayloadHash Payload) Payload + => PayloadDb_ a tbl + -> Payload + -> IO () +dbAddChecked db e = + unlessM (tableMember db ek) dbAddCheckedInternal + where + ek = RankedBlockPayloadHash (view pldHeight e) (view pldPayloadHash e) + + -- Internal helper methods + + -- TODO add validation and check that parent exists (except for height 0). + + -- | Unchecked addition + -- + -- ASSUMES that + -- + -- * Item is not yet in database + -- + dbAddCheckedInternal = casInsert (_payloadDbTable db) (RankedPayload e) diff --git a/src/Chainweb/PayloadProvider/EVM/Receipt.hs b/src/Chainweb/PayloadProvider/EVM/Receipt.hs new file mode 100644 index 0000000000..f3d53149f1 --- /dev/null +++ b/src/Chainweb/PayloadProvider/EVM/Receipt.hs @@ -0,0 +1,597 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE UndecidableInstances #-} + +{-# OPTIONS_GHC -Wno-orphans #-} + +-- | +-- Module: Chainweb.PayloadProvider.EVM.Receipt +-- Copyright: Copyright © 2025 Kadena LLC. +-- License: MIT +-- Maintainer: Lars Kuhtz +-- Stability: experimental +-- +module Chainweb.PayloadProvider.EVM.Receipt +( LogTopic(..) +, LogData(..) +, LogEntry(..) +, RpcLogEntry(..) +, fromRpcLogEntry +, TxStatus(..) +, Receipt(..) +, ReceiptsRoot(..) +, TransactionIndex(..) +, RpcReceipt(..) +, fromRpcReceipt +, encodeReceipt +, receiptTrieProof +, rpcReceiptTrieProof +) where + +import Control.Applicative +import Chainweb.Crypto.MerkleLog +import Chainweb.MerkleUniverse +import Chainweb.PayloadProvider.EVM.Utils +import Chainweb.Utils +import Data.Aeson +import Data.Aeson.Types (Pair) +import Data.Bifunctor +import Data.ByteString qualified as B +import Ethereum.Misc +import Ethereum.RLP +import Ethereum.Trie +import Ethereum.Utils hiding (int) +import Numeric.Natural + +-- -------------------------------------------------------------------------- -- +-- Log Entry + +newtype LogTopic = LogTopic (BytesN 32) + deriving (Show, Eq) + deriving newtype (RLP) + deriving ToJSON via (HexBytes (BytesN 32)) + deriving FromJSON via (HexBytes (BytesN 32)) + +newtype LogData = LogData B.ByteString + deriving (Show, Eq) + deriving newtype (RLP) + deriving ToJSON via (HexBytes B.ByteString) + deriving FromJSON via (HexBytes B.ByteString) + +-- | LogEntry +-- +-- https://github.com/ethereum/py-evm/blob/main/eth/rlp/logs.py: +-- +-- @ +-- fields = [ +-- ("address", address), +-- ("topics", CountableList(uint32)), +-- ("data", binary) +-- ] +-- @ +-- +data LogEntry = LogEntry + { _logEntryAddress :: !Address + , _logEntryTopics :: ![LogTopic] + , _logEntryData :: !LogData + } + deriving (Show, Eq) + +instance RLP LogEntry where + putRlp a = putRlpL + [ putRlp $! _logEntryAddress a + , putRlpL $! putRlp <$> _logEntryTopics a + , putRlp $! _logEntryData a + ] + getRlp = label "LogEntry" $ getRlpL $ LogEntry + <$> label "logEntryAddress" getRlp + <*> label "logEntryTopics" getRlp + <*> label "logEntryData" getRlp + {-# INLINE putRlp #-} + {-# INLINE getRlp #-} + +instance ToJSON LogEntry where + toEncoding = pairs . mconcat . logEntryProperties + toJSON = object . logEntryProperties + {-# INLINE toEncoding #-} + {-# INLINE toJSON #-} + +instance FromJSON LogEntry where + parseJSON = withObject "LogEntry" $ \o -> LogEntry + <$> o .: "address" + <*> o .: "topics" + <*> o .: "data" + {-# INLINE parseJSON #-} + +logEntryProperties :: KeyValue e kv => LogEntry -> [kv] +logEntryProperties r = + [ "address" .= _logEntryAddress r + , "data" .= _logEntryData r + , "topics" .= _logEntryTopics r + ] +{-# INLINE logEntryProperties #-} +{-# SPECIALIZE logEntryProperties :: LogEntry -> [Series] #-} +{-# SPECIALIZE logEntryProperties :: LogEntry -> [Pair] #-} + +-- -------------------------------------------------------------------------- -- +-- JSON RPC Log Entries + +newtype TransactionIndex = TransactionIndex Natural + deriving (Show, Eq, Ord) + deriving newtype (RLP) + deriving ToJSON via (HexQuantity Natural) + deriving FromJSON via (HexQuantity Natural) + +data RpcLogEntry = RpcLogEntry + { _rpcLogEntryAddress :: !Address + -- ^ 20 Bytes - address from which this log originated. + , _rpcLogEntryTopics :: ![LogTopic] + -- ^ Array of 0 to 4 32 Bytes of indexed log arguments. (In solidity: The first topic is the + -- hash of the signature of the event (e.g. Deposit(address,bytes32,uint256)), except you + -- declared the event with the anonymous specifier.) + , _rpcLogEntryData :: !LogData + -- ^ contains one or more 32 Bytes non-indexed arguments of the log. + , _rpcLogEntryBlockHash :: !BlockHash + -- ^ 32 Bytes - hash of the block where this log was in. null when its pending. null when + -- its pending log. + , _rpcLogEntryBlockNumber :: !BlockNumber + -- ^ the block number where this log was in. null when its pending. null when its pending + -- log. + , _rpcLogEntryLogIndex :: !TransactionIndex + -- ^ integer of the log index position in the block. null when its pending log. + , _rpcLogEntryRemoved :: !Bool + -- ^ true when the log was removed, due to a chain reorganization. false if it's a valid + -- log. + , _rpcLogEntryTransactionHash :: !TransactionHash + -- ^ 32 Bytes - hash of the transactions this log was created from. null when its pending + -- log. + , _rpcLogEntryTransactionIndex :: !TransactionIndex + -- ^ integer of the transactions index position log was created from. null when its pending + -- log. + } + deriving (Eq, Show) + +fromRpcLogEntry :: RpcLogEntry -> LogEntry +fromRpcLogEntry rpc = LogEntry + { _logEntryAddress = _rpcLogEntryAddress rpc + , _logEntryTopics = _rpcLogEntryTopics rpc + , _logEntryData = _rpcLogEntryData rpc + } + +instance ToJSON RpcLogEntry where + toEncoding = pairs . mconcat . rpcLogEntryProperties + toJSON = object . rpcLogEntryProperties + {-# INLINE toEncoding #-} + {-# INLINE toJSON #-} + +instance FromJSON RpcLogEntry where + parseJSON = withObject "RpcLogEntry" $ \o -> RpcLogEntry + <$> o .: "address" + <*> o .: "topics" + <*> o .: "data" + <*> o .: "blockHash" + <*> o .: "blockNumber" + <*> o .: "logIndex" + <*> o .: "removed" + <*> o .: "transactionHash" + <*> o .: "transactionIndex" + {-# INLINE parseJSON #-} + +rpcLogEntryProperties :: KeyValue e kv => RpcLogEntry -> [kv] +rpcLogEntryProperties r = + [ "address" .= _rpcLogEntryAddress r + , "blockHash" .= _rpcLogEntryBlockHash r + , "blockNumber" .= _rpcLogEntryBlockNumber r + , "data" .= _rpcLogEntryData r + , "logIndex" .= _rpcLogEntryLogIndex r + , "removed" .= _rpcLogEntryRemoved r + , "topics" .= _rpcLogEntryTopics r + , "transactionHash" .= _rpcLogEntryTransactionHash r + , "transactionIndex" .= _rpcLogEntryTransactionIndex r + ] +{-# INLINE rpcLogEntryProperties #-} +{-# SPECIALIZE rpcLogEntryProperties :: RpcLogEntry -> [Series] #-} +{-# SPECIALIZE rpcLogEntryProperties :: RpcLogEntry -> [Pair] #-} + +-- -------------------------------------------------------------------------- -- +-- Tx Status + +newtype TxStatus = TxStatus Natural + deriving (Show, Eq) + deriving ToJSON via (HexQuantity Natural) + deriving FromJSON via (HexQuantity Natural) + +-- | This is the instance used in RLP encodings for Receipts in the Receipt +-- Merkle tree for computing the receipt root in Consensus Headers. +-- +-- The Yellow paper doesn't specify how the tx status is encoded in the +-- RLP encoding of receipts. This encoding is derived from +-- +-- +instance RLP TxStatus where + putRlp (TxStatus 1) = putRlp @B.ByteString "\x01" + putRlp (TxStatus 0) = putRlp @B.ByteString "" + putRlp x = error $ "unsupported tx status: " <> show x + + getRlp = label "TxStatus" $ getRlp @B.ByteString >>= \case + "\x01" -> return $ TxStatus 1 + "" -> return $ TxStatus 0 + x -> fail $ "unsupported tx status: " <> show x + + {-# INLINE putRlp #-} + {-# INLINE getRlp #-} + +-- -------------------------------------------------------------------------- -- +-- Transaction Type + +-- | Ethereum Transaction Types: +-- +data TransactionType + = LegacyTransaction + -- ^ Legacy Transactions. + -- + -- The RLP encoding for legacy receipts is @rlp([status, + -- cumulativeGasUsed, logsBloom, logs])@. This binary format is used as + -- value in the trie for the receipt root hash. + -- + -- cf. https://eips.ethereum.org/EIPS/eip-2718 + | Eip2930Transaction + -- ^ EIP-2930: 0x01 + -- + -- The EIP-2718 ReceiptPayload for this transaction is @rlp([status, + -- cumulativeGasUsed, logsBloom, logs])@. + -- + -- cf. https://eips.ethereum.org/EIPS/eip-2930 + | Eip1559Transaction + -- ^ EIP-1559: 0x02 + -- + -- The EIP-2718 ReceiptPayload for this transaction is @rlp([status, + -- cumulative_transaction_gas_used, logs_bloom, logs])@. + -- + -- cf. https://eips.ethereum.org/EIPS/eip-1559 + | Eip4844Transaction + -- ^ EIP-4844: 0x03 + -- + -- The EIP-2718 ReceiptPayload for this transaction is @rlp([status, + -- cumulative_transaction_gas_used, logs_bloom, logs])@. + -- + -- cf. https://eips.ethereum.org/EIPS/eip-4844 + deriving (Show, Eq, Ord, Enum, Bounded) + +instance ToJSON TransactionType where + toJSON = toJSON . HexQuantity . int @_ @Natural . fromEnum + toEncoding = toEncoding . HexQuantity . int @_ @Natural . fromEnum + {-# INLINE toJSON #-} + {-# INLINE toEncoding #-} + +instance FromJSON TransactionType where + parseJSON v = do + HexQuantity x <- parseJSON v + case (x :: Natural) of + 0x00 -> return LegacyTransaction + 0x01 -> return Eip2930Transaction + 0x02 -> return Eip1559Transaction + 0x03 -> return Eip4844Transaction + _ -> fail $ "invalid transaction type: " <> show x + {-# INLINE parseJSON #-} + +-- -------------------------------------------------------------------------- -- +-- Receipt + +-- | Receipt +-- +-- The encoding that is used in the trie for computing the receipt root hash is +-- as follows: +-- +-- https://eips.ethereum.org/EIPS/eip-2718: +-- +-- @ +-- (TransactionType || ReceiptPayload) or LegacyReceipt +-- @ +-- +-- where +-- +-- - TransactionType is a positive unsigned 8-bit number between 0 and 0x7f that +-- represents the type of the transaction +-- - ReceiptPayload is an opaque byte array whose interpretation is dependent on +-- the TransactionType and defined in future EIPs +-- - LegacyReceipt is @rlp([status, cumulativeGasUsed, logsBloom, logs])@ + +-- -------------------------------------------------------------------------- -- +-- Receipt Payload + +-- | According to EIP-2718 a ReceiptPayload is an opaque byte array whose +-- interpretation is dependent on the TransactionType and defined in future +-- EIPs. +-- +-- However, up to the Cancun fork the ReceiptPayload are the same for all +-- transaction types. +-- +data ReceiptPayload = ReceiptPayload + { _receiptPayloadStatus :: !TxStatus + -- ^ Status code of the transaction + -- + -- A non-negative integer + + , _receiptPayloadGasUsed :: !GasUsed + -- ^ Gas used in block up to and including this tx. + -- + -- A non-negative integer value + + , _receiptPayloadBloom :: !Bloom + -- ^ Bloomfilter of the logs + -- + -- A 2048 bit (256 bytes) hash value + + , _receiptPayloadLogs :: ![LogEntry] + -- ^ Logs that are created during execution of the tx + -- + -- The sequence Rl is a series of log entries + } + deriving (Show, Eq) + +-- The RLP encoding for Receipt Payloads accodring to EIP-2718, EIP-2930, +-- EIP-1559 and EIP-4844. +-- +-- @ +-- rlp([status, cumulativeGasUsed, logsBloom, logs]) +-- @ +-- +-- cf. https://eips.ethereum.org/EIPS/eip-2718: +-- +instance RLP ReceiptPayload where + putRlp r = putRlpL + [ putRlp $! _receiptPayloadStatus r + , putRlp $! _receiptPayloadGasUsed r + , putRlp $! _receiptPayloadBloom r + , putRlp $! _receiptPayloadLogs r + ] + + getRlp = label "ReceiptPayload" $ getRlpL $ ReceiptPayload + <$> getRlp -- status + <*> getRlp -- gas used + <*> getRlp -- bloom + <*> getRlp -- logs + {-# INLINE putRlp #-} + {-# INLINE getRlp #-} + +-- | Receipt +-- +data Receipt + = Receipt + { _receiptType :: !TransactionType + -- ^ Transaction type + -- + , _receiptPayload :: !ReceiptPayload + -- ^ As of the Cancun for receipts payloads are the same for all + -- transaction types. If this changes in the future, the Receipt + -- type should probably use different constructors for different + -- transaction types. + } + deriving (Show, Eq) + +-- | Status code of the transaction +-- +-- A non-negative integer +_receiptStatus :: Receipt -> TxStatus +_receiptStatus = _receiptPayloadStatus . _receiptPayload + +-- | Gas used in block up to and including this tx. +-- +-- A non-negative integer value +_receiptGasUsed :: Receipt -> GasUsed +_receiptGasUsed = _receiptPayloadGasUsed . _receiptPayload + +-- | Bloomfilter of the logs +-- +-- A 2048 bit (256 bytes) hash value +_receiptBloom :: Receipt -> Bloom +_receiptBloom = _receiptPayloadBloom . _receiptPayload + +-- | Logs that are created during execution of the tx +-- +-- The sequence Rl is a series of log entries +_receiptLogs :: Receipt -> [LogEntry] +_receiptLogs = _receiptPayloadLogs . _receiptPayload + +-- | RLP encodings of receipts are used inconsistently in different contexts +-- based on the transaction type. +-- +instance RLP Receipt where + putRlp r = case _receiptType r of + LegacyTransaction -> putRlp (_receiptPayload r) + t -> putRlp + $ B.singleton (int $ fromEnum t) + <> putByteString (putRlp (_receiptPayload r)) + + -- This is sound because the RLP encodings for a list (legacy txs) and + -- a bytestring (EIP-2718 txs) differe at the first byte. This also means + -- the first branch of the alternative fails fast. + getRlp = label "Receipt" $ getLegacyTx <|> getTx + where + getLegacyTx = label "LegacyTransaction" $ Receipt + <$> pure LegacyTransaction + <*> getRlp @ReceiptPayload + getTx = do + b <- getRlp @B.ByteString + case B.uncons b of + Just (0x01, r) -> label "Eip2930Transaction" $ Receipt + <$> pure Eip2930Transaction + <*> case get (getRlp @ReceiptPayload) r of + Left e -> fail $ "Eip2930Transaction: " <> show e + Right r' -> return r' + Just (0x02, r) -> label "Eip1559Transaction" $ Receipt + <$> pure Eip1559Transaction + <*> case get (getRlp @ReceiptPayload) r of + Left e -> fail $ "Eip2930Transaction: " <> show e + Right r' -> return r' + Just (0x03, r) -> label "Eip4844Transaction" $ Receipt + <$> pure Eip4844Transaction + <*> case get (getRlp @ReceiptPayload) r of + Left e -> fail $ "Eip2930Transaction: " <> show e + Right r' -> return r' + Just (x, _) -> fail $ + "invalid transaction type: expected 0x01, 0x02 or 0x03, but got: " <> sshow x + Nothing -> fail "invalid receipt encoding" + {-# INLINE putRlp #-} + {-# INLINE getRlp #-} + +encodeReceipt :: Receipt -> B.ByteString +encodeReceipt r = case _receiptType r of + LegacyTransaction -> putByteString $ putRlp (_receiptPayload r) + t -> B.singleton (int $ fromEnum t) <> putByteString (putRlp (_receiptPayload r)) + +-- instance ToJSON Receipt where +-- toEncoding = pairs . mconcat . receiptProperties +-- toJSON = object . receiptProperties +-- {-# INLINE toEncoding #-} +-- {-# INLINE toJSON #-} +-- +-- instance FromJSON Receipt where +-- parseJSON = withObject "Receipt" $ \o -> Receipt +-- <$> o .: "status" +-- <*> o .: "cumulativeGasUsed" +-- <*> o .: "bloom" +-- <*> o .: "logs" +-- {-# INLINE parseJSON #-} +-- +-- receiptProperties :: KeyValue e kv => Receipt -> [kv] +-- receiptProperties o = +-- [ "status" .= _receiptStatus o +-- , "cumulativeGasUsed" .= _receiptGasUsed o +-- , "bloom" .= _receiptBloom o +-- , "logs" .= _receiptLogs o +-- ] +-- {-# INLINE receiptProperties #-} +-- {-# SPECIALIZE receiptProperties :: Receipt -> [Series] #-} +-- {-# SPECIALIZE receiptProperties :: Receipt -> [Pair] #-} + +deriving via (RlpMerkleLogEntry 'EthReceiptsRootTag ReceiptsRoot) + instance MerkleHashAlgorithm a => IsMerkleLogEntry a ChainwebHashTag ReceiptsRoot + +deriving via (RlpMerkleLogEntry 'EthReceiptTag Receipt) + instance MerkleHashAlgorithm a => IsMerkleLogEntry a ChainwebHashTag Receipt + +-- -------------------------------------------------------------------------- -- +-- JSON RPC API Receipts + +data RpcReceipt = RpcReceipt + { _rpcReceiptType :: !TransactionType + -- ^ Transaction type + , _rpcReceiptGasUsed :: !GasUsed + -- ^ the amount of gas used by this specific transaction alone. + , _rpcReceiptBloom :: !Bloom + -- ^ 256 Bytes - Bloom filter for light clients to quickly retrieve related logs. + , _rpcReceiptLogs :: ![RpcLogEntry] + -- ^ Array - Array of log objects, which this transaction generated. + , _rpcReceiptStatus :: !TxStatus + -- ^ Status code of the transaction, either 1 (success) or 0 (failure) + -- + -- For pre Byzantium this is "root", 32 bytes of post-transaction stateroot + + , _rpcReceiptBlockHash :: !BlockHash + -- ^ 32 Bytes - hash of the block where this transaction was in. + , _rpcReceiptBlockNumber :: !BlockNumber + -- ^ block number where this transaction was in. + , _rpcReceiptContractAddress :: !(Maybe Address) + -- ^ 20 Bytes - the contract address created, if the transaction was a contract creation, otherwise - null. + , _rpcReceiptCumulativeGasUsed :: !GasUsed + -- ^ the total amount of gas used when this transaction was executed in the block. + , _rpcReceiptFrom :: !Address + -- ^ 20 Bytes - address of the sender. + , _rpcReceiptTo :: !(Maybe Address) + -- ^ 20 Bytes - address of the receiver. Null when the transaction is a contract creation transaction. + , _rpcReceiptTransactionHash :: !TransactionHash + -- ^ 32 Bytes - hash of the transaction. + , _rpcReceiptTransactionIndex :: !TransactionIndex + -- ^ integer of the transactions index position in the block. + } + deriving (Eq, Show) + +fromRpcReceipt :: RpcReceipt -> Receipt +fromRpcReceipt rpc = Receipt + { _receiptType = _rpcReceiptType rpc + , _receiptPayload = ReceiptPayload + { _receiptPayloadStatus = _rpcReceiptStatus rpc + -- , _receiptPayloadGasUsed = _rpcReceiptGasUsed rpc + , _receiptPayloadGasUsed = _rpcReceiptCumulativeGasUsed rpc + -- this comes as a surprise, but seems to be required for computing the correct + -- receipt root in the consensus header. + , _receiptPayloadBloom = _rpcReceiptBloom rpc + , _receiptPayloadLogs = fromRpcLogEntry <$> _rpcReceiptLogs rpc + } + } + +instance ToJSON RpcReceipt where + toEncoding = pairs . mconcat . rpcReceiptProperties + toJSON = object . rpcReceiptProperties + {-# INLINE toEncoding #-} + {-# INLINE toJSON #-} + +instance FromJSON RpcReceipt where + parseJSON = withObject "RpcReceipt" $ \o -> RpcReceipt + <$> (o .:? "type" .!= LegacyTransaction) + <*> o .: "gasUsed" + <*> o .: "logsBloom" + <*> o .: "logs" + <*> o .: "status" + <*> o .: "blockHash" + <*> o .: "blockNumber" + <*> o .: "contractAddress" + <*> o .: "cumulativeGasUsed" + <*> o .: "from" + <*> o .: "to" + <*> o .: "transactionHash" + <*> o .: "transactionIndex" + {-# INLINE parseJSON #-} + +rpcReceiptProperties :: KeyValue e kv => RpcReceipt -> [kv] +rpcReceiptProperties r = + [ "type" .= _rpcReceiptType r + , "blockHash" .= _rpcReceiptBlockHash r + , "blockNumber" .= _rpcReceiptBlockNumber r + , "contractAddress" .= _rpcReceiptContractAddress r + , "cumulativeGasUsed" .= _rpcReceiptCumulativeGasUsed r + , "from" .= _rpcReceiptFrom r + , "gasUsed" .= _rpcReceiptGasUsed r + , "logs" .= _rpcReceiptLogs r + , "logsBloom" .= _rpcReceiptBloom r + , "status" .= _rpcReceiptStatus r + , "to" .= _rpcReceiptTo r + , "transactionHash" .= _rpcReceiptTransactionHash r + , "transactionIndex" .= _rpcReceiptTransactionIndex r + ] +{-# INLINE rpcReceiptProperties #-} +{-# SPECIALIZE rpcReceiptProperties :: RpcReceipt -> [Series] #-} +{-# SPECIALIZE rpcReceiptProperties :: RpcReceipt -> [Pair] #-} + +-- -------------------------------------------------------------------------- -- +-- + +rpcReceiptTrieProof + :: [RpcReceipt] + -> TransactionIndex + -> Proof +rpcReceiptTrieProof rs = receiptTrieProof kv + where + kv = (\x -> (_rpcReceiptTransactionIndex x, fromRpcReceipt x)) <$> rs + +receiptTrieProof + :: [(TransactionIndex, Receipt)] + -- ^ block receipts + -> TransactionIndex + -> Proof +receiptTrieProof receipts idx = createProof kv (putRlpByteString idx) + where + kv = bimap putRlpByteString encodeReceipt <$> receipts diff --git a/src/Chainweb/PayloadProvider/EVM/SPV.hs b/src/Chainweb/PayloadProvider/EVM/SPV.hs new file mode 100644 index 0000000000..a716c67c61 --- /dev/null +++ b/src/Chainweb/PayloadProvider/EVM/SPV.hs @@ -0,0 +1,153 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeAbstractions #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE ScopedTypeVariables #-} + +{-# OPTIONS_GHC -Wno-orphans #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE KindSignatures #-} + +-- | +-- Module: Chainweb.PayloadProvider.EVM.SPV +-- Copyright: Copyright © 2025 Kadena LLC. +-- License: MIT +-- Maintainer: Lars Kuhtz +-- Stability: experimental +-- +module Chainweb.PayloadProvider.EVM.SPV +( XLogData(..) +, parseXLogData +) where + +import Chainweb.ChainId +import Chainweb.Utils +import Chainweb.Utils.Serialization +import Chainweb.Version +import Control.Exception +import Control.Monad.Catch +import Data.ByteString qualified as B +import Data.Text qualified as T +import Data.Word +import Ethereum.Misc qualified as E +import Ethereum.Receipt +import GHC.Generics (Generic) +import Chainweb.PayloadProvider.EVM.Utils hiding (ChainId) +import Data.Aeson +import Ethereum.Utils (HexBytes(..)) +import Control.Monad +import Chainweb.PayloadProvider + +-- -------------------------------------------------------------------------- +-- Exceptions + +data XChainException + = InvalidLogData T.Text + deriving (Show, Eq) + +instance Exception XChainException + +-- -------------------------------------------------------------------------- -- +-- Event Signature + +newtype EventId = EventId (E.BytesN 32) + deriving (Show, Eq, Generic, E.Bytes) + +_xChainInitializedSignature :: B.ByteString +_xChainInitializedSignature = "CrosschainInitialized(uint32,address,uint64,bytes)" + +_xChainInitializedId :: EventId +_xChainInitializedId = EventId + $ E._getKeccak256Hash + $ E.keccak256 + $ _xChainInitializedSignature + +-- -------------------------------------------------------------------------- -- +-- Crosschain Operation Name + +newtype XChainOperationName = XChainOperationName Word64 + deriving (Show, Eq, Generic) + deriving newtype (ToJSON, FromJSON) + +-- -------------------------------------------------------------------------- -- +-- X-Chain Message Type + +newtype XChainData = XChainData B.ByteString + deriving (Show, Eq, Generic) + deriving (ToJSON, FromJSON) via (HexBytes B.ByteString) + +-- -------------------------------------------------------------------------- -- +-- LogData For Crosschain Event + +-- @ +-- event CrosschainInitialized( +-- uint32 indexed targetChainId, +-- address indexed targetContractAddress, +-- uint64 indexed crosschainOperationName, +-- bytes crosschainData +-- ) +-- @ + +-- | X-Chain LogData +-- +-- This data structure is specifically for KIP-34 crosschain transfer proofs. +-- +data XLogData = XLogData + { _xLogDataSenderAddress :: !Address32 + , _xLogDataTargetChain :: !ChainId + , _xLogDataTargetContract :: !Address32 + , _xLogDataOperationName :: !XChainOperationName + , _xLogDataMessage :: !XChainData + } + deriving (Show, Eq, Generic) + +-- | The signature of the event that is stored in the first topic. +-- +-- @ +-- Keccak256('CrossChainInitialized(uint32,address,uint64,bytes)') +-- @ +-- +xLogDataSignature :: E.BytesN 32 +xLogDataSignature = b + where + HexBytes b = unsafeFromText + "0x9d2528c24edd576da7816ca2bdaa28765177c54b32fb18e2ca18567fbc2a9550" + +parseXLogData + :: MonadThrow m + => HasVersion + => XEventId + -> LogEntry + -> m XLogData +parseXLogData eid e = do + (LogTopic t0, LogTopic t1, LogTopic t2, LogTopic t3) <- getTopics + + -- FIXME FIXME FIXME + -- Check the event signture + + unless (t0 == xLogDataSignature) $ + throwM $ UnsupportedEventType eid + + targetChain <- mkChainId h =<< runGetS decodeWordBe (E.bytes $ dropN @32 @4 t1) + operationName <- XChainOperationName <$> runGetS decodeWordBe (E.bytes $ dropN @32 @8 t3) + + return XLogData + { _xLogDataOperationName = operationName + , _xLogDataSenderAddress = toAddress32 $ _logEntryAddress e + , _xLogDataTargetChain = targetChain + , _xLogDataTargetContract = Address32 t2 + , _xLogDataMessage = XChainData $ E.bytes $ _logEntryData e + } + where + h = _xEventBlockHeight eid + getTopics = case _logEntryTopics e of + (t0 : t1 : t2 : t3: _ ) -> return (t0, t1, t2, t3) + l -> throwM $ InvalidEvent eid $ + "expected at least four topics but got " <> sshow (length l) diff --git a/src/Chainweb/PayloadProvider/EVM/Utils.hs b/src/Chainweb/PayloadProvider/EVM/Utils.hs new file mode 100644 index 0000000000..fe8a7dd85f --- /dev/null +++ b/src/Chainweb/PayloadProvider/EVM/Utils.hs @@ -0,0 +1,324 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} + +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE TypeFamilies #-} + +-- | +-- Module: Chainweb.PayloadProvider.EVM.Utils +-- Copyright: Copyright © 2024 Kadena LLC. +-- License: MIT +-- Maintainer: Lars Kuhtz +-- Stability: experimental +-- +module Chainweb.PayloadProvider.EVM.Utils +( ChainId(..) +, Randao(..) +, BlockValue(..) +, Address32(..) +, toAddress32 +, _blockValueStu +, DefaultBlockParameter(..) +, ExecutionRequest(..) + +-- * Misc Utils +, fromHexQuanity +, fromHexBytes +, nullHash +, nullBlockHash +, decodeRlpM +, dropN + +-- * Merkle Log Entries for EVM Types +, RlpMerkleLogEntry(..) +) where + +import Chainweb.BlockHash qualified as Chainweb +import Chainweb.MinerReward +import Chainweb.Utils +import Chainweb.Utils.Serialization (runPutS, runGetS) +import Control.Monad.Catch +import Data.Aeson +import Data.ByteString qualified as B +import Data.ByteString.Base16 qualified as B16 +import Data.ByteString.Short qualified as BS +import Data.Hashable (Hashable) +import Data.Text qualified as T +import Data.Text.Encoding qualified as T +import Data.Text.Read qualified as T +import Ethereum.Misc qualified as E +import Ethereum.RLP (RLP, get, getRlp, putRlpByteString) +import Ethereum.Receipt +import Ethereum.Transaction (Wei (..)) +import Ethereum.Utils hiding (int, natVal_) +import Foreign.Storable (Storable) +import GHC.Generics (Generic) +import GHC.TypeLits +import Text.Printf +import Chainweb.MerkleUniverse +import Chainweb.Crypto.MerkleLog +import Data.MerkleLog (MerkleNodeType(..)) +import qualified Data.ByteString.Short as SB + +-- -------------------------------------------------------------------------- -- +-- Utils (should be moved to the ethereum package) + +-- copy and past from the Ethereum.Utils + +fromHexQuanity :: HexQuantity a -> a +fromHexQuanity (HexQuantity a) = a + +fromHexBytes :: HexBytes a -> a +fromHexBytes (HexBytes a) = a + +nullHash :: E.Keccak256Hash +nullHash = E.Keccak256Hash $ E.replicateN 32 + +nullBlockHash :: E.BlockHash +nullBlockHash = E.BlockHash nullHash + +deriving instance Functor HexQuantity +deriving instance Functor HexBytes + +-- The implementation should be moved to the Ethereum.Utils +instance HasTextRepresentation (HexQuantity Natural) where + toText (HexQuantity a) = T.pack $ printf @(Natural -> String) "0x%x" a + fromText t = T.hexadecimal <$> strip0x t >>= \case + Right (x, "") -> return $ HexQuantity x + Right (x, p) -> throwM $ TextFormatException + $ sshow (T.length p) <> " pending characters after parsing " <> sshow x + Left e -> throwM $ TextFormatException (T.pack e) + {-# INLINE toText #-} + {-# INLINE fromText #-} + +instance HasTextRepresentation E.BlockNumber where + toText (E.BlockNumber a) = toText (HexQuantity a) + fromText t = do + HexQuantity n <- fromText t + return $ E.BlockNumber n + {-# INLINE toText #-} + {-# INLINE fromText #-} + +instance HasTextRepresentation (HexBytes B.ByteString) where + toText (HexBytes a) = T.decodeUtf8 ("0x" <> B16.encode a) + fromText t = (B16.decode . T.encodeUtf8 <$> strip0x t) >>= \case + Left e -> throwM $ TextFormatException $ T.pack e + Right x -> return $ HexBytes x + {-# INLINE toText #-} + {-# INLINE fromText #-} + +instance HasTextRepresentation (HexBytes BS.ShortByteString) where + toText = toText . fmap BS.fromShort + fromText t = fmap BS.toShort <$> fromText t + {-# INLINE toText #-} + {-# INLINE fromText #-} + +instance KnownNat n => HasTextRepresentation (HexBytes (E.BytesN n)) where + toText = toText . fmap E.bytes + fromText t = do + HexBytes bs <- fromText t + case E.bytesN bs of + Right x -> return (HexBytes x) + Left e -> throwM $ TextFormatException $ sshow e + {-# INLINE toText #-} + {-# INLINE fromText #-} + +instance HasTextRepresentation E.Keccak256Hash where + toText = toText . HexBytes . E.bytes + fromText = fmap (E.Keccak256Hash . fromHexBytes) . fromText + {-# INLINE toText #-} + {-# INLINE fromText #-} + +instance HasTextRepresentation E.BlockHash where + toText = toText . HexBytes . E.bytes + fromText = fmap E.BlockHash . fromText + {-# INLINE toText #-} + {-# INLINE fromText #-} + +instance HasTextRepresentation E.Address where + toText = toText . HexBytes . E.bytes + fromText = fmap (E.Address . fromHexBytes) . fromText + {-# INLINE toText #-} + {-# INLINE fromText #-} + +-- -------------------------------------------------------------------------- -- +-- Bytes + +dropN + :: forall (m :: Natural) (n :: Natural) + . KnownNat m + => KnownNat n + => n <= m + => E.BytesN m + -> E.BytesN n +dropN b = E.unsafeBytesN @n (BS.drop (int d) (E._getBytesN b)) + where + d = natVal_ @m - natVal_ @n + +-- TODO: move to ethereum package +deriving newtype instance E.Bytes LogData + +-- -------------------------------------------------------------------------- -- +-- RLP Encoding Tools + +decodeRlpM + :: MonadThrow m + => RLP a + => B.ByteString -> m a +decodeRlpM bs = case get getRlp bs of + Left e -> throwM $ DecodeException $ (T.pack e) + Right x -> return x +{-# INLINE decodeRlpM #-} + +-- -------------------------------------------------------------------------- -- +-- HexBytes representation for Chainweb BlockHash + +instance ToJSON (HexBytes Chainweb.BlockHash) where + toEncoding (HexBytes a) = toEncoding (HexBytes $ runPutS $ Chainweb.encodeBlockHash a) + toJSON (HexBytes a) = toJSON (HexBytes $ runPutS $ Chainweb.encodeBlockHash a) + {-# INLINE toEncoding #-} + {-# INLINE toJSON #-} + +instance FromJSON (HexBytes Chainweb.BlockHash) where + parseJSON v = HexBytes <$> do + HexBytes b <- parseJSON @(HexBytes (E.BytesN 32)) v + case runGetS Chainweb.decodeBlockHash (E.bytes b) of + Right x -> return x + Left e -> fail (sshow e) + {-# INLINE parseJSON #-} + +-- -------------------------------------------------------------------------- -- +-- ChainId + +newtype ChainId = ChainId { _chainId :: Natural } + deriving (Show, Eq, Ord, Generic) + deriving (ToJSON, FromJSON) via (HexQuantity Natural) + +-- -------------------------------------------------------------------------- -- +-- Address 32 + +newtype Address32 = Address32 (E.BytesN 32) + deriving (Show, Eq, Ord) + deriving newtype (RLP, E.Bytes, Storable) + deriving (FromJSON, ToJSON) via (HexBytes (E.BytesN 32)) + deriving HasTextRepresentation via (HexBytes (E.BytesN 32)) + +toAddress32 + :: E.Address + -> Address32 +toAddress32 (E.Address b) = Address32 (E.appendN zeroN b) + +zeroN :: KnownNat n => E.BytesN n +zeroN = E.replicateN 0 + +-- -------------------------------------------------------------------------- -- +-- Randao + +-- | RANDAO is a pseudorandom value generated by validators on the Ethereum +-- consensus layer. +-- +-- 32 bytes [cf. yellow paper 4.4.3 (44)] +-- +newtype Randao = Randao (E.BytesN 32) + deriving (Show, Eq, Ord) + deriving newtype (RLP, E.Bytes, Storable, Hashable) + deriving ToJSON via (HexBytes (E.BytesN 32)) + deriving FromJSON via (HexBytes (E.BytesN 32)) + +newtype BlockValue = BlockValue { _blockValue :: Wei } + deriving (Show, Eq) + deriving newtype (RLP) + deriving (ToJSON, FromJSON) via (HexQuantity E.Word256) + +_blockValueStu :: BlockValue -> Stu +_blockValueStu (BlockValue (Wei v)) = Stu (int v) + +-- ---------------------------------------------------------------------------- +-- Execution Request + +-- | Execution Requests are described in EIP-7685 and introduced in the Pectra +-- hard fork. +-- +-- They let the execution layer request certain actions from the consensus that +-- are usually related to managing stake. +-- +-- In chainweb consensus we ignore these requests at the moment. However, it is +-- possible that in the future we will use this mechanism for custom requests +-- that are specific to chainweb consensus. +-- +newtype ExecutionRequest = ExecutionRequest BS.ShortByteString + deriving (Show, Eq, Ord) + deriving newtype (RLP, E.Bytes, Hashable) + deriving ToJSON via (HexBytes SB.ShortByteString) + deriving FromJSON via (HexBytes SB.ShortByteString) + +-- -------------------------------------------------------------------------- -- +-- Default Block Parameter + +-- | Default block parameter +-- +-- cf. https://ethereum.org/en/developers/docs/apis/json-rpc/#default-block +-- +data DefaultBlockParameter + = DefaultBlockEarliest + | DefaultBlockLatest + | DefaultBlockPending + | DefaultBlockSafe + | DefaultBlockFinalized + | DefaultBlockNumber !E.BlockNumber + deriving (Show, Eq, Generic) + deriving (ToJSON, FromJSON) via (JsonTextRepresentation "DefaultBlockParameter" DefaultBlockParameter) + +instance HasTextRepresentation DefaultBlockParameter where + toText DefaultBlockEarliest = "earliest" + toText DefaultBlockLatest = "latest" + toText DefaultBlockPending = "pending" + toText DefaultBlockSafe = "safe" + toText DefaultBlockFinalized = "finalized" + toText (DefaultBlockNumber (E.BlockNumber n)) = toText (HexQuantity n) + {-# INLINE toText #-} + + fromText t = case t of + "latest" -> return DefaultBlockLatest + "earliest" -> return DefaultBlockEarliest + "pending" -> return DefaultBlockPending + "safe" -> return DefaultBlockSafe + "finalized" -> return DefaultBlockFinalized + x -> DefaultBlockNumber . E.BlockNumber . fromHexQuanity <$> fromText x + {-# INLINE fromText #-} + +-- -------------------------------------------------------------------------- -- + +newtype RlpMerkleLogEntry (tag :: ChainwebHashTag) t = RlpMerkleLogEntry t + deriving newtype RLP + +instance + ( KnownNat (MerkleTagVal ChainwebHashTag tag) + , MerkleHashAlgorithm a + , RLP t + ) + => IsMerkleLogEntry a ChainwebHashTag (RlpMerkleLogEntry tag t) + where + type Tag (RlpMerkleLogEntry tag t) = tag + toMerkleNode = InputNode . putRlpByteString + fromMerkleNode (InputNode bs) = case get getRlp bs of + Left e -> throwM $ MerkleLogDecodeException (T.pack e) + Right x -> Right x + fromMerkleNode (TreeNode _) = throwM expectedInputNodeException + diff --git a/src/Chainweb/PayloadProvider/Initialization.hs b/src/Chainweb/PayloadProvider/Initialization.hs new file mode 100644 index 0000000000..4effdbdc30 --- /dev/null +++ b/src/Chainweb/PayloadProvider/Initialization.hs @@ -0,0 +1,44 @@ +{-# LANGUAGE ImportQualifiedPost #-} + +-- | +-- Module: Chainweb.PayloadProvider.Initialization +-- Copyright: Copyright © 2024 Kadena LLC. +-- License: MIT +-- Maintainer: Lars Kuhtz +-- Stability: experimental +-- +module Chainweb.PayloadProvider.Initialization +( Resources(..) +) where + +import Chainweb.ChainId +import Chainweb.Version +import Chainweb.Pact.Payload.PayloadStore +import Chainweb.Pact.Types (MemPoolAccess) +import Data.Text qualified as T + +-- -------------------------------------------------------------------------- -- +-- Initialization + +-- | FIXME: this should be refined +-- +type MinerInfo = T.Text + +-- | Globally initialized resources that are needed by payload providers. +-- +-- Note that not all payload providers require all of these resources. +-- +data Resources tbl logger = Resources + { _resourceChainwebVersion :: !ChainwebVersion + , _resourceChainId :: !ChainId + , _resourceLogger :: !logger + , _resourceMempoolAccess :: !MemPoolAccess + -- ^ The mempool is owned completely by the payload provider. So, maybe + -- we should let it initialize the mempool by itself? At the moment all + -- network components are initialized centrally. + , _resourcePayloadDb :: !(PayloadDb tbl) + -- ^ For the EVM this is not needed, because it manages its own payload + -- database and synchronization. Pact relies on the consensus header for\ + -- synchronizing the payloads and populating the payload database. + , _resourceMinerInfo :: !MinerInfo + } diff --git a/src/Chainweb/PayloadProvider/Minimal.hs b/src/Chainweb/PayloadProvider/Minimal.hs new file mode 100644 index 0000000000..1edff313a1 --- /dev/null +++ b/src/Chainweb/PayloadProvider/Minimal.hs @@ -0,0 +1,582 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuantifiedConstraints #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeAbstractions #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE TupleSections #-} + +-- | +-- Module: Chainweb.IdleProvider +-- Copyright: Copyright © 2024 Kadena LLC. +-- License: MIT +-- Maintainer: Lars Kuhtz +-- Stability: experimental +-- +-- A minimal payload provider. +-- +-- No user provided payload processing is supported. +-- +-- Miner reward payout must be recorded in the block payload hash. Ideally, this +-- would be done in a way such that payloads could be validated just from the +-- evaluation context and the payload hash, without the need to persist and +-- synchronize additional payload data. An obvious way to do this would be to +-- use the miner pk account as payload hash. However, that would be unsafe by +-- allowing miner to attack the Chainweb SPV proofs by proving arbitrary facts. +-- +-- At the moment, Chainweb SPV proofs do not generally witness provenance with +-- respect to a particular block header. If that information is needed in a +-- particular proof it must be provided on application level in the proof claim, +-- which means that it is hidden behind a Chainweb MerkleLog tag. With the +-- current proof format, there is no way for consumers of SPV proofs to verify +-- that a proof claim was made in the context of a particular payload provider. +-- Consequently, _all_ data in the preimage of a Merkle root must be tagged and +-- preimages of all Merkle roots in the Chainweb Merkle tree must be verified +-- down to the tag level by miners. +-- +-- This means that Validation of a block header can be selfcontained only if all +-- data in the preimage of the payload hash is deterministically derived from +-- the header data. +-- +-- There is no way to encode the miner account in the block header in a +-- practical way. Therefore, the requirement to include the miner account (or +-- some data that is derived from the miner account) in the preimage of the +-- payload hash implies that header validation cannot be selfcontained and we +-- need to introduce payloads that are persisted and synchronized between nodes. +-- +-- Additional Remarks: +-- +-- More generally, the above also means that if a node user decides to not +-- validate payloads on all chains, that they blindly trust the miners in the +-- system to validate all payloads on all chains each time they verify an SPV +-- proof. In particular, it means that a majority of miners *must* validate all +-- payloads on all chains! +-- +-- This may be actually a strong argument why it is good that over 50% of the +-- chains are blocked most of the time. One can probably establish a Ramsey +-- style argument that a each chain must be covered by a majority of miners or +-- otherwise some miners would risk to have their devices blocked sometimes. +-- +module Chainweb.PayloadProvider.Minimal +( MinimalProviderConfig(..) +, mpcRedeemChain +, mpcRedeemAccount +, defaultMinimalProviderConfig +, validateMinimalProviderConfig +, pMinimalProviderConfig +, MinimalPayloadProvider +, minimalPayloadDb +, minimalPayloadQueue +, newMinimalPayloadProvider +) where + +import Chainweb.BlockHeader +import Chainweb.BlockHeight +import Chainweb.BlockPayloadHash +import Chainweb.Logger +import Chainweb.MinerReward +import Chainweb.Parent +import Chainweb.PayloadProvider +import Chainweb.PayloadProvider.Minimal.Payload +import Chainweb.PayloadProvider.Minimal.PayloadDB qualified as PDB +import Chainweb.PayloadProvider.P2P +import Chainweb.PayloadProvider.P2P qualified as Rest +import Chainweb.PayloadProvider.P2P.RestAPI.Client qualified as Rest +import Chainweb.Ranked +import Chainweb.Storage.Table +import Chainweb.Storage.Table.Map +import Chainweb.Storage.Table.RocksDB +import Chainweb.Utils +import Chainweb.Utils.Serialization +import Chainweb.Version +import Configuration.Utils +import Control.Concurrent.Async +import Control.Concurrent.STM +import Control.Lens hiding ((.=)) +import Control.Monad +import Control.Monad.Catch +import Control.Monad.Except (throwError) +import Data.ByteString qualified as B +import Data.HashMap.Strict qualified as HM +import Data.HashSet qualified as HS +import Data.LogMessage (LogFunction, LogFunctionText) +import Data.PQueue (PQueue) +import Data.Text qualified as T +import GHC.Generics (Generic) +import Network.HTTP.Client qualified as HTTP +import Numeric.Natural +import P2P.TaskQueue +import Servant.Client +import System.LogLevel +import Data.Maybe + +-- -------------------------------------------------------------------------- -- + +data MinimalProviderConfig = MinimalProviderConfig + { _mpcRedeemChain :: !ChainId + , _mpcRedeemAccount :: !Account + } + deriving (Show, Eq, Generic) + +makeLenses ''MinimalProviderConfig + +defaultMinimalProviderConfig :: MinimalProviderConfig +defaultMinimalProviderConfig = MinimalProviderConfig + { _mpcRedeemChain = unsafeChainId 0 + , _mpcRedeemAccount = invalidAccount + -- Most likely this account is invalid on all providers. If the account + -- is invalid on the redeem chain, the reward can't be claimed. So, most + -- likely, this burns the miner rewards. + } + +instance ToJSON MinimalProviderConfig where + toJSON o = object + [ "redeemChain" .= _mpcRedeemChain o + , "redeemAccount" .= _mpcRedeemAccount o + ] + +instance FromJSON MinimalProviderConfig where + parseJSON = withObject "MinimalProviderConfig" $ \o -> + MinimalProviderConfig + <$> o .: "redeemChain" + <*> o .: "redeemAccount" + +instance FromJSON (MinimalProviderConfig -> MinimalProviderConfig) where + parseJSON = withObject "MinimalProviderConfig" $ \o -> id + <$< mpcRedeemChain ..: "redeemChain" % o + <*< mpcRedeemAccount ..: "redeemAccount" % o + +pMinimalProviderConfig :: MParser MinimalProviderConfig +pMinimalProviderConfig = id + <$< mpcRedeemChain .:: pChainId + <*< mpcRedeemAccount .:: pAccount + where + pChainId :: OptionParser ChainId + pChainId = unsafeChainId <$> option auto + % long "default-redeem-chain" + <> help "chain on which block rewards from the default payload provider can be claimed" + + pAccount :: OptionParser Account + pAccount = option textReader + % long "default-redeem-account" + <> help "a valid account on the redeem chain for the default payload provider" + +validateMinimalProviderConfig + :: HasVersion + => ConfigValidation MinimalProviderConfig [] +validateMinimalProviderConfig o + | HS.member rcid chainIds = return () + | otherwise = do + throwError $ mconcat + [ "The provided redeem chain for the default payload provider is not a valid chain in the current chainweb" + , " Provided value " <> sshow rcid + ] + where + rcid = _mpcRedeemChain o + +-- -------------------------------------------------------------------------- -- + +data MinimalPayloadProvider = MinimalPayloadProvider + { _minimalChainId :: !ChainId + , _minimalPayloadVar :: !(TMVar NewPayload) + , _minimalRedeemChain :: !ChainId + , _minimalMinerInfo :: !Account + , _minimalPayloadStore :: !(PayloadStore (PDB.PayloadDb RocksDbTable) Payload) + , _minimalCandidatePayloads :: !(MapTable RankedBlockPayloadHash Payload) + -- ^ FIXME: should this be moved into the Payload Store? + -- + -- For now we just prune after each successful syncToBlock. + , _minimalLogger :: LogFunction + } + +minimalPayloadDb :: Getter MinimalPayloadProvider (PDB.PayloadDb RocksDbTable) +minimalPayloadDb = to (_payloadStoreTable . _minimalPayloadStore) + +minimalPayloadQueue :: Getter MinimalPayloadProvider (PQueue (Task ClientEnv Payload)) +minimalPayloadQueue = to (_payloadStoreQueue . _minimalPayloadStore) + +newMinimalPayloadProvider + :: Logger logger + => HasVersion + => HasChainId c + => logger + -> c + -> RocksDb + -> Maybe HTTP.Manager + -> MinimalProviderConfig + -> IO MinimalPayloadProvider +newMinimalPayloadProvider logger c rdb mgr conf + | payloadProviderTypeForChain c /= MinimalProvider = + error "Chainweb.PayloadProvider.Minimal.configuration: chain does not use minimal provider" + | otherwise = do + SomeChainwebVersionT @v _ <- return someChainwebVersionVal + SomeChainIdT @c _ <- return $ someChainIdVal c + let payloadClient = Rest.payloadClient @v @c @'MinimalProvider + + let payloadRankedPayloadHash pld = RankedBlockPayloadHash + { _rankedBlockPayloadHashHeight = view payloadBlockHeight pld + , _rankedBlockPayloadHashHash = view payloadHash pld + } + let payloadBatchClient rhs = do + rs <- Rest.payloadBatchClient @v @c @'MinimalProvider rhs + let rs' = HM.fromList $ (\pld -> (payloadRankedPayloadHash pld, pld)) <$> rs + return $ (`HM.lookup` rs') <$> rhs + + pdb <- PDB.initPayloadDb $ PDB.configuration c rdb + store <- newPayloadStore mgr (logFunction pldStoreLogger) pdb payloadClient payloadBatchClient + var <- newEmptyTMVarIO + candidates <- emptyTable + logFunctionText logger Debug "minimal payload provider started" + return MinimalPayloadProvider + { _minimalChainId = _chainId c + , _minimalPayloadVar = var + , _minimalRedeemChain = _mpcRedeemChain conf + , _minimalMinerInfo = _mpcRedeemAccount conf + , _minimalPayloadStore = store + , _minimalCandidatePayloads = candidates + , _minimalLogger = logFunction logger + } + where + pldStoreLogger = addLabel ("sub-component", "payloadStore") logger + +instance HasChainId MinimalPayloadProvider where + _chainId = _minimalChainId + +instance + ReadableTable MinimalPayloadProvider RankedBlockPayloadHash Payload + where + tableLookup = tableLookup . _minimalPayloadStore + tableLookupBatch' s = tableLookupBatch' (_minimalPayloadStore s) + tableMember = tableMember . _minimalPayloadStore + +instance + Table MinimalPayloadProvider RankedBlockPayloadHash Payload + where + tableInsert = tableInsert . _minimalPayloadStore + tableInsertBatch s = tableInsertBatch (_minimalPayloadStore s) + tableDelete s = tableDelete (_minimalPayloadStore s) + tableDeleteBatch s = tableDeleteBatch (_minimalPayloadStore s) + +-- -------------------------------------------------------------------------- -- +-- Validate Payload + +data PayloadValidationFailure + = PayloadInvalidChainwebVersion !(Expected ChainwebVersion) !(Actual ChainwebVersion) + | PayloadInvalidChainId !(Expected ChainId) !(Actual ChainId) + | PayloadInvalidMinerReward !(Expected MinerReward) !(Actual MinerReward) + | PayloadInvalidHeight !(Expected BlockHeight) !(Actual BlockHeight) + | PayloadInvalidHash !(Expected BlockPayloadHash) !(Actual BlockPayloadHash) + | PayloadInvalidPayloadData !(Expected EncodedPayloadData) !(Actual EncodedPayloadData) + deriving (Show, Eq, Generic) + +instance Exception PayloadValidationFailure + +-- | Validate a Payload against a given 'EvaluationCtx'. +-- +-- Notes: +-- +-- The type witnesses that ChainId values are valid for the latest chainweb +-- graph. +-- +-- The Account type witnesses that the size of the account data is within the +-- required limits. +-- +-- _evaluationCtxParentCreationTime: there's no notion of time in the minimal +-- payload provider. +-- +-- _evaluationCtxParentHash: the parent hash is not reflected in the payload. +-- Payloads uniquly identify a block via version, chainid, and height. +-- +validatePayload + :: forall m + . MonadThrow m + => HasVersion + => MinimalPayloadProvider + -> Payload + -> EvaluationCtx ConsensusPayload + -> m () +validatePayload p pld ctx = do + checkEq PayloadInvalidChainId + (_chainId p) + (_chainId pld) + checkEq PayloadInvalidHeight + (_evaluationCtxCurrentHeight ctx) + (view payloadBlockHeight pld) + checkEq PayloadInvalidMinerReward + (_evaluationCtxMinerReward ctx) + (view payloadMinerReward pld) + checkEq PayloadInvalidHash + (_consensusPayloadHash $ _evaluationCtxPayload ctx) + (view payloadHash pld) + case _consensusPayloadData $ _evaluationCtxPayload ctx of + Nothing -> return () + Just x -> checkEq PayloadInvalidPayloadData x (encodedPayloadData pld) + where + checkEq + :: Eq a + => (Expected a -> Actual a -> PayloadValidationFailure) + -> a + -> a + -> m () + checkEq failure expected actual = + unless (expected == actual) $ + throwM $ failure (Expected expected) (Actual actual) + +encodedPayloadData :: Payload -> EncodedPayloadData +encodedPayloadData = EncodedPayloadData . runPutS . encodePayload + +encodedPayloadDataSize :: EncodedPayloadData -> Natural +encodedPayloadDataSize (EncodedPayloadData bs) = int $ B.length bs + +decodePayloadData :: MonadThrow m => EncodedPayloadData -> m Payload +decodePayloadData (EncodedPayloadData bs) = runGetS decodePayload bs + +-- -------------------------------------------------------------------------- -- +-- Payload Provider API + +instance PayloadProvider MinimalPayloadProvider where + prefetchPayloads = minimalPrefetchPayloads + syncToBlock = minimalSyncToBlock + latestPayloadSTM = minimalLatestPayloadStm + latestPayloadIO = minimalLatestPayloadIO + eventProof = error "Chainweb.PayloadProvider.Minimal.eventProof: not implemented" + +-- | Fetch a payload for an evaluation context and insert it into the candidate +-- table. +-- +getPayloadForContext + :: MinimalPayloadProvider + -> Maybe Hints + -> Ranked ConsensusPayload + -> IO Payload +getPayloadForContext p h ctx = do + insertPayloadData (_consensusPayloadData $ _ranked ctx) + pld <- Rest.getPayload + (_minimalPayloadStore p) + (_minimalCandidatePayloads p) + (Priority $ negate $ int $ _rankedHeight ctx) + (_hintsOrigin <$> h) + (_consensusPayloadHash <$> ctx) + casInsert (_minimalCandidatePayloads p) pld + return pld + where + insertPayloadData Nothing = return () + insertPayloadData (Just epld) = case decodePayloadData epld of + Right pld -> casInsert (_minimalCandidatePayloads p) pld + Left e -> do + lf Warn $ "failed to decode encoded payload from evaluation ctx: " <> sshow e + + lf :: LogFunctionText + lf = _minimalLogger p + +getPayloadsForConsensusPayloads + :: MinimalPayloadProvider + -> Maybe Hints + -> [Ranked ConsensusPayload] + -> IO [(RankedBlockPayloadHash, Payload)] +getPayloadsForConsensusPayloads p h ctxs = do + insertPayloadDataBatch (_minimalCandidatePayloads p) + plds <- Rest.getPayloads + (_minimalPayloadStore p) + (_minimalCandidatePayloads p) + (Priority $ negate $ int $ _rankedHeight $ head ctxs) + (_hintsOrigin <$> h) + (fmap _consensusPayloadHash <$> ctxs) + tableInsertBatch (_minimalCandidatePayloads p) plds + return plds + where + insertPayloadDataBatch tbl = do + plds <- mapM decodePld ctxs + tableInsertBatch tbl $ catMaybes plds + + decodePld rcp@(Ranked _ cp) = case mapM decodePayloadData $ _consensusPayloadData cp of + Right pld -> + return $ (_consensusPayloadHash <$> rcp,) <$> pld + Left e -> do + lf Warn $ "failed to decode encoded payloads from evaluation ctx: " <> sshow e + return Nothing + + lf :: LogFunctionText + lf = _minimalLogger p + + +-- | Fetch all payloads in an evaluation context and insert them into the +-- candidate table. +-- +-- This version blocks until all payloads are fetched (or a timeout occurs). +-- +-- Should we also expose a version that is fire-and-forget? +-- +minimalPrefetchPayloads + :: HasVersion + => MinimalPayloadProvider + -> Maybe Hints + -> [Ranked ConsensusPayload] + -> IO () +minimalPrefetchPayloads p h ps = do + logg p Info $ "prefetch payloads: query " <> sshow (length ps) + -- mapConcurrently_ (try @_ @TaskException . getPayloadForContext p h) ps + rs <- getPayloadsForConsensusPayloads p h ps + logg p Info $ "prefetch payloads: got " <> sshow (length rs) + +-- | +-- +-- NOTE: +-- +-- The mimimal Payload Provider is special in that it is stateless. Validation +-- of a payload does depend only on the evaluation context and not on the +-- history of the chain. Similarly, new block production does depend only on the +-- block height and not on current latest block. +-- +-- This means that 'syncToBlock' does not need to resolve reorgs. It also means +-- that it succeeds on an empty ForkInfo trace. (Otherwise it would succeed only +-- if the requested target state matched the current state.) However, it also +-- means, that the content of the payload db could be incomplete or even +-- inconsistent by containing payloads from non-canonical forks at some block +-- heights. +-- +-- If it is a requirement that the payload provider offers access to the full +-- and consistent history via the service API, the implementation of +-- 'syncToBlock' must be adjusted to resolve reorgs and guarantee a seemless +-- history. +-- +minimalSyncToBlock + :: HasVersion + => MinimalPayloadProvider + -> Maybe Hints + -> ForkInfo + -> IO ConsensusState +minimalSyncToBlock p h i = do + logg p Debug "syncToBlock called" + validatePayloads p h i + + -- FIXME: is this right place to prune the candidate store? + pruneCandidates p (_forkInfoTargetState i) + + -- Produce new block + case _forkInfoNewBlockCtx i of + Nothing -> do + logg p Debug $ "no new payload for sync state: " <> sshow latestState + return () + Just ctx -> do + logg p Debug $ "create new payload for sync state: " <> sshow latestState + atomically + $ writeTMVar (_minimalPayloadVar p) + $ makeNewPayload p latestState ctx + return $ _forkInfoTargetState i + where + latestState = _consensusStateLatest $ _forkInfoTargetState i + +logg :: MinimalPayloadProvider -> LogLevel -> T.Text -> IO () +logg = _minimalLogger + +makeNewPayload + :: HasVersion + => MinimalPayloadProvider + -> SyncState + -> NewBlockCtx + -> NewPayload +makeNewPayload p latest ctx = NewPayload + { _newPayloadChainId = _chainId p + , _newPayloadParentHeight = Parent $ _syncStateHeight latest + , _newPayloadParentHash = Parent $ _syncStateBlockHash latest + , _newPayloadBlockPayloadHash = view payloadHash pld + , _newPayloadEncodedPayloadData = Just epld + , _newPayloadEncodedPayloadOutputs = Nothing + , _newPayloadNumber = 0 -- there will only be a single output per parent + , _newPayloadTxCount = 0 + , _newPayloadSize = encodedPayloadDataSize epld + , _newPayloadOutputSize = 0 + , _newPayloadFees = 0 + } + where + pld = newPayload p + (_syncStateHeight latest + 1) + (_newBlockCtxMinerReward ctx) + (_minimalRedeemChain p) + (_minimalMinerInfo p) + epld = encodedPayloadData pld + +-- | Fetches and validates all missing payloads for a 'ForkInfo' value. +-- +-- Throws PayloadValidationFailure if a payload is not valid. +-- +-- FIXME: is it fine that we can end up with a payload database where +-- some earlier payloads are missing? This would also mean that the respective +-- payloads have not been validated. This is probably fine with the current cut +-- pipeline, but this might not always be the case in the future. +-- +validatePayloads + :: HasVersion + => MinimalPayloadProvider + -> Maybe Hints + -> ForkInfo + -> IO () +validatePayloads p h i = do + + -- If the trace is larger than one we first try to fetch all payloads in a + -- batch and insert them into the candidate store. This will insert them + -- into the candidate table. After this the getPayloadForContext call below + -- should be not hit the network any more. This is currently only beneficial + -- when synchronizing long forks or a with a consensus that is ahead, like + -- during replay or reinitialization of the payload provider. + -- + -- FIXME: seems to time out for some reason + -- when (length (_forkInfoTrace i) > 1) $ + -- void $ getPayloadsForConsensusPayloads p h + -- (_evaluationCtxRankedPayload <$> _forkInfoTrace i) + + mapConcurrently_ go (_forkInfoTrace i) + where + go ctx = do + pld <- getPayloadForContext p h + (Ranked (_evaluationCtxCurrentHeight ctx) (_evaluationCtxPayload ctx)) + validatePayload p pld ctx + casInsert (_minimalPayloadStore p) pld + +minimalLatestPayloadIO :: MinimalPayloadProvider -> IO NewPayload +minimalLatestPayloadIO = atomically . readTMVar . _minimalPayloadVar + +minimalLatestPayloadStm :: MinimalPayloadProvider -> STM NewPayload +minimalLatestPayloadStm = readTMVar . _minimalPayloadVar + +-- | The depth at which the candidate cache is pruned. We prune after each +-- successful syncToBlock call. Most of the time this cache is very small and +-- pruning should be very fast. +-- +-- * In normal operation, that just extends the chain, the a pruning depth of 0 is +-- fine +-- * For "normal" reorgs the diameter of the graph is sufficient. +-- +-- FIXME Make this depend on the catchup step size. +-- +-- * Remove items from this cache that are in the validated database. +-- +-- * For reorgs that are due to network forks/partitions the depth of the +-- catchup would be optimal, which is bounded by the reorg limit. For now we +-- ignore that case. We want a solution where we don't have permanent cost +-- overhead for this exceptional scenario. +-- +candidatePruningDepth :: HasVersion => MinimalPayloadProvider -> BlockHeight -> BlockHeight +candidatePruningDepth _p h = int $ diameter (chainGraphAt h) + +pruneCandidates :: HasVersion => MinimalPayloadProvider -> ConsensusState -> IO () +pruneCandidates p s = deleteLt (_minimalCandidatePayloads p) lrh + { _rankedHeight = h - candidatePruningDepth p h + } + where + lrh = latestRankedBlockPayloadHash s + h = _rankedHeight lrh diff --git a/src/Chainweb/PayloadProvider/Minimal/Payload.hs b/src/Chainweb/PayloadProvider/Minimal/Payload.hs new file mode 100644 index 0000000000..751c51af09 --- /dev/null +++ b/src/Chainweb/PayloadProvider/Minimal/Payload.hs @@ -0,0 +1,414 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} + +-- | +-- Module: Chainweb.PayloadProvider.Minimal.Payload +-- Copyright: Copyright © 2025 Kadena LLC. +-- License: MIT +-- Maintainer: Lars Kuhtz +-- Stability: experimental +-- +module Chainweb.PayloadProvider.Minimal.Payload +( Account +, account +, invalidAccount +, Payload +, newPayload +, payloadMinerReward +, payloadChainwebVersion +, payloadChainId +, payloadBlockHeight +, payloadRedeemChain +, payloadRedeemAccount +, payloadHash +, genesisPayload +, encodePayload +, decodePayload +, type PayloadCas +, proof +, runProof +) where + +import Chainweb.BlockHeight +import Chainweb.BlockPayloadHash +import Chainweb.Crypto.MerkleLog +import Chainweb.MerkleLogHash +import Chainweb.MerkleUniverse +import Chainweb.MinerReward +import Chainweb.Storage.Table +import Chainweb.Utils +import Chainweb.Utils.Serialization +import Chainweb.Version +import Control.Lens (Getter) +import Control.Lens.Getter (to) +import Control.Monad +import Control.Monad.Catch +import Data.Aeson +import Data.Aeson.Types (Pair) +import Data.ByteString.Short qualified as BS +import Data.Function +import Data.Hashable +import Data.MerkleLog qualified as V2 (MerkleProof, runProof) +import Data.Void +import Data.Word +import GHC.Generics (Generic) +import GHC.Stack +import Numeric.Natural + +-- -------------------------------------------------------------------------- -- +-- Account Info + +-- | Maximum allowed account size. This must be verified by the payload +-- provider. +-- +-- Omitting to enforce this would be DoS attack vector. +-- +maxAccountSize :: Integral n => n +maxAccountSize = 512 +{-# INLINE maxAccountSize #-} + +data AccountToLargeException = + AccountTooLarge (Actual Natural) (Expected Natural) + deriving (Show, Eq, Generic) + +instance Exception AccountToLargeException + +accountTooLarge :: Integral n => n -> AccountToLargeException +accountTooLarge actual = + AccountTooLarge (Actual (int actual)) (Expected maxAccountSize) + +-- | Account Information in a payload provider specific format. +-- +-- NOTE: The maximum length is 512 bytes. This must be enforced during payload +-- validation. It is implied by 'decodeAccount' and the 'FromJSON' instance. +-- +newtype Account = Account BS.ShortByteString + deriving (Show, Eq, Ord, Generic) + deriving (ToJSON, FromJSON) via (JsonTextRepresentation "Account" Account) + +-- | Creates a new Account value and checks that the size is within the +-- acceptable limits. +-- +account :: MonadThrow m => BS.ShortByteString -> m Account +account bs + | BS.length bs > maxAccountSize = + throwM $ accountTooLarge (BS.length bs) + | otherwise = return $ Account bs + +encodeAccount :: HasCallStack => Account -> Put +encodeAccount (Account bs) = do + let l = BS.length bs + when (l > int (maxBound @Word16)) $ + error "Chainweb.PayloadProvider.Minimal.encodePayload: account is too large" + putWord16le (int l) + putShortByteString bs +{-# INLINE encodeAccount #-} + +decodeAccount :: Get Account +decodeAccount = do + l <- int <$> getWord16le + bs <- getShortByteString l + account bs +{-# INLINE decodeAccount #-} + +instance HasTextRepresentation Account where + toText (Account bs) = encodeB64UrlNoPaddingText $ BS.fromShort bs + fromText = account . BS.toShort <=< decodeB64UrlNoPaddingText + {-# INLINEABLE toText #-} + {-# INLINEABLE fromText #-} + +-- | An account that _may_ be invalid. It is not guaranteed to be invalid! +-- +-- This assumed to be an invalid account on all providers. However, do not +-- count on it! +-- +invalidAccount :: Account +invalidAccount = Account "" + +-- -------------------------------------------------------------------------- -- + +-- | Payload for the Minimal Payload Provider +-- +-- Its sole purpose is to enable payout of miner rewards. +-- +-- Payload validation witnesses that the payload properties match the respective +-- values frm the evaluation context for the block. +-- +-- The output of payload validation is the payload itself. The BlockPayloadHash +-- is the Merkle root of this structure. +-- +data Payload = Payload + -- Provenance data: + -- (must be consistent with the evaluation context) + { _payloadChainwebVersion :: !ChainwebVersionCode + -- ^ The chainweb version of the block + , _payloadChainId :: !ChainId + -- ^ The chain of the block + , _payloadBlockHeight :: !BlockHeight + -- ^ The height of the block. + , _payloadMinerReward :: !MinerReward + -- ^ The miner reward for the block in Stu. + + -- Miner data: + , _payloadRedeemChain :: !ChainId + -- ^ The unique chain on which the payload can redeemed. + -- If the chain does not (yet) exist, the miner reward is inaccessible. + , _payloadRedeemAccount :: !Account + -- ^ A key that enables the payout of the miner reward on the target + -- chain. The format of the key depends on '_payloadRedeemChain'. + + -- Synthetic field + , _payloadHash :: {- Lazy -} BlockPayloadHash + -- ^ Merkle root for this payload. It is used as BlockPayloadHash + -- in the block. + } + deriving (Show, Generic) + +instance HasChainId Payload where + _chainId = _payloadChainId + +-- -------------------------------------------------------------------------- -- + +instance Hashable Payload where + hashWithSalt s = hashWithSalt s . _payloadHash + {-# INLINEABLE hashWithSalt #-} + +instance Eq Payload where + (==) = (==) `on` _payloadHash + +instance Ord Payload where + compare = compare `on` (\h -> (_payloadBlockHeight h, _payloadHash h)) + +instance IsCasValue Payload where + type CasKeyType Payload = RankedBlockPayloadHash + casKey p = RankedBlockPayloadHash (_payloadBlockHeight p) (_payloadHash p) + {-# INLINE casKey #-} + +type PayloadCas tbl = Cas tbl Payload + +-- -------------------------------------------------------------------------- -- +-- Internal Block Hash Computation + +-- | Compute the hash of a payload. +-- +-- Does not force '_payloadHash' in the input +-- +computeHash :: Payload -> BlockPayloadHash +computeHash h = BlockPayloadHash $ MerkleLogHash $ computeMerkleLogRoot h +{-# INLINE computeHash #-} + +-- -------------------------------------------------------------------------- -- +-- Merkle Proofs +-- +-- Example: +-- +-- ghci> Just p = proof @BlockHeight pld +-- ghci> runProof p == blockPayloadHash pld +-- True +-- ghci> proofSubject @_ @_ @BlockHeight p +-- BlockHeight 6373 + +-- | Creates a Merkle proof for a header property of a Payload. +-- +proof + :: forall a m + . MonadThrow m + => a ~ ChainwebMerkleHashAlgorithm + -- => HasHeader a ChainwebHashTag c (MkLogType a ChainwebHashTag Payload) + => Payload + -> m (V2.MerkleProof a) +proof = headerProofV2 @Payload +{-# INLINE proof #-} + +-- | Runs a proof. Returns the BlockPayloadHash of the payload for which +-- inclusion is proven. +-- +runProof :: V2.MerkleProof ChainwebMerkleHashAlgorithm -> BlockPayloadHash +runProof = BlockPayloadHash . MerkleLogHash . V2.runProof +{-# INLINE runProof #-} + +-- -------------------------------------------------------------------------- -- +-- JSON Serialization + +-- | JSON properties +-- +-- The JSON serialization also includes the block hash. +-- +properties :: KeyValue e kv => Payload -> [kv] +properties o = + [ "chainwebVersion" .= _payloadChainwebVersion o + , "chainId" .= _payloadChainId o + , "blockHeight" .= _payloadBlockHeight o + , "minerReward" .= _payloadMinerReward o + , "redeemChain" .= _payloadRedeemChain o + , "redeemAccount" .= _payloadRedeemAccount o + , "hash" .= _payloadHash o + ] +{-# INLINE properties #-} +{-# SPECIALIZE properties :: Payload -> [Series] #-} +{-# SPECIALIZE properties :: Payload -> [Pair] #-} + +instance ToJSON Payload where + toEncoding = pairs . mconcat . properties + toJSON = object . properties + {-# INLINE toEncoding #-} + {-# INLINE toJSON #-} + +instance FromJSON Payload where + parseJSON v = do + pld <- flip (withObject "Payload") v $ \o -> Payload + <$> o .: "chainwebVersion" + <*> o .: "chainId" + <*> o .: "blockHeight" + <*> o .: "minerReward" + <*> o .: "redeemChain" + <*> o .: "redeemAccount" + <*> pure (error "Chainweb.PayloadProvider.Minimal: _payloadHash") + return pld + { _payloadHash = computeHash pld + } + {-# INLINE parseJSON #-} + +-- -------------------------------------------------------------------------- -- +-- Serialization + +-- | Serialization +-- +-- (this does not include the payload hash) +-- +encodePayload :: HasCallStack => Payload -> Put +encodePayload pld = do + encodeChainwebVersionCode (_payloadChainwebVersion pld) + encodeChainId (_payloadChainId pld) + encodeBlockHeight (_payloadBlockHeight pld) + encodeMinerReward (_payloadMinerReward pld) + encodeChainId (_payloadRedeemChain pld) + encodeAccount (_payloadRedeemAccount pld) + +decodePayload :: HasCallStack => Get Payload +decodePayload = do + pld <- Payload + <$> decodeChainwebVersionCode + <*> decodeChainId + <*> decodeBlockHeight + <*> decodeMinerReward + <*> decodeChainId + <*> decodeAccount + <*> pure (error "Chainweb.PayloadProvider.Minimal.decodePayload: attempt decode hash") + return pld { _payloadHash = computeHash pld } + +-- -------------------------------------------------------------------------- -- + +genesisPayload + :: HasCallStack + => HasVersion + => HasChainId cid + => cid + -> Payload +genesisPayload cid + | payloadProviderTypeForChain cid /= MinimalProvider = + error "Chainweb.PayloadProvider.Minimal.Payload.genesisPayload: chain does not use minimal provider" + | otherwise = pld + where + genHeight = genesisBlockHeight (_chainId cid) + pld = Payload + { _payloadChainwebVersion = _versionCode implicitVersion + , _payloadChainId = _chainId cid + , _payloadBlockHeight = genHeight + , _payloadMinerReward = MinerReward 0 + -- genesis blocks are not mined, hence there is no reward. + , _payloadRedeemChain = _chainId cid + -- There is nothing to redeem in a genesis block. + , _payloadRedeemAccount = Account mempty + -- There is nothing to redeem in a genesis block. Even if this would + -- be valid Account on some chain, the redeem chain is fixed to be + -- the chain of the block itself and the reward is 0. + , _payloadHash = computeHash pld + } + +newPayload + :: HasCallStack + => HasVersion + => HasChainId cid + => cid + -> BlockHeight + -> MinerReward + -> ChainId + -> Account + -> Payload +newPayload c h r rc acc = pld + where + pld = Payload + { _payloadChainwebVersion = _versionCode implicitVersion + , _payloadChainId = _chainId c + , _payloadBlockHeight = h + , _payloadMinerReward = r + , _payloadRedeemChain = rc + , _payloadRedeemAccount = acc + , _payloadHash = computeHash pld + } + +-- -------------------------------------------------------------------------- -- +-- MerkleLog Entry + +instance MerkleHashAlgorithm a => IsMerkleLogEntry a ChainwebHashTag Payload + where + type Tag @ChainwebHashTag Payload = MinimalPayloadTag + toMerkleNode = encodeMerkleInputNode encodePayload + fromMerkleNode = decodeMerkleInputNode decodePayload + {-# INLINE toMerkleNode #-} + {-# INLINE fromMerkleNode #-} + +-- -------------------------------------------------------------------------- -- +-- MerkleLog Instance + +instance HasMerkleLog ChainwebMerkleHashAlgorithm ChainwebHashTag Payload where + + -- /IMPORTANT/ a types must occur at most once in this list + type MerkleLogHeader Payload = '[Payload] + type MerkleLogBody Payload = Void + + toLog h = newMerkleLog @ChainwebMerkleHashAlgorithm entries + where + entries = h :+: emptyBody + + fromLog l = pld + { _payloadHash = computeHash pld + } + where + (pld :+: _) = _merkleLogEntries l + +-- -------------------------------------------------------------------------- -- +-- Getter + +payloadMinerReward :: Getter Payload MinerReward +payloadMinerReward = to _payloadMinerReward + +payloadChainwebVersion :: Getter Payload ChainwebVersionCode +payloadChainwebVersion = to _payloadChainwebVersion + +payloadChainId :: Getter Payload ChainId +payloadChainId = to _payloadChainId + +payloadBlockHeight :: Getter Payload BlockHeight +payloadBlockHeight = to _payloadBlockHeight + +payloadRedeemChain :: Getter Payload ChainId +payloadRedeemChain = to _payloadRedeemChain + +payloadRedeemAccount :: Getter Payload Account +payloadRedeemAccount = to _payloadRedeemAccount + +payloadHash :: Getter Payload BlockPayloadHash +payloadHash = to _payloadHash diff --git a/src/Chainweb/PayloadProvider/Minimal/PayloadDB.hs b/src/Chainweb/PayloadProvider/Minimal/PayloadDB.hs new file mode 100644 index 0000000000..57b168b4b1 --- /dev/null +++ b/src/Chainweb/PayloadProvider/Minimal/PayloadDB.hs @@ -0,0 +1,256 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuantifiedConstraints #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeSynonymInstances #-} + +-- | +-- Module: Chainweb.PayloadProvider.Minimal.PayloadDB +-- Copyright: Copyright © 2025 Kadena LLC. +-- License: MIT +-- Maintainer: Lars Kuhtz +-- Stability: experimental +-- +module Chainweb.PayloadProvider.Minimal.PayloadDB +( Configuration +, configuration +, PayloadDb +, initPayloadDb +, closePayloadDb +, withPayloadDb +, insertPayloadDb +, type RankedPayloadCas +) where + +import Chainweb.BlockHeight +import Chainweb.BlockPayloadHash +import Chainweb.MerkleUniverse +import Chainweb.PayloadProvider.Minimal.Payload +import Chainweb.Storage.Table +import Chainweb.Storage.Table.RocksDB +import Chainweb.Utils hiding (Codec) +import Chainweb.Utils.Serialization +import Chainweb.Version +import Control.DeepSeq (NFData) +import Control.Lens (view) +import Control.Monad.Catch +import Data.Aeson +import Data.ByteString qualified as B +import Data.Hashable (Hashable) +import Data.Text.Encoding qualified as T +import GHC.Generics (Generic) +import Numeric.Additive +import GHC.Stack + +-- -------------------------------------------------------------------------- -- +-- Exceptions + +type PayloadNotFoundException = PayloadNotFoundException_ ChainwebMerkleHashAlgorithm + +newtype PayloadNotFoundException_ a = PayloadNotFoundException (BlockPayloadHash_ a) + deriving (Show, Eq, Ord, Generic) + deriving anyclass (NFData, Hashable) + +instance Exception PayloadNotFoundException + +-- -------------------------------------------------------------------------- -- +-- | Configuration of the payload DB for the minimal payload provider +-- + +data Configuration = Configuration + { _configChainId' :: !ChainId + , _configRocksDb' :: !RocksDb + } + +_configRocksDb :: Configuration -> RocksDb +_configRocksDb = _configRocksDb' + +configuration + :: HasCallStack + => HasVersion + => HasChainId c + => c + -> RocksDb + -> Configuration +configuration c rdb + | payloadProviderTypeForChain c /= MinimalProvider = + error "Chainweb.PayloadProvider.Minimal.PayloadDB.configuration: chain does not use minimal provider" + | otherwise = Configuration + { _configChainId' = _chainId c + , _configRocksDb' = rdb + } + +instance HasChainId Configuration where + _chainId = _configChainId' + +-- -------------------------------------------------------------------------- -- +-- Ranked Block Payload (only used internally) + +newtype RankedPayload = RankedPayload { _getRankedPayload :: Payload } + deriving (Show, Generic) + deriving newtype (Eq, Ord, Hashable, ToJSON, FromJSON) + +instance IsCasValue RankedPayload where + type CasKeyType RankedPayload = RankedBlockPayloadHash + casKey (RankedPayload bh) + = RankedBlockPayloadHash (view payloadBlockHeight bh) (view payloadHash bh) + {-# INLINE casKey #-} + +type RankedPayloadCas tbl = Cas tbl RankedPayload + +-- -------------------------------------------------------------------------- -- +-- BlockRank (only used internally) + +newtype BlockRank = BlockRank { _getBlockRank :: BlockHeight } + deriving (Show, Generic) + deriving anyclass (NFData) + deriving newtype + ( Eq, Ord, Hashable, ToJSON, FromJSON + , AdditiveSemigroup, AdditiveAbelianSemigroup, AdditiveMonoid + , Num, Integral, Real, Enum + ) + +-- -------------------------------------------------------------------------- -- +-- Internal + +encodeRankedPayload :: RankedPayload -> B.ByteString +encodeRankedPayload = runPutS . encodePayload . _getRankedPayload +{-# INLINE encodeRankedPayload #-} + +decodeRankedPayload :: MonadThrow m => B.ByteString -> m RankedPayload +decodeRankedPayload bs = RankedPayload <$> runGetS decodePayload bs +{-# INLINE decodeRankedPayload #-} + +-- -------------------------------------------------------------------------- -- +-- Payload DB + +type PayloadDb tbl = PayloadDb_ ChainwebMerkleHashAlgorithm tbl + +data PayloadDb_ a tbl = PayloadDb + { _payloadDbChainId' :: !ChainId + , _payloadDbTable' :: !(tbl RankedBlockPayloadHash RankedPayload) + } + +_payloadDbTable :: PayloadDb_ a tbl -> tbl RankedBlockPayloadHash RankedPayload +_payloadDbTable = _payloadDbTable' + +instance HasChainId (PayloadDb_ a tbl) where + _chainId = _payloadDbChainId' + {-# INLINE _chainId #-} + +instance ReadableTable1 tbl => ReadableTable (PayloadDb_ a tbl) RankedBlockPayloadHash Payload where + tableLookup db k = fmap _getRankedPayload <$> tableLookup (_payloadDbTable db) k + {-# INLINE tableLookup #-} + +instance Table1 tbl => Table (PayloadDb_ a tbl) RankedBlockPayloadHash Payload where + tableInsert db k v = tableInsert (_payloadDbTable db) k (RankedPayload v) + tableDelete db k = tableDelete @_ @_ @RankedPayload (_payloadDbTable db) k + {-# INLINE tableInsert #-} + {-# INLINE tableDelete #-} + +-- -------------------------------------------------------------------------- -- +-- Initialization + +-- | Initialize a database handle +-- +initPayloadDb :: HasVersion => Configuration -> IO (PayloadDb_ a RocksDbTable) +initPayloadDb config = do + -- Add genesis payload + dbAddChecked db (genesisPayload config) + return db + where + cid = _chainId config + cidNs = T.encodeUtf8 (toText cid) + + payloadTable = newTable + (_configRocksDb config) + (Chainweb.Storage.Table.RocksDB.Codec encodeRankedPayload decodeRankedPayload) + (Codec (runPutS . encodeRankedBlockPayloadHash) (runGetS decodeRankedBlockPayloadHash)) + ["MinimalProvider", cidNs, "payload"] + + !db = PayloadDb + { _payloadDbChainId' = cid + , _payloadDbTable' = payloadTable + } + +-- | Close a database handle and release all resources +-- +closePayloadDb :: PayloadDb_ a tbl -> IO () +closePayloadDb _ = return () + +withPayloadDb + :: HasVersion + => RocksDb + -> ChainId + -> (PayloadDb_ a RocksDbTable -> IO b) + -> IO b +withPayloadDb db cid = bracket start closePayloadDb + where + start = initPayloadDb $ configuration cid db + +-- -------------------------------------------------------------------------- -- +-- Validated Payload + +-- NOTE: the constructor of this type is intentionally NOT exported. Value of +-- this type must be only created via functions from this module. +-- +newtype ValidatedPayload = ValidatedPayload Payload + deriving (Show, Eq, Generic) + +_validatedPayload :: ValidatedPayload -> Payload +_validatedPayload (ValidatedPayload h) = h +{-# INLINE _validatedPayload #-} + +-- -------------------------------------------------------------------------- -- +-- Insertions + +insertPayloadDb :: Table1 tbl => PayloadDb_ a tbl -> ValidatedPayload -> IO () +insertPayloadDb db = dbAddChecked db . _validatedPayload +{-# INLINE insertPayloadDb #-} + +-- unsafeInsertPayloadDb :: Table1 tbl => PayloadDb_ a tbl -> Payload -> IO () +-- unsafeInsertPayloadDb = dbAddChecked +-- {-# INLINE unsafeInsertPayloadDb #-} + +-- -------------------------------------------------------------------------- -- +-- Insert +-- +-- Only functions in this section are allowed to modify values of the Db type. + +-- | A a new entry to the database +-- +-- Updates all indices. +-- +dbAddChecked + :: Table1 tbl -- Cas (tbl RankedBlockPayloadHash Payload) Payload + => PayloadDb_ a tbl + -> Payload + -> IO () +dbAddChecked db e = + unlessM (tableMember db ek) dbAddCheckedInternal + where + ek = RankedBlockPayloadHash + (view payloadBlockHeight e) + (view payloadHash e) + + -- Internal helper methods + + -- TODO add validation and check that parent exists (except for height 0). + + -- | Unchecked addition + -- + -- ASSUMES that + -- + -- * Item is not yet in database + -- + dbAddCheckedInternal = casInsert (_payloadDbTable db) (RankedPayload e) diff --git a/src/Chainweb/PayloadProvider/P2P.hs b/src/Chainweb/PayloadProvider/P2P.hs new file mode 100644 index 0000000000..e97a4f4db5 --- /dev/null +++ b/src/Chainweb/PayloadProvider/P2P.hs @@ -0,0 +1,428 @@ +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE QuantifiedConstraints #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE NumericUnderscores #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} + +-- | +-- Module: Chainweb.PayloadProvider.P2P +-- Copyright: Copyright © 2024 Kadena LLC. +-- License: MIT +-- Maintainer: Lars Kuhtz +-- Stability: experimental +-- +-- FIXME: rename this module into Chainweb.PayloadProvider.PayloadStore +-- +module Chainweb.PayloadProvider.P2P +( PayloadStore(..) +, newPayloadStore +, getPayload +, getPayloads +, getPayloadSimple +) where + +import Chainweb.BlockPayloadHash +import Chainweb.Storage.Table +import Chainweb.Utils +import Control.Monad.Catch +import Data.Aeson (object, (.=)) +import Data.Functor +import Data.LogMessage +import Data.PQueue +import Data.TaskMap +import Data.Text qualified as T +import Network.HTTP.Client qualified as HTTP +import P2P.Peer +import P2P.Session +import P2P.TaskQueue +import Servant.Client +import System.LogLevel +import Utils.Logging.Trace +import Chainweb.Storage.Table.HashMap (emptyTable) +import Control.Concurrent.Async +import Control.Exception +import Chainweb.Core.Brief +import P2P.Utils + +-- -------------------------------------------------------------------------- -- +-- Response Timeout Constants + +-- | For P2P queries we lower the response timeout to 500ms. This is tight +-- but guarantees that the task isn't blocked for too long and retries +-- another node quickly in case the first node isn't available. If no node +-- in the network is able to serve that quickly the local node is out of +-- luck. However, 500ms should be sufficient for a well-connected node +-- anywhere on the world. Otherwise, the node would have trouble anyways. +-- +taskResponseTimeout :: HTTP.ResponseTimeout +taskResponseTimeout = HTTP.responseTimeoutMicro 500_000 + +pullOriginResponseTimeout :: HTTP.ResponseTimeout +pullOriginResponseTimeout = HTTP.responseTimeoutMicro 1_000_000 + +-- | Set the response timeout on all requests made with the ClientEnv This +-- overwrites the default response timeout of the connection manager. +-- +setResponseTimeout :: HTTP.ResponseTimeout -> ClientEnv -> ClientEnv +setResponseTimeout t env = env + { makeClientRequest = \u r -> defaultMakeClientRequest u r <&> \req -> req + { HTTP.responseTimeout = t + } + } + +-- -------------------------------------------------------------------------- -- +-- Payload Store + +-- | P2P network service handle for payloads. +-- +-- It facilities storage and synchronization of payloads accross nodes in the +-- P2P network. +-- +-- Payload data is indexed by the ranked block payload hash. There are no +-- constraints on the payload data values. +-- +data PayloadStore tbl a = PayloadStore + { _payloadStoreTable :: !tbl + -- ^ Content addressed store for storing payload data + , _payloadStoreMemo :: !(TaskMap RankedBlockPayloadHash a) + -- ^ Internal memo table for active P2P tasks. Due to the way how cut + -- resolution works the same payload may be requested several times + -- while the first request is still processed. This map helps to avoid + -- running a P2P task redundantly. + , _payloadStoreQueue :: !(PQueue (Task ClientEnv a)) + -- ^ task queue for scheduling tasks with the P2P task server. This + -- Queue should be shared across chains (and possibly also across + -- payload providers, although for that we would have to hide the + -- payload type parameter, both here as well as in the HTTP client) + , _payloadStoreLogFunction :: !LogFunction + -- ^ LogFunction + , _payloadStoreMgr :: !(Maybe HTTP.Manager) + -- ^ Manager object for making HTTP requests + , _payloadStoreGetPayloadClient :: !(RankedBlockPayloadHash -> ClientM a) + -- ^ HTTP client for querying payloads (provided by the PayloadProvider) + -- + -- There is a default Payload REST API in + -- "Chainweb.PayloadProvider.P2P.RestAPI" that can be used in common + -- cases. + -- + -- NOTE: This used to have a ChainId parameter which allowed sharing of + -- the store between payload providers with the same payload type. This + -- could make it easier to limit concurrency across chains. If this is + -- needed the ChainId parameter would have to be re-added. + , _payloadStoreGetPayloadBatchClient :: !([RankedBlockPayloadHash] -> ClientM [Maybe a]) + -- ^ HTTP client for querying payloads in batches (provided by the + -- PayloadProvider) + -- + -- There is a default Payload REST API in + -- "Chainweb.PayloadProvider.P2P.RestAPI" that can be used in common + -- cases. + -- + -- The same considerations apply as for '_payloadStoreGetPayloadClient'. + } + +-- FIXME: not sure whether the following instances are a good idea... + +-- | Expose the /local/ payload table. +-- +-- NOTE, this does /not/ look for payloads in P2P network. Data available in +-- this table is guaranteed to be fully validated, both by the execution client +-- as well as against the evaluation context. +-- +instance + (ReadableTable pdb RankedBlockPayloadHash a) + => ReadableTable (PayloadStore pdb a) RankedBlockPayloadHash a + where + tableLookup = tableLookup . _payloadStoreTable + tableLookupBatch' s = tableLookupBatch' (_payloadStoreTable s) + tableMember = tableMember . _payloadStoreTable + +-- | Expose the /local/ payload table. +-- +-- NOTE, this does /not/ look for payloads in P2P network. Data available in +-- this table is guaranteed to be fully validated, both by the execution client +-- as well as against the evaluation context. +-- +instance + (Table pdb RankedBlockPayloadHash a) + => Table (PayloadStore pdb a) RankedBlockPayloadHash a + where + tableInsert = tableInsert . _payloadStoreTable + tableInsertBatch s = tableInsertBatch (_payloadStoreTable s) + tableDelete s = tableDelete (_payloadStoreTable s) + tableDeleteBatch s = tableDeleteBatch (_payloadStoreTable s) + +-- -------------------------------------------------------------------------- -- +-- Initialization + +-- | FIXME: +-- +-- Why not move a generic payload DB here, so that it can be managed by the +-- payload store. (We can offer more complex payload providers to provide there +-- own version if desired.) +-- +-- FIXME: +-- +-- The queue needs to be hooked up to a p2p node. Where is that done? Given +-- that a single p2p node can serve many payload stores, the queue should +-- probably be passed as a parameter. +-- +newPayloadStore + :: ReadableTable tbl RankedBlockPayloadHash a + => Maybe HTTP.Manager + -- ^ Manager for P2P networking. This manager should be shared by all + -- P2P networks. + -> LogFunction + -> tbl + -- ^ initialized Payload DB. In particular it is expected that genesis + -- payloads are already available. + -> (RankedBlockPayloadHash -> ClientM a) + -> ([RankedBlockPayloadHash] -> ClientM [Maybe a]) + -> IO (PayloadStore tbl a) +newPayloadStore mgr logfun payloadDb cli bcli = do + payloadTaskQueue <- newEmptyPQueue _taskPriority _taskId Nothing + payloadMemo <- new + return $! PayloadStore + { _payloadStoreTable = payloadDb + , _payloadStoreMemo = payloadMemo + , _payloadStoreQueue = payloadTaskQueue + , _payloadStoreLogFunction = logfun + , _payloadStoreMgr = mgr + , _payloadStoreGetPayloadClient = cli + , _payloadStoreGetPayloadBatchClient = bcli + } + +-- -------------------------------------------------------------------------- -- +-- Get Payload + +-- | Simple version of getPayload +-- +-- Mostly useful for testing and debugging +-- +getPayloadSimple + :: forall a tbl + . ReadableTable tbl RankedBlockPayloadHash a + => CasKeyType a ~ RankedBlockPayloadHash + => PayloadStore tbl a + -> RankedBlockPayloadHash + -> IO a +getPayloadSimple s r = do + candidates <- emptyTable + getPayload s candidates prio Nothing r + where + prio = Priority $ negate $ int $ _rankedBlockPayloadHashHeight r + +-- | Query a payload either from the local store, or the origin, or P2P network. +-- +-- The payload is only queried and not inserted into the local store. We want to +-- insert it only after it got validate by the payload provider. +-- +getPayload + :: forall a tbl candidateTbl + . ReadableTable tbl RankedBlockPayloadHash a + => Table candidateTbl RankedBlockPayloadHash a + => PayloadStore tbl a + -> candidateTbl + -> Priority + -- ^ larger values get precedence in the P2P task queue. A good + -- heuristics is to use the negated block height. + -> Maybe PeerInfo + -- ^ Peer from with the BlockPayloadHash originated, if available. + -> RankedBlockPayloadHash + -> IO a +getPayload s candidateStore priority maybeOrigin payloadHash = do + logfun Debug $ "getPayload: " <> toText payloadHash + tableLookup candidateStore payloadHash >>= \case + Just !x -> return x + Nothing -> tableLookup tbl payloadHash >>= \case + Just !x -> return x + Nothing -> memo memoMap payloadHash $ \_ -> + pullOrigin payloadHash maybeOrigin >>= \case + Nothing -> do + t <- queryPayloadTask payloadHash + pQueueInsert queue t + awaitTask t + Just !x -> return x + where + maybeMgr = _payloadStoreMgr s + tbl = _payloadStoreTable s + memoMap = _payloadStoreMemo s + queue = _payloadStoreQueue s + + logfun :: LogLevel -> T.Text -> IO () + logfun = _payloadStoreLogFunction s + + traceLogfun :: forall m . LogMessage m => LogLevel -> m -> IO () + traceLogfun = _payloadStoreLogFunction s + + taskMsg k msg = "payload task " <> toText k <> " @ " <> toText payloadHash <> ": " <> msg + + traceLabel subfun = + "Chainweb.PayloadProvider.P2P.getPayload." <> subfun + + -- Only used for logging trace telemetry + rankedHashJson rh = object + [ "height" .= _rankedBlockPayloadHashHeight rh + , "hash" .= _rankedBlockPayloadHashHash rh + ] + + -- | Try to pull a block payload from the given origin peer + -- + pullOrigin :: RankedBlockPayloadHash -> Maybe PeerInfo -> IO (Maybe a) + pullOrigin k Nothing = do + logfun Debug $ taskMsg k "no origin" + return Nothing + pullOrigin k (Just origin) + | Nothing <- maybeMgr = do + logfun Debug $ taskMsg k "no origin" + return Nothing + | Just mgr <- maybeMgr = do + let originEnv = setResponseTimeout pullOriginResponseTimeout $ peerInfoClientEnv mgr origin + logfun Debug $ taskMsg k "lookup origin" + !r <- trace traceLogfun (traceLabel "pullOrigin") (rankedHashJson k) 0 + $ runClientM (_payloadStoreGetPayloadClient s k) originEnv + case r of + (Right !x) -> do + logfun Debug $ taskMsg k "received from origin" + return $ Just x + Left (e :: ClientError) -> do + logfun Debug $ taskMsg k $ "failed to receive from origin: " <> renderClientError e + return Nothing + + -- | Query a block payload via the task queue + -- + queryPayloadTask :: RankedBlockPayloadHash -> IO (Task ClientEnv a) + queryPayloadTask k = newTask (TaskId $ toText k) priority $ \logg env -> do + logg @T.Text Debug $ taskMsg k "query remote block payload" + let taskEnv = setResponseTimeout taskResponseTimeout env + !r <- trace traceLogfun (traceLabel "queryPayloadTask") (rankedHashJson k) (let Priority i = priority in i) + $ runClientM (_payloadStoreGetPayloadClient s k) taskEnv + case r of + (Right !x) -> do + logg @T.Text Debug $ taskMsg k "received remote payload" + return x + Left (e :: ClientError) -> do + logg @T.Text Debug $ taskMsg k $ "failed: " <> renderClientError e + throwM e + +-- | Query a payloads either from the local store, or the origin, or P2P network. +-- +-- The payloads are only queried and not inserted into the local store. We want to +-- insert it only after it got validate by the payload provider. +-- +getPayloads + :: forall a tbl candidateTbl + . ReadableTable tbl RankedBlockPayloadHash a + => Table candidateTbl RankedBlockPayloadHash a + => PayloadStore tbl a + -> candidateTbl + -> Priority + -- ^ larger values get precedence in the P2P task queue. A good + -- heuristics is to use the negated block height. + -> Maybe PeerInfo + -- ^ Peer from with the BlockPayloadHash originated, if available. + -> [RankedBlockPayloadHash] + -> IO [(RankedBlockPayloadHash, a)] +getPayloads s candidateStore priority maybeOrigin payloadHashes = do + logfun Debug $ "getPayloads: " <> brief payloadHashes + (missing, plds0) <- collect @_ @a payloadHashes <$> tableLookupBatch candidateStore payloadHashes + (missing', plds1) <- collect @_ @a missing <$> tableLookupBatch tbl missing + + -- FIXME We do this output of hte memo map, so this is not shared and we + -- may call this more than once for the same batch. It's not clear + -- whether this can actually happen in practice, since the resolution of + -- payloads is implicitely guarded by the resolution of headers. + -- But we should double check that. + -- Generally, it might be useful to move memoization up to the header + -- level, since there should be no sharing below that level. + -- + (missing'', plds2) <- collect @_ @a missing' + <$> pullOriginBatch missing' maybeOrigin + + plds3 <- forConcurrently missing'' $ \k -> do + v <- memo memoMap k $ \_ -> do + t <- queryPayloadTask k + pQueueInsert queue t + awaitTask t + return (k, v) + return $! mconcat [plds0, plds1, plds2, plds3] + + where + maybeMgr = _payloadStoreMgr s + tbl = _payloadStoreTable s + memoMap = _payloadStoreMemo s + queue = _payloadStoreQueue s + + logfun :: LogLevel -> T.Text -> IO () + logfun = _payloadStoreLogFunction s + + collect :: [k] -> [Maybe v] -> ([k], [(k, v)]) + collect [] [] = ([], []) + collect (k:ks) (v:vs) = case v of + Just v' -> (ks, (k, v'):vs') + Nothing -> (k:ks', vs') + where + (ks', vs') = collect ks vs + collect _ _ = throw $ InternalInvariantViolation "Chainweb.PayloadProvider.P2P.collect: length mismatch" + + traceLogfun :: forall m . LogMessage m => LogLevel -> m -> IO () + traceLogfun = _payloadStoreLogFunction s + + taskMsg _ks msg = "payload task " <> "batch" <> " @ " <> brief payloadHashes <> ": " <> msg + + traceLabel subfun = + "Chainweb.PayloadProvider.P2P.getPayload." <> subfun + + -- Only used for logging trace telemetry + rankedHashJson rh = object + [ "height" .= _rankedBlockPayloadHashHeight rh + , "hash" .= _rankedBlockPayloadHashHash rh + ] + + -- | Try to pull block payloads from the given origin peer + -- + -- FIXME: respect maximum batch sizes of P2P API. + -- + pullOriginBatch :: [RankedBlockPayloadHash] -> Maybe PeerInfo -> IO [Maybe a] + pullOriginBatch ks Nothing = do + logfun Debug $ taskMsg ks "no origin" + return [Nothing | _ <- ks] + pullOriginBatch ks (Just origin) + | Nothing <- maybeMgr = do + logfun Debug $ taskMsg ks "no origin" + return [Nothing | _ <- ks] + | Just mgr <- maybeMgr = do + let originEnv = setResponseTimeout pullOriginResponseTimeout $ peerInfoClientEnv mgr origin + logfun Debug $ taskMsg ks "lookup origin" + !r <- trace traceLogfun (traceLabel "pullOrigin") (rankedHashJson <$> ks) 0 + $ runClientM (_payloadStoreGetPayloadBatchClient s ks) originEnv + case r of + (Right !x) -> do + logfun Debug $ taskMsg ks "received from origin" + return x + Left (e :: ClientError) -> do + logfun Debug $ taskMsg ks $ "failed to receive from origin: " <> renderClientError e + return [Nothing | _ <- ks] + + -- | Query a block payload via the task queue + -- + queryPayloadTask :: RankedBlockPayloadHash -> IO (Task ClientEnv a) + queryPayloadTask k = newTask (TaskId $ toText k) priority $ \logg env -> do + logg @T.Text Debug $ taskMsg k "query remote block payload" + let taskEnv = setResponseTimeout taskResponseTimeout env + !r <- trace traceLogfun (traceLabel "queryPayloadTask") (rankedHashJson k) (let Priority i = priority in i) + $ runClientM (_payloadStoreGetPayloadClient s k) taskEnv + case r of + (Right !x) -> do + logg @T.Text Debug $ taskMsg k "received remote payload" + return x + Left (e :: ClientError) -> do + logg @T.Text Debug $ taskMsg k $ "failed: " <> renderClientError e + throwM e diff --git a/src/Chainweb/PayloadProvider/P2P/RestAPI.hs b/src/Chainweb/PayloadProvider/P2P/RestAPI.hs new file mode 100644 index 0000000000..721f8cc8bf --- /dev/null +++ b/src/Chainweb/PayloadProvider/P2P/RestAPI.hs @@ -0,0 +1,341 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeAbstractions #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} + +{-# OPTIONS_GHC -Wno-orphans #-} +{-# LANGUAGE LambdaCase #-} + +-- | +-- Module: Chainweb.PayloadProvider.P2P.RestAPI +-- Copyright: Copyright © 2024 Kadena LLC. +-- License: MIT +-- Maintainer: Lars Kuhtz +-- Stability: experimental +-- +module Chainweb.PayloadProvider.P2P.RestAPI +( PayloadBatchLimit(..) +, BatchBody(..) +, IsPayloadProvider(..) +, RestPayload(..) +, PayloadList(..) + +-- * Payload API +, type PayloadApi +, payloadApi +, type PayloadGetApi +, payloadGetApi +, type PayloadPostApi +, payloadPostApi +-- ** Legacy API +, type ServicePayloadGetApi +, servicePayloadGetApi + +-- * SomePayloadApi +, somePayloadApi +, somePayloadApis +) where + +import Chainweb.BlockHeader +import Chainweb.BlockHeaderDB.RestAPI () +import Chainweb.BlockHeight +import Chainweb.BlockPayloadHash +import Chainweb.ChainId +import Chainweb.Pact.Payload qualified as Pact +import Chainweb.PayloadProvider.EVM.ExecutionPayload qualified as EVM +import Chainweb.PayloadProvider.Minimal.Payload qualified as Minimal +import Chainweb.Ranked +import Chainweb.RestAPI.Orphans () +import Chainweb.RestAPI.Utils +import Chainweb.Utils +import Chainweb.Utils.Serialization (runPutL, putWord32le, runGetEitherL, getWord32le) +import Chainweb.Version +import Control.Monad +import Control.Monad.Identity +import Data.Aeson +import Data.Kind +import Data.Maybe +import Data.Proxy +import Ethereum.RLP qualified as EVM +import GHC.Generics (Generic) +import GHC.TypeNats +import Servant.API +import Data.Singletons + +-- -------------------------------------------------------------------------- -- +-- Constants + +-- | The maximum number of items that are returned in a batch +-- +newtype PayloadBatchLimit = PayloadBatchLimit Natural + deriving (Show, Eq) + deriving newtype (Ord, Enum, Num, Real, Integral, ToJSON, FromJSON) + +-- -------------------------------------------------------------------------- -- +-- IsPayload Provider Class +-- +-- NOTE: +-- +-- Currently, this class is only available for provider P2P. It might be useful +-- more generally for the implementation of payload providers. However, not all +-- payload providers use payload data that is visible to the chainweb-node +-- beacon. Therefore PayloadData concepts must not leak to the ChainwebVersion +-- level and the definition of the PayloadProviderType tag. Also, the +-- 'PayloadProvider' class as well as the moduel "Chainweb.PayloadProvider" must +-- not depend on it. +-- +-- TODO: +-- +-- - Todo rename payload that is visible to the chainweb-node beacon to +-- something like "PayloadData" or "PayloadInfo" to indicate that it does not +-- represent the complete block payload +-- +-- - In the module hierachy, distinguishy more clearly between general Payload +-- Provider features, that concern all payload providers, and auxiliary +-- payload provider features, that serve as optional utils to implement +-- aspects of payload providers that are hosted in the chainweb-node beacon. +-- + +-- | Class of Payload Provider APIs +-- +-- We need to dispatch the APIs for different payload providers at type level +-- because servant composes APIs on type level. Once we run payload providers in +-- different processes with their own server instances we don't need that any +-- more. +-- +class + ( ToJSON (PayloadType p) + , FromJSON (PayloadType p) + , ToJSON (PayloadBatchType p) + , FromJSON (PayloadBatchType p) + , MimeRender OctetStream (PayloadType p) + , MimeRender OctetStream (PayloadBatchType p) + ) + => IsPayloadProvider (p :: PayloadProviderType) + where + type PayloadType p :: Type + type PayloadBatchType p :: Type + + batch :: [Maybe (PayloadType p)] -> PayloadBatchType p + + -- default Payload Batch limit + p2pPayloadBatchLimit :: PayloadBatchLimit + p2pPayloadBatchLimit = 0 + +-- -------------------------------------------------------------------------- -- + +-- | The body of a batch payload request. +-- +newtype BatchBody = BatchBody [RankedBlockPayloadHash] + deriving (Show, Eq, Generic) + deriving (ToJSON, FromJSON) via [JsonRanked "hash" BlockPayloadHash] + +-- -------------------------------------------------------------------------- -- +-- Wrapper for Rest API Payloads + +-- | Wrapper for Rest API Payloads +-- +-- The purpose of this newtype is to avoid IncohrentInstances when resolving +-- Servants type classes. +-- +newtype RestPayload a = RestPayload { _restPayload :: a } + deriving (Show, Eq) + deriving newtype (ToJSON, FromJSON) + +instance MimeRender OctetStream a => MimeRender OctetStream (RestPayload a) where + mimeRender p = mimeRender p . _restPayload + +-- -------------------------------------------------------------------------- -- +-- Legacy Payload GET API + +-- | The legacy API is not supported by all Payload Providers. +-- +-- @GET \/chainweb\/\\/\\/chain\/\\/payload\/\@ +-- +-- * For Pact the result is the PayloadData +-- * For EVM the result is the EVM execution header +-- +type ServicePayloadGetApi_ (v :: ChainwebVersionT) (c :: ChainIdT) (p :: PayloadProviderType) + = "payload" + :> Capture "BlockPayloadHash" BlockPayloadHash + :> QueryParam "height" BlockHeight + :> Get '[JSON, OctetStream] (RestPayload (PayloadType p)) + +type ServicePayloadGetApi (v :: ChainwebVersionT) (c :: ChainIdT) (p :: PayloadProviderType) + = 'ChainwebEndpoint v + :> ChainEndpoint c + :> ServicePayloadGetApi_ v c p + +servicePayloadGetApi + :: forall (v :: ChainwebVersionT) (c :: ChainIdT) (p :: PayloadProviderType) + . IsPayloadProvider p + => Proxy (ServicePayloadGetApi v c p) +servicePayloadGetApi = Proxy + +-- -------------------------------------------------------------------------- -- +-- Payload GET API + +-- | @GET \/chainweb\/\\/\\/chain\/\\/height\/\\/payload\/\@ +-- +-- * For Pact the result is the PayloadData +-- * For EVM the result is the EVM execution header +-- +type PayloadGetApi_ (v :: ChainwebVersionT) (c :: ChainIdT) (p :: PayloadProviderType) + = "height" + :> Capture "BlockHeight" BlockHeight + :> "payload" + :> Capture "BlockPayloadHash" BlockPayloadHash + :> Get '[JSON, OctetStream] (RestPayload (PayloadType p)) + +type PayloadGetApi (v :: ChainwebVersionT) (c :: ChainIdT) (p :: PayloadProviderType) + = 'ChainwebEndpoint v :> ChainEndpoint c :> PayloadGetApi_ v c p + +payloadGetApi + :: forall (v :: ChainwebVersionT) (c :: ChainIdT) (p :: PayloadProviderType) + . Proxy (PayloadGetApi v c p) +payloadGetApi = Proxy + +-- -------------------------------------------------------------------------- -- +-- Payload POST API + +-- | @POST \/chainweb\/\\/\\/chain\/\\/payload\/batch@ +-- +-- The query may return any number (including none) of the requested payload +-- data. Results are returned in any order. +-- +type PayloadPostApi_ (v :: ChainwebVersionT) (c :: ChainIdT) (p :: PayloadProviderType) + = "payload" + :> "batch" + :> ReqBody '[JSON] BatchBody + :> Post '[JSON, OctetStream] (RestPayload (PayloadBatchType p)) + +type PayloadPostApi (v :: ChainwebVersionT) (c :: ChainIdT) (p :: PayloadProviderType) + = 'ChainwebEndpoint v :> ChainEndpoint c :> PayloadPostApi_ v c p + +payloadPostApi + :: forall (v :: ChainwebVersionT) (c :: ChainIdT) (p :: PayloadProviderType) + . Proxy (PayloadPostApi v c p) +payloadPostApi = Proxy + +-- -------------------------------------------------------------------------- -- +-- Payload API + +type PayloadApi v c p + = PayloadGetApi v c p + :<|> PayloadPostApi v c p + +payloadApi + :: forall (v :: ChainwebVersionT) (c :: ChainIdT) (p :: PayloadProviderType) + . Proxy (PayloadApi v c p) +payloadApi = Proxy + +-- -------------------------------------------------------------------------- -- +-- Some Payload API + +-- | Dispatch provider specific APIs +-- +-- FIXME: Should we split this up and move it into the scope of the respective +-- payload providers. Otherwise this module has to depend on the payload +-- providers. +-- +somePayloadApi + :: IsPayloadProvider 'MinimalProvider + => IsPayloadProvider 'PactProvider + => HasVersion + => ChainId + -> SomeApi +somePayloadApi c = runIdentity $ do + SomeChainwebVersionT (_ :: Proxy v') <- return $ someChainwebVersionVal + SomeChainIdT (_ :: Proxy c') <- return $ someChainIdVal c + withSomeSing (payloadProviderTypeForChain c) $ \case + SMinimalProvider -> + return $! SomeApi (payloadApi @v' @c' @'MinimalProvider) + SPactProvider -> + return $! SomeApi (payloadApi @v' @c' @'PactProvider) + SEvmProvider @n _ -> + return $! SomeApi (payloadApi @v' @c' @('EvmProvider n)) + +somePayloadApis :: HasVersion => [ChainId] -> SomeApi +somePayloadApis = mconcat . fmap somePayloadApi + +-- -------------------------------------------------------------------------- -- +-- Implementations of IsPayloadProvider +-- -------------------------------------------------------------------------- -- + +-- | IsPayloadProvider instance for the Minimal Payload provider +-- +instance IsPayloadProvider MinimalProvider where + type PayloadType MinimalProvider = Minimal.Payload + type PayloadBatchType MinimalProvider = [Minimal.Payload] + p2pPayloadBatchLimit = 20 -- FIXME + batch = catMaybes + +instance MimeRender OctetStream Minimal.Payload where + mimeRender _ = runPutL . Minimal.encodePayload + {-# INLINE mimeRender #-} + +instance MimeUnrender OctetStream Minimal.Payload where + mimeUnrender _ = runGetEitherL Minimal.decodePayload + {-# INLINE mimeUnrender #-} + +instance MimeRender OctetStream [Minimal.Payload] where + mimeRender _ ps = runPutL $ do + putWord32le (int $ length ps) + mapM_ Minimal.encodePayload ps + +instance MimeUnrender OctetStream [Minimal.Payload] where + mimeUnrender _ = runGetEitherL $ do + l <- int <$> getWord32le + replicateM l Minimal.decodePayload + {-# INLINE mimeUnrender #-} + +-- | IsPayloadProvider instance for the Pact Payload provider +-- +-- FIXME: fix this instance to conform with the current API (or even +-- better fix the current bad binary encoding of payload data). +-- +instance IsPayloadProvider PactProvider where + type PayloadType PactProvider = Pact.PayloadData + type PayloadBatchType PactProvider = Pact.PayloadDataList + p2pPayloadBatchLimit = 20 -- FIXME + batch = Pact.PayloadDataList . catMaybes + +-- | IsPayloadProvider instance for the Pact Payload provider +-- +instance IsPayloadProvider (EvmProvider n) where + type PayloadType (EvmProvider n) = EVM.Payload + type PayloadBatchType (EvmProvider n) = PayloadList + p2pPayloadBatchLimit = 20 -- FIXME + batch = PayloadList . catMaybes + +newtype PayloadList = PayloadList { _payloadList :: [EVM.Payload] } + deriving (Show, Eq, Generic) + deriving newtype (ToJSON, FromJSON, EVM.RLP) + +instance MimeRender OctetStream EVM.Payload where + mimeRender _ = EVM.putRlpLazyByteString + {-# INLINE mimeRender #-} + +instance MimeUnrender OctetStream EVM.Payload where + mimeUnrender _ = EVM.getLazy EVM.getRlp + {-# INLINE mimeUnrender #-} + +instance MimeRender OctetStream PayloadList where + mimeRender _ = EVM.putRlpLazyByteString + {-# INLINE mimeRender #-} + +instance MimeUnrender OctetStream PayloadList where + mimeUnrender _ = EVM.getLazy EVM.getRlp + {-# INLINE mimeUnrender #-} diff --git a/src/Chainweb/PayloadProvider/P2P/RestAPI/Client.hs b/src/Chainweb/PayloadProvider/P2P/RestAPI/Client.hs new file mode 100644 index 0000000000..b3d8d38a51 --- /dev/null +++ b/src/Chainweb/PayloadProvider/P2P/RestAPI/Client.hs @@ -0,0 +1,93 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} + +-- | +-- Module: Chainweb.PayloadProvider.P2P.RestAPI.Client +-- Copyright: Copyright © 2018 - 2020 Kadena LLC. +-- License: MIT +-- Maintainer: Lars Kuhtz +-- Stability: experimental +-- +-- Client implementation of the block payload REST API +-- +module Chainweb.PayloadProvider.P2P.RestAPI.Client +( payloadClient +, payloadBatchClient +-- , outputsClient +-- , outputsBatchClient +) where + +import Servant.Client + +-- internal modules + +import Chainweb.ChainId +import Chainweb.PayloadProvider.P2P.RestAPI +import Chainweb.RestAPI.Orphans () +import Chainweb.Version +import Chainweb.BlockPayloadHash + +-- -------------------------------------------------------------------------- -- +-- GET Payload Client + +payloadClient + :: forall (v :: ChainwebVersionT) (c :: ChainIdT) (p :: PayloadProviderType) + . KnownChainwebVersionSymbol v + => IsPayloadProvider p + => KnownChainIdSymbol c + => RankedBlockPayloadHash + -> ClientM (PayloadType p) +payloadClient rh = _restPayload <$> client (payloadGetApi @v @c @p) height hash + where + height = _rankedBlockPayloadHashHeight rh + hash = _rankedBlockPayloadHashHash rh + +-- payloadClient +-- :: ChainwebVersion +-- -> ChainId +-- -> RankedBlockPayloadHash +-- -> ClientM (RestPayload (PayloadType p)) +-- payloadClient v c h = runIdentity $ do +-- SomeChainwebVersionT (_ :: Proxy v) <- return $ someChainwebVersionVal v +-- SomeChainIdT (_ :: Proxy c) <- return $ someChainIdVal c +-- case provider of +-- MinimalProvider -> +-- return $! payloadClient_ @v @c @'MinimalProvider h +-- PactProvider -> +-- return $! payloadClient_ @v @c @'PactProvider h +-- -- EvmProvider -> +-- -- return $! payloadClient_ @v @c @'PactProvider h +-- where +-- provider :: PayloadProviderType +-- provider = payloadProviderTypeForChain v c + +-- -------------------------------------------------------------------------- -- +-- Post Payload Batch Client + +payloadBatchClient + :: forall (v :: ChainwebVersionT) (c :: ChainIdT) (p :: PayloadProviderType) + . KnownChainwebVersionSymbol v + => IsPayloadProvider p + => KnownChainIdSymbol c + => [RankedBlockPayloadHash] + -> ClientM (PayloadBatchType p) +payloadBatchClient bb = _restPayload + <$> client (payloadPostApi @v @c @p) (BatchBody bb) + +-- +-- -- The query may return any number (including none) of the requested payload +-- -- data. Results are returned in any order. +-- -- +-- payloadBatchClient +-- :: ChainwebVersion +-- -> ChainId +-- -> BatchBody +-- -> ClientM PayloadDataList +-- payloadBatchClient v c k = runIdentity $ do +-- SomeChainwebVersionT (_ :: Proxy v) <- return $ someChainwebVersionVal v +-- SomeChainIdT (_ :: Proxy c) <- return $ someChainIdVal c +-- return $ payloadBatchClient_ @v @c k +-- diff --git a/src/Chainweb/PayloadProvider/P2P/RestAPI/Server.hs b/src/Chainweb/PayloadProvider/P2P/RestAPI/Server.hs new file mode 100644 index 0000000000..5a3e836627 --- /dev/null +++ b/src/Chainweb/PayloadProvider/P2P/RestAPI/Server.hs @@ -0,0 +1,172 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE AllowAmbiguousTypes #-} + +-- | +-- Module: Chainweb.Pact.Payload.RestAPI.Server +-- Copyright: Copyright © 2018 - 2020 Kadena LLC. +-- License: MIT +-- Maintainer: Lars Kuhtz +-- Stability: experimental +-- +-- Server implementation of the block payload REST API +-- +-- FIXME: consider to not expose the payload table directly, but only through an +-- API (possibly in the PayloadProvider class or may dedicated +-- PayloadProviderApi class). +-- Or, alternatively, create the apis along with the apis in the provider +-- initialization function internally and not in the resources module. +-- +module Chainweb.PayloadProvider.P2P.RestAPI.Server +( + somePayloadServer + +-- * Single Chain Server +, payloadApp +, payloadApiLayout +) where + +import Control.Applicative +import Control.Monad +import Control.Monad.IO.Class + +import Data.Aeson +import Data.Function +import Data.Maybe +import Data.Proxy +import qualified Data.Text.IO as T + +import Prelude hiding (lookup) + +import Servant + +-- internal modules + +import Chainweb.BlockHeader +import Chainweb.ChainId +import Chainweb.PayloadProvider.P2P.RestAPI +import Chainweb.RestAPI.Orphans () +import Chainweb.RestAPI.Utils +import Chainweb.Utils (int) +import Chainweb.Version + +import Chainweb.BlockHeight (BlockHeight) +import Chainweb.Storage.Table +import Chainweb.BlockPayloadHash + +-- -------------------------------------------------------------------------- -- +-- Utils + +err404Msg :: ToJSON msg => msg -> ServerError +err404Msg msg = setErrJSON msg err404 + +-- -------------------------------------------------------------------------- -- +-- GET Payload Handler + +-- | Query the 'BlockPayload' by its 'BlockPayloadHash' +-- +payloadHandler + :: forall tbl (p :: PayloadProviderType) + . ReadableTable tbl RankedBlockPayloadHash (PayloadType p) + => IsPayloadProvider p + => tbl + -> BlockHeight + -> BlockPayloadHash + -> Handler (RestPayload (PayloadType p)) +payloadHandler db h k = liftIO (tableLookup db rh) >>= \case + Nothing -> throwError $ err404Msg $ object + [ "reason" .= ("key not found" :: String) + , "key" .= k + ] + Just e -> return $ RestPayload e + where + rh = RankedBlockPayloadHash h k + +-- -------------------------------------------------------------------------- -- +-- POST Payload Batch Handler + +payloadBatchHandler + :: forall tbl (p :: PayloadProviderType) + . ReadableTable tbl RankedBlockPayloadHash (PayloadType p) + => IsPayloadProvider p + => PayloadBatchLimit + -> tbl + -> BatchBody + -> Handler (RestPayload (PayloadBatchType p)) +payloadBatchHandler 0 _ _ = throwError $ err404Msg @String "payload batch limit is 0" +payloadBatchHandler batchLimit db (BatchBody ks) = liftIO $ do + r <- batch @p <$> tableLookupBatch db (limit ks) + return $ RestPayload r + where + limit = take $ int (min (p2pPayloadBatchLimit @p) batchLimit) + +-- -------------------------------------------------------------------------- -- +-- Payload API Server + +payloadServer + :: forall tbl v c p + . ReadableTable tbl RankedBlockPayloadHash (PayloadType p) + => IsPayloadProvider p + => PayloadBatchLimit + -> tbl + -> Server (PayloadApi v c p) +payloadServer batchLimit db + = payloadHandler @tbl @p db + :<|> payloadBatchHandler @tbl @p batchLimit db + +-- -------------------------------------------------------------------------- -- +-- Application for a single PayloadDb + +payloadApp + :: forall tbl v c p + . ReadableTable tbl RankedBlockPayloadHash (PayloadType p) + => IsPayloadProvider p + => KnownChainwebVersionSymbol v + => KnownChainIdSymbol c + => PayloadBatchLimit + -> tbl + -> Application +payloadApp batchLimit db = serve + (Proxy @(PayloadApi v c p)) + (payloadServer @tbl @v @c @p batchLimit db) + +payloadApiLayout + :: forall tbl v c (p :: PayloadProviderType) + . KnownChainwebVersionSymbol v + => IsPayloadProvider p + => KnownChainIdSymbol c + => tbl + -> IO () +payloadApiLayout _ = T.putStrLn $ layout (Proxy @(PayloadApi v c p)) + +-- -------------------------------------------------------------------------- -- +-- Multichain Server + +somePayloadServer + :: forall tbl v c p + . ReadableTable tbl RankedBlockPayloadHash (PayloadType p) + => IsPayloadProvider p + => KnownChainwebVersionSymbol v + => KnownChainIdSymbol c + => PayloadBatchLimit + -> tbl + -> SomeServer +somePayloadServer batchLimit db = SomeServer + (Proxy @(PayloadApi v c p)) + (payloadServer @tbl @v @c @p batchLimit db) + +-- somePayloadServers +-- :: ReadableTable tbl RankedBlockPayloadHash a +-- => ChainwebVersion +-- -> PayloadBatchLimit +-- -> [(ChainId, PayloadDb tbl)] +-- -> SomeServer +-- somePayloadServers v batchLimit +-- = mconcat . fmap (somePayloadServer batchLimit . uncurry (somePayloadDbVal v)) diff --git a/src/Chainweb/PayloadProvider/Pact.hs b/src/Chainweb/PayloadProvider/Pact.hs new file mode 100644 index 0000000000..72d7512fdd --- /dev/null +++ b/src/Chainweb/PayloadProvider/Pact.hs @@ -0,0 +1,195 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE UndecidableInstances #-} + +module Chainweb.PayloadProvider.Pact +( PactPayloadProvider(..) +, withPactPayloadProvider +, pactMemPoolAccess +, decodeNewPayload +) where + +import Chainweb.BlockHeaderDB (withBlockHeaderDb) +import Chainweb.ChainId +import Chainweb.Core.Brief +import Chainweb.Counter +import Chainweb.Logger +import Chainweb.MerkleUniverse +import Chainweb.MinerReward qualified as MinerReward +import Chainweb.Pact.Backend.ChainwebPactDb qualified as ChainwebPactDb +import Chainweb.Pact.Backend.Utils +import Chainweb.Pact.Mempool.Mempool +import Chainweb.Pact.PactService qualified as PactService +import Chainweb.Pact.Payload +import Chainweb.Pact.Payload.PayloadStore +import Chainweb.Pact.Transaction qualified as Pact +import Chainweb.Pact.Types +import Chainweb.PayloadProvider +import Chainweb.PayloadProvider.Pact.BlockHistoryMigration +import Chainweb.Storage.Table.RocksDB +import Chainweb.Utils +import Chainweb.Version +import Control.Concurrent.STM +import Control.Exception.Safe +import Control.Lens +import Control.Monad +import Control.Monad.IO.Class +import Control.Monad.Trans.Resource (ResourceT) +import Data.LogMessage +import Data.Vector (Vector) +import Data.Vector qualified as V +import Network.HTTP.Client qualified as HTTP +import System.LogLevel + +data PactPayloadProvider logger tbl = PactPayloadProvider + { pactPayloadProviderLogger :: logger + , pactPayloadProviderServiceEnv :: ServiceEnv tbl + } + +makePrisms ''PactPayloadProvider + +instance HasChainId (PactPayloadProvider logger tbl) where + chainId = _PactPayloadProvider . _2 . chainId + +instance (Logger logger, CanPayloadCas tbl) => PayloadProvider (PactPayloadProvider logger tbl) where + prefetchPayloads p h ps = do + lf Info $ "prefetch: query: " <> sshow (length ps) + rs <- PactService.getPayloadsForConsensusPayloads + (pactPayloadProviderLogger p) + (pactPayloadProviderServiceEnv p) + h + ps + lf Info $ "prefetch: got: " <> sshow (length rs) + where + lf = logFunctionText (pactPayloadProviderLogger p) + + + syncToBlock (PactPayloadProvider logger e) = PactService.syncToFork logger e + + latestPayloadSTM (PactPayloadProvider _logger e) = do + (_, bip) <- readTMVar (_psMiningPayloadVar e) + let pwo = toPayloadWithOutputs + (fromJuste $ _psMiner e) + (_blockInProgressTransactions bip) + return NewPayload + { _newPayloadChainId = _chainId e + , _newPayloadParentHeight = _bctxParentHeight $ _blockInProgressBlockCtx bip + , _newPayloadParentHash = _bctxParentHash $ _blockInProgressBlockCtx bip + , _newPayloadBlockPayloadHash = _payloadWithOutputsPayloadHash pwo + , _newPayloadEncodedPayloadData = Just $ EncodedPayloadData $ encodePayloadData $ payloadWithOutputsToPayloadData pwo + -- this doesn't make it anywhere in storage, right? + , _newPayloadEncodedPayloadOutputs = Just $ EncodedPayloadOutputs $ encodeBlockOutputs $ + BlockOutputs (_payloadWithOutputsOutputsHash pwo) (snd <$> _payloadWithOutputsTransactions pwo) (_payloadWithOutputsCoinbase pwo) + , _newPayloadNumber = _blockInProgressNumber bip + -- Informative: + , _newPayloadTxCount = int $ V.length $ _payloadWithOutputsTransactions pwo + -- ^ The number of user transactions in the block. The exact way how + -- transactions are counted is provider specific. + , _newPayloadSize = 0 + -- ^ what do we do here? why do we care? + , _newPayloadOutputSize = 0 + -- ^ what do we do here? why do we care? + , _newPayloadFees = MinerReward.Stu 0 + -- I suppose this is the sum of the gas in the command results? + } + + eventProof :: Logger logger => PactPayloadProvider logger tbl -> XEventId -> IO SpvProof + eventProof = error "not figured out yet" + +decodeNewPayload :: MonadThrow m => NewPayload -> m PayloadWithOutputs +decodeNewPayload NewPayload{..} = do + pd <- decodePayloadData @_ @ChainwebMerkleHashAlgorithm $ + _encodedPayloadData $ fromJuste _newPayloadEncodedPayloadData + bo <- decodeBlockOutputs @_ @ChainwebMerkleHashAlgorithm $ + _encodedPayloadOutputs $ fromJuste _newPayloadEncodedPayloadOutputs + return $ payloadWithOutputs pd (_blockCoinbaseOutput bo) (_blockOutputs bo) + +-- | Initialization for Pact (in process) Api +withPactPayloadProvider + :: CanPayloadCas tbl + => Logger logger + => HasVersion + => ChainId + -> RocksDb + -- ^ Temporary requirement for the `migrateBlockHistoryTable` step. + -> Maybe HTTP.Manager + -> logger + -> Maybe (Counter "txFailures") + -> MemPoolAccess + -> PayloadDb tbl + -> FilePath + -> PactServiceConfig + -> Maybe PayloadWithOutputs + -> ResourceT IO (PactPayloadProvider logger tbl) +withPactPayloadProvider cid rdb http logger txFailuresCounter mpa pdb pactDbDir config maybeGenesisPayload = do + readWriteSqlenv <- withSqliteDb cid logger pactDbDir False + liftIO $ ChainwebPactDb.initSchema readWriteSqlenv + + -- perform the database migration of the `BlockHeader` Table. + bhdb <- withBlockHeaderDb rdb cid + + liftIO $ do + needsMigration <- tableNeedsMigration logger readWriteSqlenv + when needsMigration $ + -- We cleanup potential old state and start migrating the entire database + -- from scratch. + migrateBlockHistoryTable logger cid readWriteSqlenv bhdb True + + readOnlySqlPool <- withReadSqlitePool cid pactDbDir + PactPayloadProvider logger <$> + PactService.withPactService cid http mpa logger txFailuresCounter pdb readOnlySqlPool readWriteSqlenv config + (maybe GenesisNotNeeded GenesisPayload maybeGenesisPayload) + +pactMemPoolAccess + :: Logger logger + => MempoolBackend Pact.Transaction + -> logger + -> MemPoolAccess +pactMemPoolAccess mp logger = MemPoolAccess + { mpaGetBlock = pactMemPoolGetBlock mp logger + , mpaProcessFork = pactProcessFork mp logger + , mpaBadlistTx = mempoolAddToBadList mp + } + +pactMemPoolGetBlock + :: Logger logger + => MempoolBackend Pact.Transaction + -> logger + -> BlockFill + -> (MempoolPreBlockCheck Pact.Transaction to + -> EvaluationCtx () + -> IO (Vector to)) +pactMemPoolGetBlock mp theLogger bf validate ctx = do + logFn theLogger Debug $! "pactMemPoolAccess - getting new block of transactions for parent " + <> brief (_evaluationCtxRankedParentHash ctx) + mempoolGetBlock mp bf validate ctx + where + logFn :: Logger l => l -> LogFunctionText -- just for giving GHC some type hints + logFn l = logFunction l + +pactProcessFork + :: Logger logger + => MempoolBackend Pact.Transaction + -> logger + -> ((Vector Pact.Transaction, Vector Pact.Transaction) -> IO ()) +pactProcessFork mp theLogger (reintroTxs, validatedTxs) = do + logFn theLogger Debug $! + "pactMemPoolAccess - " <> sshow (length reintroTxs) <> " transactions to reintroduce" + -- No need to run pre-insert check here -- we know these are ok, and + -- calling the pre-check would block here (it calls back into pact service) + mempoolInsert mp UncheckedInsert reintroTxs + mempoolMarkValidated mp validatedTxs + + where + logFn :: Logger l => l -> LogFunctionText + logFn lg = logFunction lg diff --git a/src/Chainweb/PayloadProvider/Pact/BlockHistoryMigration.hs b/src/Chainweb/PayloadProvider/Pact/BlockHistoryMigration.hs new file mode 100644 index 0000000000..2dd6a07aac --- /dev/null +++ b/src/Chainweb/PayloadProvider/Pact/BlockHistoryMigration.hs @@ -0,0 +1,165 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NumericUnderscores #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} + +module Chainweb.PayloadProvider.Pact.BlockHistoryMigration where + +import Chainweb.BlockHash +import Chainweb.BlockHeader +import Chainweb.BlockHeaderDB (BlockHeaderDb) +import Chainweb.ChainId +import Chainweb.Logger +import Chainweb.Pact.Backend.Types (SQLiteEnv) +import Chainweb.TreeDB +import Chainweb.Version (HasVersion) +import Control.Lens +import Control.Monad.IO.Class +import System.Logger qualified as L +import System.LogLevel +import Chainweb.Pact.Backend.Utils +import Chainweb.Pact.Backend.PactState (qryStream) +import Chainweb.Parent +import Chainweb.PayloadProvider +import Streaming qualified as S +import Streaming.Prelude qualified as S +import Chainweb.Utils (sshow, whenM) +import Chainweb.Utils.Serialization (runPutS, runGetS) +import Data.IORef (newIORef, readIORef, modifyIORef') +import Control.Monad +import Data.Time.Clock (getCurrentTime, diffUTCTime) + +-- | Migrates the @BlockHistory@ table if it is outdated or missing required columns. +-- +-- Due to SQLite limitations, we cannot simply add the missing column and migrate +-- the data afterward. Specifically, constraints (such as the uniqueness of the +-- @blockhash@ column) must be satisfied at the time the column is added, and +-- SQLite does not allow adding columns with unique constraints via @ALTER TABLE@. +-- See for more details. +-- +-- The migration is performed only if 'tableNeedsMigration' indicates it's necessary. +-- It proceeds in a row-wise migration of existing data from the old @BlockHistory@ table and +-- the 'BlockHeaderDb' (backed by RocksDb), performed in chunks of 10,000 entries. +-- +-- Each chunk is committed in a transaction block. +-- +-- NOTE: THIS Module can be deleted after migration !!! +-- +migrateBlockHistoryTable + :: HasVersion + => Logger logger + => logger + -> ChainId + -> SQLiteEnv + -> BlockHeaderDb + -> Bool -- ^ cleanup table after migration + -> IO () +migrateBlockHistoryTable logger cid sdb bhdb cleanup + = L.withLoggerLabel ("component", "migrateBlockHistoryTable") logger $ \lf -> + whenM (tableNeedsMigration lf sdb) $ do + let logf serv msg = liftIO $ logFunctionText lf serv msg + + nBlockHistory2 <- nTableEntries "BlockHistory2" + nBlockHistory <- nTableEntries "BlockHistory" + + when (nBlockHistory2 <= nBlockHistory) $ do + logf Info "Partial migration detected, cleaning up and restarting." + throwOnDbError $ exec_ sdb "DELETE FROM BlockHistory2" + + let qstmt = "SELECT blockheight, endingtxid, hash from BlockHistory ORDER BY blockheight,endingtxid ASC" + rty = [RInt, RInt, RBlob] + + start <- getCurrentTime + + e <- qryStream sdb qstmt [] rty $ \rs -> do + remainingRowsRef <- newIORef nBlockHistory + rs + & S.chunksOf 10_000 + & S.mapsM (\chunk -> do + remainingRows <- readIORef remainingRowsRef + let perc = (1.0 - fromIntegral @_ @Double remainingRows / fromIntegral @_ @Double nBlockHistory) * 100.0 + logf Info $ "Table migration: Process remaining rows: " <> sshow remainingRows <> " ("<> sshow perc <> ")" + r <- withTransaction sdb $ chunk + & S.mapMaybeM (\case + rr@[SInt bh, SInt _, SBlob h] -> do + let rowBlockHeight = fromIntegral bh + rowBlockHash <- runGetS decodeBlockHash h + lookupRanked bhdb rowBlockHeight rowBlockHash >>= \case + Nothing -> do + -- TODO: stop when there's a missing header? + -- error if there's a gap? + logFunctionText logger Warn + $ "BlockHeader Entry missing for " + <> "blockHeight=" + <> sshow rowBlockHeight + <> ", blockHash=" + <> sshow rowBlockHash + return Nothing + Just blockHeader -> do + let bph = view blockPayloadHash blockHeader + enc = runPutS $ encodeBlockPayloadHash bph + + throwOnDbError $ exec' sdb + "INSERT INTO BlockHistory2 (blockheight, endingtxid, hash, payloadhash) VALUES (?, ?, ?, ?)" + $ rr ++ [SBlob enc] + return (Just blockHeader) + _ -> error "unexpected row shape" + ) + & S.last + + modifyIORef' remainingRowsRef (\old -> max 0 (old - 10_000)) + pure r) + & S.catMaybes + & S.last + + case e of + _ S.:> Left e' -> + error $ "Table migration failure: " <> sshow e' + maybeFinalBlock S.:> Right () -> do + finalBlock <- case maybeFinalBlock of + Nothing -> do + logf Warn "No blocks were found in the original table!" + return (genesisBlockHeader cid) + Just finalBlock -> + return finalBlock + end <- getCurrentTime + logf Info $ "Elapsed Time: " <> sshow (diffUTCTime end start) + + when cleanup $ withTransaction sdb $ do + logf Info "Data migration completed, cleaning up" + _ <- rewindDbTo cid sdb (Parent $ view rankedBlockHash finalBlock) + let finalBlockSyncState = syncStateOfBlockHeader finalBlock + throwOnDbError $ setConsensusState sdb + (ConsensusState finalBlockSyncState finalBlockSyncState finalBlockSyncState) + throwOnDbError $ exec_ sdb "DROP TABLE BlockHistory" + + logf Info "Table migration successful" + + where + nTableEntries tname = throwOnDbError $ qry_ sdb ("SELECT count(*) from " <> tname) [RInt] >>= \case + [[SInt n]] -> pure n + _ -> error "unexpected row shape" + + +-- | Checks whether the @BlockHistory@ table is (still) existing +-- and therefore requires a data migration step. +tableNeedsMigration + :: Logger logger + => logger + -> SQLiteEnv + -> IO Bool +tableNeedsMigration lf sqe = do + let logf serv msg = liftIO $ logFunctionText lf serv msg + + r <- throwOnDbError $ qry sqe "SELECT 1 FROM sqlite_master WHERE type = 'table' AND name = 'BlockHistory';" [] [RInt] + case r of + [[SInt _]] -> do + logf Info "BlockHistory table exists, need to migrate data." + pure True + _ -> do + logf Info "BlockHistory table does not exists. No table migration required." + pure False diff --git a/src/Chainweb/PayloadProvider/Pact/Configuration.hs b/src/Chainweb/PayloadProvider/Pact/Configuration.hs new file mode 100644 index 0000000000..478976da17 --- /dev/null +++ b/src/Chainweb/PayloadProvider/Pact/Configuration.hs @@ -0,0 +1,174 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE NumericUnderscores #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} + +-- | +-- Module: Chainweb.PayloadProvider.Pact.Configuration +-- Copyright: Copyright © 2025 Kadena LLC. +-- License: MIT +-- Maintainer: Lars Kuhtz +-- Stability: experimental +-- +module Chainweb.PayloadProvider.Pact.Configuration +( PactProviderConfig(..) +, pactConfigReintroTxs +, pactConfigMempoolP2p +, pactConfigBlockGasLimit +, pactConfigLogGas +, pactConfigMinGasPrice +, pactConfigPreInsertCheckTimeout +, pactConfigAllowReadsInLocal +, pactConfigFullHistoricPactState +, pactConfigEnableLocalTimeout +, pactConfigMiner +, defaultPactProviderConfig +, pPactProviderConfig +, pMiner +, invalidMiner +) where + +import Chainweb.Pact.Mempool.Mempool qualified as Mempool +import Chainweb.Pact.Mempool.P2pConfig +import Chainweb.Miner.Pact (Miner(..), MinerGuard(..), MinerId(..)) +import Chainweb.Pact.Types (defaultPreInsertCheckTimeout) +import Chainweb.Pact.Payload(PayloadWithOutputs) +import Chainweb.Time hiding (second) +import Chainweb.Utils +import Chainweb.Version +import Configuration.Utils hiding (Error, Lens', disabled) +import Control.Lens hiding ((.=), (<.>)) +import Control.Monad +import Data.Maybe +import Data.Set qualified as Set +import GHC.Generics hiding (from, to) +import Pact.Core.Gas qualified as Pact +import Pact.Core.Guards qualified as Pact +import Pact.Core.StableEncoding +import Pact.JSON.Encode qualified as J +import Prelude hiding (log) + +-- -------------------------------------------------------------------------- -- + +invalidMiner :: Miner +invalidMiner = Miner "" + $ MinerGuard + $ Pact.GKeyset (Pact.KeySet mempty Pact.KeysAll) + +pMiner :: ChainId -> OptionParser Miner +pMiner cid = pkToMiner <$> pPk + where + pkToMiner pk = Miner + (MinerId $ "k:" <> Pact._pubKey pk) + (MinerGuard $ Pact.GKeyset $ Pact.KeySet (Set.singleton pk) Pact.KeysAll) + pPk = Pact.PublicKeyText <$> textOption + % prefixLongCid cid "pact-mining-public-key" + <> helpCid cid + "Public key of a miner in hex decimal encoding. The account name is the public key prefix by 'k:'. Payload production is disabled if not set." + +-- -------------------------------------------------------------------------- -- +-- Payload Provider Configuration + +-- | Placeholder for PactProviderConfig +-- +data PactProviderConfig = PactProviderConfig + { _pactConfigReintroTxs :: !Bool + , _pactConfigMempoolP2p :: !(EnableConfig MempoolP2pConfig) + , _pactConfigBlockGasLimit :: !Mempool.GasLimit + , _pactConfigLogGas :: !Bool + , _pactConfigMinGasPrice :: !Mempool.GasPrice + , _pactConfigPreInsertCheckTimeout :: !Micros + , _pactConfigAllowReadsInLocal :: !Bool + + -- For shallow nodes this should be a history depth parameter + , _pactConfigFullHistoricPactState :: !Bool + + , _pactConfigEnableLocalTimeout :: !Bool + , _pactConfigMiner :: !(Maybe Miner) + , _pactConfigDatabaseDirectory :: !(Maybe FilePath) + , _pactConfigGenesisPayload :: !(Maybe PayloadWithOutputs) + } + deriving (Show, Eq, Generic) + +makeLenses ''PactProviderConfig + +instance ToJSON PactProviderConfig where + toJSON o = object + [ "reintroTxs" .= _pactConfigReintroTxs o + , "mempoolP2p" .= _pactConfigMempoolP2p o + , "gasLimitOfBlock" .= J.toJsonViaEncode (StableEncoding $ _pactConfigBlockGasLimit o) + , "logGas" .= _pactConfigLogGas o + , "minGasPrice" .= J.toJsonViaEncode (StableEncoding $ _pactConfigMinGasPrice o) + , "preInsertCheckTimeout" .= _pactConfigPreInsertCheckTimeout o + , "allowReadsInLocal" .= _pactConfigAllowReadsInLocal o + , "fullHistoricPactState" .= _pactConfigFullHistoricPactState o + , "enableLocalTimeout" .= _pactConfigEnableLocalTimeout o + , "miner" .= J.toJsonViaEncode (_pactConfigMiner o) + , "databaseDirectory" .= _pactConfigDatabaseDirectory o + , "genesisPayload" .= _pactConfigGenesisPayload o + ] + +instance FromJSON (PactProviderConfig -> PactProviderConfig) where + parseJSON = withObject "PactProviderConfig" $ \o -> id + <$< pactConfigReintroTxs ..: "reintroTxs" % o + <*< pactConfigMempoolP2p %.: "mempoolP2p" % o + <*< pactConfigBlockGasLimit . iso StableEncoding _stableEncoding ..: "gasLimitOfBlock" % o + <*< pactConfigLogGas ..: "logGas" % o + <*< pactConfigMinGasPrice . iso StableEncoding _stableEncoding ..: "minGasPrice" % o + <*< pactConfigPreInsertCheckTimeout ..: "preInsertCheckTimeout" % o + <*< pactConfigAllowReadsInLocal ..: "allowReadsInLocal" % o + <*< pactConfigFullHistoricPactState ..: "fullHistoricPactState" % o + <*< pactConfigEnableLocalTimeout ..: "enableLocalTimeout" % o + <*< pactConfigMiner ..: "miner" % o + <*< pactConfigDatabaseDirectory ..: "databaseDirectory" % o + <*< pactConfigGenesisPayload ..: "genesisPayload" % o + +defaultPactProviderConfig :: PactProviderConfig +defaultPactProviderConfig = PactProviderConfig + { _pactConfigReintroTxs = True + , _pactConfigMempoolP2p = defaultEnableConfig defaultMempoolP2pConfig + , _pactConfigBlockGasLimit = Pact.GasLimit (Pact.Gas 150_000) + , _pactConfigLogGas = False + , _pactConfigMinGasPrice = Pact.GasPrice 1e-8 + , _pactConfigPreInsertCheckTimeout = defaultPreInsertCheckTimeout + , _pactConfigAllowReadsInLocal = False + , _pactConfigFullHistoricPactState = True + , _pactConfigEnableLocalTimeout = False + , _pactConfigMiner = Nothing + , _pactConfigDatabaseDirectory = Nothing + , _pactConfigGenesisPayload = Nothing + } + +pPactProviderConfig :: ChainId -> MParser PactProviderConfig +pPactProviderConfig cid = id + <$< pactConfigReintroTxs .:: enableDisableFlag + % prefixLongCid cid "pact-tx-reintro" + <> helpCid cid "whether to enable transaction reintroduction from losing forks" + <*< pactConfigMempoolP2p %:: pEnableConfigCid "pact-mempool-p2p" cid pMempoolP2pConfig + <*< pactConfigBlockGasLimit . iso StableEncoding _stableEncoding .:: jsonOption + % prefixLongCid cid "pact-block-gas-limit" + <> helpCid cid "the sum of all transaction gas fees in a block must not exceed this number" + <*< pactConfigLogGas .:: boolOption_ + % prefixLongCid cid "pact-log-gas" + <> helpCid cid "log gas consumed by Pact commands" + <*< pactConfigMinGasPrice . iso StableEncoding _stableEncoding .:: jsonOption + % prefixLongCid cid "pact-min-gas-price" + <> helpCid cid "the gas price of an individual transaction in a block must not be beneath this number" + <*< pactConfigPreInsertCheckTimeout .:: jsonOption + % prefixLongCid cid "pact-pre-insert-check-timeout" + <> helpCid cid "Max allowed time in microseconds for the transactions validation in the PreInsertCheck command." + <*< pactConfigAllowReadsInLocal .:: boolOption_ + % prefixLongCid cid "pact-allowReadsInLocal" + <> helpCid cid "Enable direct database reads of smart contract tables in local queries." + <*< pactConfigFullHistoricPactState .:: boolOption_ + % prefixLongCid cid "pact-full-historic-pact-state" + <> helpCid cid "Write full historic Pact state; only enable for custodial or archival nodes." + <*< pactConfigEnableLocalTimeout .:: option auto + % prefixLongCid cid "pact-enable-local-timeout" + <> helpCid cid "Enable timeout support on /local endpoints" + <*< pactConfigMiner .:: fmap Just % pMiner cid + <*< pactConfigDatabaseDirectory .:: fmap Just % fileOption + % prefixLongCid cid "pact-database-directory" + <> helpCid cid "the directory to store the pact database" diff --git a/src/Chainweb/PayloadProvider/Pact/Genesis.hs b/src/Chainweb/PayloadProvider/Pact/Genesis.hs new file mode 100644 index 0000000000..32f859207f --- /dev/null +++ b/src/Chainweb/PayloadProvider/Pact/Genesis.hs @@ -0,0 +1,90 @@ +{-# LANGUAGE ImportQualifiedPost #-} + +-- | +-- Module: Chainweb.PayloadProvider.Pact.Genesis +-- Copyright: Copyright © 2025 Kadena LLC. +-- License: MIT +-- Maintainer: Lars Kuhtz +-- Stability: experimental +-- +module Chainweb.PayloadProvider.Pact.Genesis +( genesisPayload +) where + +import Chainweb.BlockHeader.Genesis.Development0Payload qualified as DN0 +import Chainweb.BlockHeader.Genesis.Development1to19Payload qualified as DNN +import Chainweb.BlockHeader.Genesis.Mainnet0Payload qualified as MN0 +import Chainweb.BlockHeader.Genesis.Mainnet10to19Payload qualified as MNKAD +import Chainweb.BlockHeader.Genesis.Mainnet1Payload qualified as MN1 +import Chainweb.BlockHeader.Genesis.Mainnet2Payload qualified as MN2 +import Chainweb.BlockHeader.Genesis.Mainnet3Payload qualified as MN3 +import Chainweb.BlockHeader.Genesis.Mainnet4Payload qualified as MN4 +import Chainweb.BlockHeader.Genesis.Mainnet5Payload qualified as MN5 +import Chainweb.BlockHeader.Genesis.Mainnet6Payload qualified as MN6 +import Chainweb.BlockHeader.Genesis.Mainnet7Payload qualified as MN7 +import Chainweb.BlockHeader.Genesis.Mainnet8Payload qualified as MN8 +import Chainweb.BlockHeader.Genesis.Mainnet9Payload qualified as MN9 +import Chainweb.BlockHeader.Genesis.RecapDevelopment0Payload qualified as RDN0 +import Chainweb.BlockHeader.Genesis.RecapDevelopment10to19Payload qualified as RDNKAD +import Chainweb.BlockHeader.Genesis.RecapDevelopment1to9Payload qualified as RDNN +import Chainweb.BlockHeader.Genesis.Testnet040Payload qualified as T04N0 +import Chainweb.BlockHeader.Genesis.Testnet041to19Payload qualified as T04NN +import Chainweb.Pact.Payload +import Chainweb.Version +import Chainweb.Version.Development +import Chainweb.Version.EvmDevelopment +import Chainweb.Version.Mainnet +import Chainweb.Version.RecapDevelopment +import Chainweb.Version.Testnet04 +import Control.Lens +import Data.HashMap.Strict qualified as HM +import GHC.Stack + +genesisPayload + :: (HasCallStack, HasVersion) + => ChainId -> Maybe PayloadWithOutputs +genesisPayload cid + | _versionCode implicitVersion == _versionCode Mainnet01 = + mainnetPayloads ^. at cid + | _versionCode implicitVersion == _versionCode Testnet04 = + testnet04Payloads ^. at cid + | _versionCode implicitVersion == _versionCode Development = + devnetPayloads ^. at cid + | _versionCode implicitVersion == _versionCode RecapDevelopment = + recapDevnetPayloads ^. at cid + | _versionCode implicitVersion == _versionCode EvmDevelopment = + evmDevnetPayloads ^. at cid + | otherwise = Nothing + where + mainnetPayloads = ChainMap $ HM.fromList $ concat + [ + [ (unsafeChainId 0, MN0.payloadBlock) + , (unsafeChainId 1, MN1.payloadBlock) + , (unsafeChainId 2, MN2.payloadBlock) + , (unsafeChainId 3, MN3.payloadBlock) + , (unsafeChainId 4, MN4.payloadBlock) + , (unsafeChainId 5, MN5.payloadBlock) + , (unsafeChainId 6, MN6.payloadBlock) + , (unsafeChainId 7, MN7.payloadBlock) + , (unsafeChainId 8, MN8.payloadBlock) + , (unsafeChainId 9, MN9.payloadBlock) + ] + , [(unsafeChainId i, MNKAD.payloadBlock) | i <- [10..19]] + ] + testnet04Payloads = ChainMap $ HM.fromList $ concat + [ [(unsafeChainId 0, T04N0.payloadBlock)] + , [(unsafeChainId i, T04NN.payloadBlock) | i <- [1..19]] + ] + devnetPayloads = ChainMap $ HM.fromList $ concat + [ [(unsafeChainId 0, DN0.payloadBlock)] + , [(unsafeChainId i, DNN.payloadBlock) | i <- [1..19]] + ] + recapDevnetPayloads = ChainMap $ HM.fromList $ concat + [ [(unsafeChainId 0, RDN0.payloadBlock)] + , [(unsafeChainId i, RDNN.payloadBlock) | i <- [1..9]] + , [(unsafeChainId i, RDNKAD.payloadBlock) | i <- [10..19]] + ] + evmDevnetPayloads = ChainMap $ HM.fromList $ concat + [ [(unsafeChainId 0, DN0.payloadBlock)] + , [(unsafeChainId i, DNN.payloadBlock) | i <- [1..19]] + ] diff --git a/src/Chainweb/PayloadProvider/SPV.hs b/src/Chainweb/PayloadProvider/SPV.hs new file mode 100644 index 0000000000..cd10efa419 --- /dev/null +++ b/src/Chainweb/PayloadProvider/SPV.hs @@ -0,0 +1,700 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE StandaloneKindSignatures #-} +{-# LANGUAGE TypeAbstractions #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +{-# OPTIONS_GHC -Wno-orphans #-} + +-- | +-- Module: Chainweb.PayloadProvider.SPV +-- Copyright: Copyright © 2025 Kadena LLC. +-- License: MIT +-- Maintainer: Lars Kuhtz +-- Stability: experimental +-- +module Chainweb.PayloadProvider.SPV +( Argument(..) +, SomeArgument(..) +, runArg +, compose +) where + +import Chainweb.BlockHash +import Chainweb.BlockPayloadHash +import Chainweb.Crypto.MerkleLog +import Chainweb.MerkleLogHash +import Chainweb.MerkleUniverse +import Chainweb.Pact.Payload +import Chainweb.PayloadProvider.EVM.Header ({- IsMerkleLogEntry instances -}) +import Chainweb.PayloadProvider.EVM.Receipt qualified as EVM +import Control.Exception +import Control.Monad +import Control.Monad.Catch +import Data.ByteString qualified as B +import Data.Coerce +import Data.Kind +import Data.MerkleLog (MerkleRoot) +import Data.MerkleLog qualified as ML +import Data.MerkleLog.V1 qualified as V1 +import Data.Text qualified as T +import Data.Type.Equality +import Data.Typeable +import Data.Word +import Ethereum.Misc qualified as E +import Ethereum.RLP (getRlpL) +import Ethereum.RLP qualified as E +import Ethereum.Trie qualified as E +import Numeric.Natural + +-- -------------------------------------------------------------------------- -- +-- Alternative Approach + +-- Protocol flow: +-- +-- 1. Event emission [on-chain]: the user creates the event. The event may be the +-- native event format of the payload provider, a custom language extension, +-- or an agreement to write a particular value to the contract store. +-- +-- 2. Proof creation [off-chain]: the user creates a proof (usually through +-- calling an API) that contains the relevant event data along with evidence +-- for its inclusion on the source chain and its provenance. +-- +-- 3. Send redeem transaction [off-chain]: the user sends a transaction that +-- includes the proof to the target chain. +-- +-- 4. Proof verification [on-chain]: the execution environment on the receiving +-- chain verifies the evidence in the proof and extract the relevant message +-- and provenance data. It performance additional checks on that data and, if +-- successful, notifies the receiver contract. +-- +-- 4. Redeem [on-chain]: the receiving contract obtains the notification data. +-- It performs some checks on the data. If the checks succeed it performs the +-- redeem operations. +-- +-- +-- TOPIC FORMAT: +-- +-- 0: event type signature hash (keccak256()) +-- 1: targetChain [uint32, bigendian] +-- 2: target address [address, last 20 bytes] +-- 3: ignored (optional for indexing) +-- +-- LogData: +-- * receiver address B.ByteString (eth address 20 bytes) +-- * amount [uint256] + +-- -------------------------------------------------------------------------- -- +-- +-- Backward compatibility: +-- +-- * Proof format: +-- * Existing proof *must* continue to work during reorg and the transition. +-- * Can we skip proof verification during replay? +-- +-- Before EVM transition: +-- 1. Introduce support for validating new format +-- 2. Enable creation of new format. +-- +-- + +-- -------------------------------------------------------------------------- -- +-- TODO: +-- +-- The types in the Merkle Universe must be available to all payload providers +-- (the alternative would be to define a unique event format across all payload +-- providers and require that all payload providers support direct proofs of +-- those events in their respective payload Merkle tree. +-- +-- For instance the EVM provider could collect events from the EVM and transform +-- those to the common format and add those to a new event tree. +-- +-- We should create a package that collects and reexports all types from the +-- Chainweb Merkle universe. + +-- -------------------------------------------------------------------------- -- + +type ChainwebMerkleLogEntry a = + ( Eq a + , Typeable a + , Show a + , IsMerkleLogEntry ChainwebMerkleHashAlgorithm ChainwebHashTag a + ) + +tagVal' :: forall b . ChainwebMerkleLogEntry b => Word16 +tagVal' = tagVal @ChainwebHashTag @(Tag b) + +-- -------------------------------------------------------------------------- +-- Claims + +data Conjunct a b where + Conjunct + :: (ChainwebMerkleLogEntry a, ChainwebMerkleLogEntry b) + => a + -> b + -> Conjunct a b + +deriving instance (Show a, Show b) => Show (Conjunct a b) +deriving instance (Eq a, Eq b) => Eq (Conjunct a b) + +class InclusionClaim a +instance {-# OVERLAPPABLE #-} (ChainwebMerkleLogEntry a) => InclusionClaim a +instance {-# OVERLAPPING #-} InclusionClaim (Conjunct a b) + +-- -------------------------------------------------------------------------- -- +-- Exceptions + +newtype VerificationException = VerificationException T.Text + deriving (Show, Eq) + +instance Exception VerificationException + +-- -------------------------------------------------------------------------- -- + +-- TODO: replace concrete types by Tags? +-- +-- The types themself are not available to all payload providers, but the tags +-- are. +-- +-- TODO do we need extensible arguments, e.g. as a data family or just class? +-- +-- For now we try to the set of supported Proofs and claim types small and +-- fixed. +-- +-- The claim types are included in the Chainweb core library to which all +-- payload providers have access. Proof verification validates the evidence and +-- also deserializes the claim, which inlcudes verification of the tag. + +-- | Arguments +-- +-- An argument provides evidence for the statement: +-- +-- \(\text{root} \in \text{Chainweb} \rightarrow \text{claim} \in \text{Chainweb}\) +-- +-- where `claim` is a value that is stored on chain and has a type that is a +-- member of the Chainweb Merkle universe. +-- +-- This statement is established by applying the argument to the claim, which +-- may succeed or fail. +-- +data Argument (claim :: Type) (root :: Type) where + Trivial + :: + ( ChainwebMerkleLogEntry a + , Coercible a (MerkleRoot ChainwebMerkleHashAlgorithm) + ) + => a + -> Argument a a + PactLegacyProof + :: V1.MerkleProof ChainwebMerkleHashAlgorithm + -> Argument TransactionOutput BlockHash + HeaderArgument + :: ML.MerkleProof ChainwebMerkleHashAlgorithm + -> Argument BlockHash BlockHash + ParentHeaderArgument + :: ML.MerkleProof ChainwebMerkleHashAlgorithm + -> Argument BlockHash BlockHash + BlockPayloadHashArgument + :: ML.MerkleProof ChainwebMerkleHashAlgorithm + -> Argument BlockPayloadHash BlockHash + PactOutputArgument + :: + ( ChainwebMerkleLogEntry root + , Coercible root (MerkleRoot ChainwebMerkleHashAlgorithm) + ) + => ML.MerkleProof ChainwebMerkleHashAlgorithm + -> Argument TransactionOutput root + EthHeaderArgument + :: + ( ChainwebMerkleLogEntry root + , Coercible root (MerkleRoot ChainwebMerkleHashAlgorithm) + ) + => ML.MerkleProof ChainwebMerkleHashAlgorithm + -> Argument E.ReceiptsRoot root + EthReceiptArgument + :: E.Proof + -> Argument EVM.Receipt E.ReceiptsRoot + + -- Composed Arguments (used when the underlying proofs can't be composed) + ComposeArgument + :: + ( ChainwebMerkleLogEntry a + , ChainwebMerkleLogEntry claim + , ChainwebMerkleLogEntry root + ) + => Argument claim a + -> Argument a root + -> Argument claim root + + -- Future work: + -- + -- Conjunect a0 a1 is not a MerkleLogEntry. Hence we need create an + -- abstraction that that covers both MerkleLogEntries and Conjunctions of + -- MerkleLogEntries. + -- + -- ComposeArgument2 + -- :: + -- ( ChainwebMerkleLogEntry a0 + -- , ChainwebMerkleLogEntry a1 + -- , ChainwebMerkleLogEntry root + -- , ChainwebMerkleLogEntry claim0 + -- , ChainwebMerkleLogEntry claim1 + -- ) + -- => Argument claim0 a0 + -- -> Argument claim1 a1 + -- -> Argument (Conjunct a0 a1) root + -- -> Argument (Conjunct claim0 claim1) root + +deriving instance (Show claim, Show root) => Show (Argument claim root) + +argumentClaim :: MonadThrow m => Argument claim root -> m claim +argumentClaim (Trivial r) = return r +argumentClaim (PactLegacyProof p) = fromMerkleNodeM + $ V1._getMerkleProofSubject + $ V1._merkleProofSubject p +argumentClaim (HeaderArgument p) = fromMerkleNodeM $ ML._merkleProofClaim p +argumentClaim (ParentHeaderArgument p) = fromMerkleNodeM $ ML._merkleProofClaim p +argumentClaim (BlockPayloadHashArgument p) = fromMerkleNodeM $ ML._merkleProofClaim p +argumentClaim (PactOutputArgument p) = fromMerkleNodeM $ ML._merkleProofClaim p +argumentClaim (EthHeaderArgument p) = fromMerkleNodeM $ ML._merkleProofClaim p +argumentClaim (EthReceiptArgument p) = case E._proofValue p of + Nothing -> throwM $ VerificationException "Invalid Receipt proof: missing claim" + Just r -> case E.get E.getRlp r of + Left e -> throwM $ VerificationException $ "Invalid receipt: " <> T.pack e + Right r' -> return r' +argumentClaim (ComposeArgument a0 _) = argumentClaim a0 +-- argumentClaim (ComposeArgument2 a0 a1 _) = Conjunct +-- <$> argumentClaim a0 +-- <*> argumentClaim a1 + +-- -------------------------------------------------------------------------- -- +-- Serialization + +data SomeArgument where + SomeArgument + :: forall (claim :: Type) (root :: Type) + . (ChainwebMerkleLogEntry claim, ChainwebMerkleLogEntry root) + => Argument claim root + -> SomeArgument + +instance MerkleHashAlgorithm a => E.RLP (MerkleRoot a) where + putRlp r = E.putRlp $ ML.encodeMerkleRoot r + getRlp = E.label "MerkleRoot " $ do + bs <- E.getRlp @B.ByteString + case ML.decodeMerkleRoot bs of + Left e -> fail $ "Invalid MerkleRoot: " <> show e + Right r -> return r + {-# INLINE putRlp #-} + {-# INLINE getRlp #-} + +instance MerkleHashAlgorithm a => E.RLP (ML.MerkleNodeType a) where + putRlp (ML.TreeNode h) = E.putRlpL + [ E.putRlp (0 :: Word8) + , E.putRlp h + ] + putRlp (ML.InputNode b) = E.putRlpL + [ E.putRlp (1 :: Word8) + , E.putRlp b + ] + getRlp = E.label "MerkleNodeType" $ do + E.getRlp @Word8 >>= \case + 0 -> E.label "TreeNode" (ML.TreeNode <$> E.getRlp) + 1 -> E.label "InputNode" (ML.InputNode <$> E.getRlp) + _ -> fail "invalid MerkleNodeType" + {-# INLINE putRlp #-} + {-# INLINE getRlp #-} + +instance MerkleHashAlgorithm a => E.RLP (V1.MerkleProof a) where + putRlp p = E.putRlpL + [ E.putRlp $ V1._getMerkleProofSubject (V1._merkleProofSubject p) + , E.putRlp $ V1.encodeMerkleProofObject (V1._merkleProofObject p) + ] + getRlp = E.label "V1.MerkleProof" $ V1.MerkleProof + <$> E.label "MerkleProofSubject" (V1.MerkleProofSubject <$> E.getRlp) + <*> E.label "MerkleProofObject" do + bs <- E.getRlp @B.ByteString + case V1.decodeMerkleProofObject bs of + Left e -> fail $ "Invalid MerkleProofObject: " <> show e + Right r -> return r + {-# INLINE putRlp #-} + {-# INLINE getRlp #-} + +instance E.RLP (ML.MerkleProof ChainwebMerkleHashAlgorithm) where + putRlp p = E.putRlpL + [ E.putRlp (ML._merkleProofClaim p) + , E.putRlp (fromIntegral @_ @Natural $ ML._merkleProofTrace p) + , E.putRlp (ML._merkleProofEvidence p) + ] + getRlp = E.label "MerkleProof" $ + ML.MerkleProof + <$> E.label "claim" E.getRlp + <*> E.label "trace" (fromIntegral @Natural <$> E.getRlp) + <*> E.label "evidence" E.getRlp + {-# INLINE putRlp #-} + {-# INLINE getRlp #-} + +instance MerkleHashAlgorithm a => E.RLP (BlockPayloadHash_ a) where + putRlp = E.putRlp . coerce @_ @(MerkleRoot a) + getRlp = E.label "BlockPayloadHash" $ coerce <$> E.getRlp @(MerkleRoot a) + {-# INLINE putRlp #-} + {-# INLINE getRlp #-} + +instance MerkleHashAlgorithm a => E.RLP (BlockHash_ a) where + putRlp = E.putRlp . coerce @_ @(MerkleRoot a) + getRlp = E.label "BlockHash" $ coerce <$> E.getRlp @(MerkleRoot a) + {-# INLINE putRlp #-} + {-# INLINE getRlp #-} + +instance E.RLP SomeArgument where + putRlp (SomeArgument @claim @root arg) = case arg of + (Trivial p) -> go 0 (coerce @_ @(MerkleRoot ChainwebMerkleHashAlgorithm) p) + (PactLegacyProof p) -> go 1 p + (HeaderArgument p) -> go 2 p + (ParentHeaderArgument p) -> go 3 p + (BlockPayloadHashArgument p) -> go 4 p + (PactOutputArgument p) -> go 5 p + (EthHeaderArgument p) -> go 6 p + (EthReceiptArgument p) -> go 7 p + (ComposeArgument a0 a1) -> E.putRlpL + [ E.putRlp (8 :: Word8) + , E.putRlp (SomeArgument a0) + , E.putRlp (SomeArgument a1) + ] + where + go :: E.RLP p => Word8 -> p -> E.Put + go tag p = E.putRlpL + [ E.putRlp (tag :: Word8) + , E.putRlp (tagVal' @claim) + , E.putRlp (tagVal' @root) + , E.putRlp p + ] + + getRlp = E.label "Argument" $ getRlpL $ do + tag <- E.label "Argument Tag" (E.getRlp @Word8) + claim <- E.label "Claim Tag" $ E.getRlp @Word16 + root <- E.label "Root Tag" $ E.getRlp @Word16 + case tag of + 0 -> E.label "Trivial" $ if + | root == tagVal' @BlockPayloadHash -> SomeArgument <$> + enforceType claim root (Trivial @BlockPayloadHash <$> E.getRlp) + | root == tagVal' @BlockHash -> SomeArgument <$> + enforceType claim root (Trivial @BlockHash <$> E.getRlp) + | otherwise -> + fail "invalid root type" + 1 -> E.label "PactLegacyProof" $ SomeArgument <$> + getTagged (PactLegacyProof <$> E.getRlp) + 2 -> E.label "HeaderArgument" $ SomeArgument <$> + getTagged (HeaderArgument <$> E.getRlp) + 3 -> E.label "ParentHeaderArgument" $ SomeArgument <$> + getTagged (ParentHeaderArgument <$> E.getRlp) + 4 -> E.label "BlockPayloadHashArgument" $ SomeArgument <$> + getTagged (BlockPayloadHashArgument <$> E.getRlp) + 5 -> E.label "PactOutputArgument" $ if + | root == tagVal' @BlockPayloadHash -> SomeArgument <$> + enforceType claim root (PactOutputArgument @BlockPayloadHash <$> E.getRlp) + | root == tagVal' @BlockHash -> SomeArgument <$> + enforceType claim root (PactOutputArgument @BlockHash <$> E.getRlp) + | otherwise -> + fail "invalid root type" + 6 -> E.label "EthHeaderArgument" $ if + | root == tagVal' @BlockPayloadHash -> SomeArgument <$> + enforceType claim root (EthHeaderArgument @BlockPayloadHash <$> E.getRlp) + | root == tagVal' @BlockHash -> SomeArgument <$> + enforceType claim root (EthHeaderArgument @BlockHash <$> E.getRlp) + | otherwise -> + fail "invalid root type" + 7 -> E.label "EthReceiptArgument" $ SomeArgument <$> + getTagged (EthReceiptArgument <$> E.getRlp) + 8 -> E.label "ComposeArgument" $ do + SomeArgument @c @a a0 <- E.getRlp + SomeArgument @a' @r a1 <- E.getRlp + arg <- getTagged @c @r $ case (eqT @a @a') of + Just Refl -> return $ ComposeArgument a0 a1 + _ -> fail "invalid compose argument" + return $ SomeArgument arg + _ -> fail "invalid argument type" + where + getTagged + :: forall claim root + . ChainwebMerkleLogEntry claim + => ChainwebMerkleLogEntry root + => E.Get (Argument claim root) + -> E.Get (Argument claim root) + getTagged p = do + claim <- E.label "Claim Tag" $ E.getRlp @Word16 + root <- E.label "Root Tag" $ E.getRlp @Word16 + enforceType claim root p + + enforceType + :: forall claim root + . ChainwebMerkleLogEntry claim + => ChainwebMerkleLogEntry root + => Word16 + -> Word16 + -> E.Get (Argument claim root) + -> E.Get (Argument claim root) + enforceType claim root p = do + unless (claim == tagVal' @claim) (fail "invalid claim type") + unless (root == tagVal' @root) (fail "invalid root type") + p + +-- -------------------------------------------------------------------------- -- +-- | Argument composition. +-- +-- The implementation balances the composition tree to be right associative. +-- This maximizes the composition on the lower level proofs. +-- +-- Nested calls to this can be quadratic in the worst case when associating from +-- the left. So one should avoid that. Instead arguments should be composed from +-- the right. +-- +compose + :: MonadThrow m + => ChainwebMerkleLogEntry a + => ChainwebMerkleLogEntry claim + => ChainwebMerkleLogEntry root + => Argument claim a + -> Argument a root + -> m (Argument claim root) +compose (Trivial _) a = return a -- FXME: check that claims match? +compose a (Trivial _) = return a -- FIXME: check that roots match? +compose (HeaderArgument m0) (HeaderArgument m1) + = HeaderArgument <$> ML.composeProofs m0 m1 +compose (ParentHeaderArgument m0) (HeaderArgument m1) + = ParentHeaderArgument <$> ML.composeProofs m0 m1 +compose (BlockPayloadHashArgument m0) (HeaderArgument m1) + = BlockPayloadHashArgument <$> ML.composeProofs m0 m1 +compose (PactOutputArgument m0) (BlockPayloadHashArgument m1) + = PactOutputArgument <$> ML.composeProofs m0 m1 +compose (PactOutputArgument m0) (ParentHeaderArgument m1) + = PactOutputArgument <$> ML.composeProofs m0 m1 +compose (EthHeaderArgument m0) (BlockPayloadHashArgument m1) + = EthHeaderArgument <$> ML.composeProofs m0 m1 +compose (ComposeArgument a0 a1) b = ComposeArgument a0 <$> compose a1 b +compose a (ComposeArgument b0 b1) = do + -- First compose a and b0. This may result in a ComposeArgument in which + -- case we and up with the previous case. + a' <- compose a b0 + compose a' b1 +compose a b = return (ComposeArgument a b) + + +-- -------------------------------------------------------------------------- -- +-- | Compute the proof root and provide evidence that the proof claim is +-- included in the root of the respective Chainweb Merkle tree. +-- +-- The claim is either a leave and a member of the Chainweb Merkle universe or +-- it is an inner node of the Chainweb Merkle tree. In case of the latter no +-- futher evidence about its type is included. +-- +-- IMPORTANT NOTE: +-- +-- If the result is an inner tree node (e.g. a 'BlockHash' or a +-- 'BlockPayloadHash') type is not checked and purely informational. There is no +-- evidence for it being correct. (we could add that evidence in the future, but +-- right now it is not provided.) +-- +-- It is an important security invariant of Chainweb that the preimage of each +-- root is completely guarded by types values in the Chainweb Merkle universe. +-- +runArg + :: MonadThrow m + => Argument claim root + -> m root +runArg (Trivial r) = return r +runArg (PactLegacyProof evidence) = do + r <- V1.runMerkleProof evidence + return (coerce r) +runArg (PactOutputArgument evidence) = do + return $ coerce $ ML.runProof evidence +runArg (ParentHeaderArgument evidence) = do + return $ coerce $ ML.runProof evidence +runArg (HeaderArgument evidence) = do + return $ coerce $ ML.runProof evidence +runArg (BlockPayloadHashArgument evidence) = do + return $ coerce $ ML.runProof evidence +runArg (EthReceiptArgument evidence) = do + -- We do not need to check the proof key because all values under this + -- root are receipts. However, we must make sure that the root has the + -- correct type, which is done either when checked against an oracle or when + -- it is used as claim in another proof. + r <- E.ReceiptsRoot <$> validateTrieProof evidence + return r +runArg (EthHeaderArgument evidence) = do + return $ coerce $ ML.runProof evidence +runArg (ComposeArgument a0 a1) = do + r0 <- runArg a0 + c1 <- argumentClaim a1 + when (r0 /= c1) $ throwM $ VerificationException "Composition failed" + runArg a1 + +-- runProof (Trivial r) = do +-- return r +-- runProof (ComposeArgument2 a0 a1 a3) (Conjunct c0 c1) = do +-- r0 <- runProof a0 c0 +-- r1 <- runProof a1 c1 +-- runProof a3 (Conjunct r0 r1) + +-- -------------------------------------------------------------------------- -- +-- | Ethereum Trie Proofs +-- + +validateTrieProof + :: MonadThrow m + => E.Proof + -> m E.Keccak256Hash +validateTrieProof p = case E.validateProof p of + Left _ -> + throwM (VerificationException "Malformed Proof") + Right False -> + throwM (VerificationException "Invalid Proof") + Right True -> + return $ E._proofRoot p + +-- -------------------------------------------------------------------------- -- +-- ATTIC + +-- tests + +-- Pact Output Proof script: +-- +-- import Chainweb.PayloadProvider.Pact.Genesis +-- import Chainweb.Version.Mainnet01 +-- import Chainweb.Utils +-- import Chainweb.Crypto.MerkleLog +-- import Chainweb.MerkleUniverse +-- import Chainweb.Pact.Payload +-- import Chainweb.BlockHeader +-- import Data.MerkleLog qualified as ML +-- import Control.Lens +-- script :: IO () +-- script = do +-- let plds = Chainweb.PayloadProvider.Pact.Genesis.genesisPayload Mainnet01 +-- pld0 <- preview (ixg $ unsafeChainId 0) plds +-- let (_, outs) = payloadWithOutputsToBlockObjects pld0 +-- p0 <- bodyProofV2 @ChainwebMerkleHashAlgorithm outs 0 +-- let bpld0 = payloadDataToBlockPayload (payloadWithOutputsToPayloadData pld0) +-- x <- headerProofV2 @BlockOutputsHash @ChainwebMerkleHashAlgorithm bpld0 +-- p <- ML.composeProofs p0 x +-- ML.runProof p +-- let poarg = PactOutputArgument @BlockPayloadHash p +-- runArg poarg +-- +-- let gh = genesisBlockHeader Mainnet01 (unsafeChainId 0) +-- hp <- headerProofV2 @BlockPayloadHash @ChainwebMerkleHashAlgorithm gh +-- ML.runProof hp +-- let harg = BlockPayloadHashArgument hp +-- runArg harg +-- +-- arg <- compose poarg harg +-- runArg arg + +-- -------------------------------------------------------------------------- -- +-- | Pact Output Proof + +-- instance E.RLP (ML.MerkleProof a) where +-- putRlp p = E.putRlp p +-- getRlp = E.label "MerkleProof" $ MerkleProof <$> E.getRlp +-- {-# INLINE putRlp #-} +-- {-# INLINE getRlp #-} + +-- createMerkleProof +-- :: [(B.ByteString, B.ByteString)] +-- -- ^ Key-value pairs that are stroed in the Trie +-- -> B.ByteString +-- -- ^ the key of the proofs +-- -> ML.MerkleProof a +-- createMerkleProof ps key = TrieProof +-- { _trieProofKey = E._proofKey p +-- , _trieProofNodes = E._proofNodes p +-- , _trieProofRoot = E._proofRoot p +-- } +-- where +-- p = E.createProof ps key + +-- -------------------------------------------------------------------------- -- +-- NEW SPV + +-- proofProperties +-- :: forall e kv +-- . KeyValue e kv +-- => ChainId +-- -> MerkleProof Sha2_512_256 +-- -> [kv] +-- proofProperties cid p = +-- [ "chain" .= cid +-- , "event" .= JsonProofSubject (_getMerkleProofSubject $ _merkleProofSubject p) +-- , "algorithm" .= ("Sha2_512_256" :: T.Text) +-- ] +-- where +-- obj = encodeB64UrlNoPaddingText . encodeMerkleProofObject +-- +-- data XChainMessage = XChainMessage +-- { _xChainMsgTargetChain :: !ChainId +-- , _xChainMsgReceiverAccount :: !B.ByteString +-- , _xChainMsgAmount :: !Stu +-- } +-- +-- data XChainEvent = XChainEvent +-- { _xChainSourceChain :: !ChainId +-- -- ^ not in the ETH log +-- , _xChainSourceContract :: !B.ByteString +-- -- ^ Added by the system +-- , _xChainSourceBlockHeight :: !Word64 +-- -- Not in EHT Log +-- , _xChainSourceTxIdx :: !Word64 +-- -- ^ this is not in the event it is provided by the user when they select +-- -- the event +-- , _xChainSourceEventIdx :: !Word64 +-- -- ^ this is not authenticated by the proof. It is provided by the user and +-- -- instructs the precompile to limit the proof to just this one event. +-- , _xChainMessage :: !XChainMessage +-- -- ^ The actual user payload. Cf. below for an example for simple ERC-20 +-- -- cross chain transfers. +-- } + + +-- data PayloadProof a = PayloadProof +-- { _payloadProofRootType :: !MerkleRootType +-- -- ^ The type of the Merle root. +-- , _payloadProofBlob :: !(MerkleProof a) +-- -- ^ The Merkle proof blob which coaintains both, the proof object and +-- -- the proof subject. +-- } deriving (Show, Eq, Generic, NFData) +-- +-- payloadProofProperties +-- :: forall a e kv +-- . MerkleHashAlgorithmName a +-- => KeyValue e kv +-- => PayloadProof a +-- -> [kv] +-- payloadProofProperties p = +-- [ "rootType" .= _payloadProofRootType p +-- , "object" .= (obj . _merkleProofObject) blob +-- , "subject" .= JsonProofSubject (_getMerkleProofSubject $ _merkleProofSubject blob) +-- , "algorithm" .= merkleHashAlgorithmName @a +-- ] +-- where +-- blob = _payloadProofBlob p +-- obj = encodeB64UrlNoPaddingText . encodeMerkleProofObject +-- {-# INLINE payloadProofProperties #-} diff --git a/src/Chainweb/Ranked.hs b/src/Chainweb/Ranked.hs index c6713e78dd..46681922b2 100644 --- a/src/Chainweb/Ranked.hs +++ b/src/Chainweb/Ranked.hs @@ -1,6 +1,16 @@ +{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} -- | -- Module: Chainweb.Ranked @@ -17,19 +27,29 @@ -- module Chainweb.Ranked ( Ranked(..) +, rankedHeight +, ranked , encodeRanked , decodeRanked +, JsonRanked(..) + +-- * IsRanked Class +, IsRanked(..) ) where import Chainweb.BlockHeight +import Chainweb.Utils import Chainweb.Utils.Serialization - import Control.DeepSeq +import Control.Lens hiding ((.=)) import Control.Monad - +import Data.Aeson import Data.Hashable - -import GHC.Generics +import Data.Typeable (Proxy(..), Typeable, typeRep) +import GHC.Generics (Generic) +import GHC.TypeLits +import Data.Text qualified as T +import Control.Monad.Catch -- -------------------------------------------------------------------------- -- -- BlockHeight Ranked Data @@ -46,8 +66,10 @@ data Ranked a = Ranked { _rankedHeight :: !BlockHeight , _ranked :: !a } - deriving (Show, Eq, Ord, Generic) + deriving stock (Functor, Show, Eq, Ord, Generic) deriving anyclass (Hashable, NFData) +makeLenses ''Ranked + encodeRanked :: (a -> Put) -> Ranked a -> Put encodeRanked putA (Ranked r a) = do @@ -61,3 +83,59 @@ decodeRanked decodeA = Ranked <*> decodeA {-# INLINE decodeRanked #-} +instance HasTextRepresentation a => HasTextRepresentation (Ranked a) where + toText a = toText (_rankedHeight a) <> "." <> toText (_ranked a) + fromText t = case T.break (== '.') t of + (h, m) + | T.null m -> throwM $ TextFormatException $ "Ranked: failed to parse: " <> t + | otherwise -> Ranked <$> fromText h <*> fromText (T.tail m) + {-# INLINE toText #-} + {-# INLINE fromText #-} + +-- -------------------------------------------------------------------------- -- +-- Has Rank Class + +-- | Class of Ranked Types. +-- +-- All instances of this class must have an 'Ord' instance that sorts by height +-- and a encoding functions that perserve this ordering on the lexicographic +-- order of the encoded values. +-- +-- This class is used because for some types the rank can be derived from the +-- value itself. In those cases the use of the 'Ranked' data type is wastefull +-- and a simple 'newtype' wrapper is better suited. This class is used to +-- abstract about both cases and to avoid cluttering the namespace. +-- +class Ord r => IsRanked r where + rank :: r -> BlockHeight + +instance Ord a => IsRanked (Ranked a) where + rank = _rankedHeight + + +-- -------------------------------------------------------------------------- -- + +-- | JSON Encoding for Ranked Types. +-- +-- The first type parameter is the JSON key for the value. +-- +newtype JsonRanked (s :: Symbol) a = JsonRanked { _jsonRanked :: Ranked a } + +instance (ToJSON a, KnownSymbol s) => ToJSON (JsonRanked s a) where + toJSON (JsonRanked r) = object + [ "height" .= _rankedHeight r + , symbolText @s .= _ranked r + ] + toEncoding (JsonRanked r) = pairs $ mconcat + [ "height" .= _rankedHeight r + , symbolText @s .= _ranked r + ] + {-# INLINE toJSON #-} + {-# INLINE toEncoding #-} + +instance (KnownSymbol s, Typeable a, FromJSON a) => FromJSON (JsonRanked s a) where + parseJSON = withObject ("Ranked " <> show (typeRep (Proxy @a))) $ \o -> + fmap JsonRanked $ Ranked + <$> o .: "height" + <*> o .: symbolText @s + {-# INLINE parseJSON #-} diff --git a/src/Chainweb/RestAPI.hs b/src/Chainweb/RestAPI.hs index bb2aa56518..84b69f5f65 100644 --- a/src/Chainweb/RestAPI.hs +++ b/src/Chainweb/RestAPI.hs @@ -49,19 +49,12 @@ module Chainweb.RestAPI , someServiceApiServer , serviceApiApplication , serveServiceApiSocket - --- * Chainweb API Client - --- ** BlockHeaderDb API Client -, module Chainweb.BlockHeaderDB.RestAPI.Client - --- ** P2P API Client -, module P2P.Node.RestAPI.Client ) where import Control.Monad (guard) import Data.Bool (bool) +import Data.Foldable import GHC.Generics (Generic) @@ -80,22 +73,18 @@ import System.Clock import Chainweb.Backup import Chainweb.BlockHeaderDB -import Chainweb.BlockHeaderDB.RestAPI.Client import Chainweb.BlockHeaderDB.RestAPI.Server import Chainweb.ChainId import Chainweb.Chainweb.Configuration -import Chainweb.Chainweb.MinerResources (MiningCoordination) +import Chainweb.Miner.Coordinator (MiningCoordination) import Chainweb.CutDB import Chainweb.CutDB.RestAPI.Server import Chainweb.HostAddress import Chainweb.Logger (Logger) -import Chainweb.Mempool.Mempool (MempoolBackend) -import qualified Chainweb.Mempool.RestAPI.Server as Mempool +import Chainweb.Pact.Mempool.Mempool (MempoolBackend) +import qualified Chainweb.Pact.Mempool.RestAPI.Server as Mempool import qualified Chainweb.Miner.RestAPI.Server as Mining -import qualified Chainweb.Pact.RestAPI.Server as PactAPI -import Chainweb.Payload.PayloadStore -import Chainweb.Payload.RestAPI -import Chainweb.Payload.RestAPI.Server +import Chainweb.Pact.Payload.RestAPI import Chainweb.RestAPI.Backup import Chainweb.RestAPI.Config import Chainweb.RestAPI.Health @@ -109,7 +98,6 @@ import Chainweb.Version import Network.X509.SelfSigned import P2P.Node.PeerDB -import P2P.Node.RestAPI.Client import P2P.Node.RestAPI.Server -- -------------------------------------------------------------------------- -- @@ -145,21 +133,21 @@ serveSocketTls settings certChain key = runTLSSocket tlsSettings settings -- | Datatype for collectively passing all storage backends to -- functions that run a chainweb server. -- -data ChainwebServerDbs t tbl = ChainwebServerDbs - { _chainwebServerCutDb :: !(Maybe (CutDb tbl)) - , _chainwebServerBlockHeaderDbs :: ![(ChainId, BlockHeaderDb)] - , _chainwebServerMempools :: ![(ChainId, MempoolBackend t)] - , _chainwebServerPayloadDbs :: ![(ChainId, PayloadDb tbl)] +data ChainwebServerDbs l t = ChainwebServerDbs + { _chainwebServerCutDb :: !(Maybe (CutDb l)) + , _chainwebServerBlockHeaderDbs :: !(ChainMap BlockHeaderDb) + , _chainwebServerMempools :: !(ChainMap (MempoolBackend t)) + , _chainwebServerPayloads :: !(ChainMap SomeServer) , _chainwebServerPeerDbs :: ![(NetworkId, PeerDb)] } deriving (Generic) -emptyChainwebServerDbs :: ChainwebServerDbs t tbl +emptyChainwebServerDbs :: ChainwebServerDbs l t emptyChainwebServerDbs = ChainwebServerDbs { _chainwebServerCutDb = Nothing - , _chainwebServerBlockHeaderDbs = [] - , _chainwebServerMempools = [] - , _chainwebServerPayloadDbs = [] + , _chainwebServerBlockHeaderDbs = mempty + , _chainwebServerMempools = mempty + , _chainwebServerPayloads = mempty , _chainwebServerPeerDbs = [] } @@ -210,62 +198,60 @@ chainwebServiceMiddlewares -- Chainweb Peer Server someChainwebServer - :: Show t - => CanReadablePayloadCas tbl + :: HasVersion + => Show t => ChainwebConfiguration - -> ChainwebServerDbs t tbl + -> ChainwebServerDbs l t -> SomeServer someChainwebServer config dbs = - maybe mempty (someCutServer v cutPeerDb) cuts - <> somePayloadServers v p2pPayloadBatchLimit payloads - <> someP2pBlockHeaderDbServers v blocks - <> Mempool.someMempoolServers v mempools - <> someP2pServers v peers + maybe mempty (someCutServer cutPeerDb) cuts + <> fold payloads + <> someP2pBlockHeaderDbServers blocks + <> Mempool.someMempoolServers mempools + <> someP2pServers peers <> someGetConfigServer config where - payloads = _chainwebServerPayloadDbs dbs + payloads = _chainwebServerPayloads dbs blocks = _chainwebServerBlockHeaderDbs dbs cuts = _chainwebServerCutDb dbs peers = _chainwebServerPeerDbs dbs mempools = _chainwebServerMempools dbs cutPeerDb = fromJuste $ lookup CutNetwork peers - v = _configChainwebVersion config -- | Legacy version with Hashes API that is used in tests -- -- When we have comprehensive testing for the service API we can remove this -- someChainwebServerWithHashesAndSpvApi - :: Show t - => CanReadablePayloadCas tbl + :: HasVersion + => Show t => ChainwebConfiguration - -> ChainwebServerDbs t tbl + -> ChainwebServerDbs l t -> SomeServer someChainwebServerWithHashesAndSpvApi config dbs = - maybe mempty (someCutServer v cutPeerDb) cuts - <> somePayloadServers v p2pPayloadBatchLimit payloads - <> someBlockHeaderDbServers v blocks payloads - <> Mempool.someMempoolServers v mempools - <> someP2pServers v peers + maybe mempty (someCutServer cutPeerDb) cuts + <> fold payloads + <> someBlockHeaderDbServers blocks + <> Mempool.someMempoolServers mempools + <> someP2pServers peers <> someGetConfigServer config - <> maybe mempty (someSpvServers v) cuts + <> maybe mempty someSpvServers cuts where - payloads = _chainwebServerPayloadDbs dbs + payloads = _chainwebServerPayloads dbs blocks = _chainwebServerBlockHeaderDbs dbs cuts = _chainwebServerCutDb dbs peers = _chainwebServerPeerDbs dbs mempools = _chainwebServerMempools dbs cutPeerDb = fromJuste $ lookup CutNetwork peers - v = _configChainwebVersion config -- -------------------------------------------------------------------------- -- -- Chainweb P2P API Application chainwebApplication - :: Show t - => CanReadablePayloadCas tbl + :: HasVersion + => Show t => ChainwebConfiguration - -> ChainwebServerDbs t tbl + -> ChainwebServerDbs l t -> Application chainwebApplication config dbs = chainwebP2pMiddlewares @@ -277,10 +263,10 @@ chainwebApplication config dbs -- When we have comprehensive testing for the service API we can remove this -- chainwebApplicationWithHashesAndSpvApi - :: Show t - => CanReadablePayloadCas tbl + :: HasVersion + => Show t => ChainwebConfiguration - -> ChainwebServerDbs t tbl + -> ChainwebServerDbs l t -> Application chainwebApplicationWithHashesAndSpvApi config dbs = chainwebP2pMiddlewares @@ -288,44 +274,44 @@ chainwebApplicationWithHashesAndSpvApi config dbs $ someChainwebServerWithHashesAndSpvApi config dbs serveChainwebOnPort - :: Show t - => CanReadablePayloadCas tbl + :: HasVersion + => Show t => Port -> ChainwebConfiguration - -> ChainwebServerDbs t tbl + -> ChainwebServerDbs l t -> IO () serveChainwebOnPort p c dbs = run (int p) $ chainwebApplication c dbs serveChainweb - :: Show t - => CanReadablePayloadCas tbl + :: HasVersion + => Show t => Settings -> ChainwebConfiguration - -> ChainwebServerDbs t tbl + -> ChainwebServerDbs l t -> IO () serveChainweb s c dbs = runSettings s $ chainwebApplication c dbs serveChainwebSocket - :: Show t - => CanReadablePayloadCas tbl + :: HasVersion + => Show t => Settings -> Socket -> ChainwebConfiguration - -> ChainwebServerDbs t tbl + -> ChainwebServerDbs l t -> Middleware -> IO () serveChainwebSocket settings sock c dbs m = runSettingsSocket settings sock $ m $ chainwebApplication c dbs serveChainwebSocketTls - :: Show t - => CanReadablePayloadCas tbl + :: HasVersion + => Show t => Settings -> X509CertChainPem -> X509KeyPem -> Socket -> ChainwebConfiguration - -> ChainwebServerDbs t tbl + -> ChainwebServerDbs l t -> Middleware -> IO () serveChainwebSocketTls settings certChain key sock c dbs m = @@ -336,86 +322,76 @@ serveChainwebSocketTls settings certChain key sock c dbs m = -- Run Chainweb P2P Server that serves a single PeerDb servePeerDbSocketTls - :: Settings + :: HasVersion + => Settings -> X509CertChainPem -> X509KeyPem -> Socket - -> ChainwebVersion -> NetworkId -> PeerDb -> Middleware -> IO () -servePeerDbSocketTls settings certChain key sock v nid pdb m = +servePeerDbSocketTls settings certChain key sock nid pdb m = serveSocketTls settings certChain key sock $ m $ chainwebP2pMiddlewares $ someServerApplication $ someP2pServer - $ somePeerDbVal v nid pdb + $ somePeerDbVal nid pdb -- -------------------------------------------------------------------------- -- -- Chainweb Service API Application someServiceApiServer - :: Show t - => CanReadablePayloadCas tbl - => Logger logger - => ChainwebVersion - -> ChainwebServerDbs t tbl - -> [(ChainId, PactAPI.PactServerData logger tbl)] - -> Maybe (MiningCoordination logger tbl) + :: Logger logger + => HasVersion + => ChainwebServerDbs l t + -> Maybe (MiningCoordination logger) -> HeaderStream -> Maybe (BackupEnv logger) -> PayloadBatchLimit -> SomeServer -someServiceApiServer v dbs pacts mr (HeaderStream hs) backupEnv pbl = +someServiceApiServer dbs mr (HeaderStream hs) backupEnv _pbl = someHealthCheckServer - <> maybe mempty (someBackupServer v) backupEnv - <> maybe mempty (someNodeInfoServer v) cuts - <> PactAPI.somePactServers v pacts - <> maybe mempty (Mining.someMiningServer v) mr - -- <> maybe mempty (someSpvServers v) cuts -- AFAIK currently not used + <> maybe mempty someBackupServer backupEnv + <> maybe mempty someNodeInfoServer cuts + <> maybe mempty Mining.someMiningServer mr + <> maybe mempty someSpvServers cuts -- AFAIK currently not used -- GET Cut, Payload, and Headers endpoints - <> maybe mempty (someCutGetServer v) cuts - <> somePayloadServers v pbl payloads - <> someBlockHeaderDbServers v blocks payloads -- TODO make max limits configurable - <> maybe mempty (someBlockStreamServer v) (bool Nothing cuts hs) + <> maybe mempty someCutGetServer cuts + <> fold payloads + <> someBlockHeaderDbServers blocks + <> maybe mempty someBlockStreamServer (bool Nothing cuts hs) where cuts = _chainwebServerCutDb dbs - payloads = _chainwebServerPayloadDbs dbs + payloads = _chainwebServerPayloads dbs blocks = _chainwebServerBlockHeaderDbs dbs serviceApiApplication - :: Show t - => CanReadablePayloadCas tbl - => Logger logger - => ChainwebVersion - -> ChainwebServerDbs t tbl - -> [(ChainId, PactAPI.PactServerData logger tbl)] - -> Maybe (MiningCoordination logger tbl) + :: Logger logger + => HasVersion + => ChainwebServerDbs l t + -> Maybe (MiningCoordination logger) -> HeaderStream -> Maybe (BackupEnv logger) -> PayloadBatchLimit -> Application -serviceApiApplication v dbs pacts mr hs be pbl +serviceApiApplication dbs mr hs benv pbl = chainwebServiceMiddlewares . someServerApplication - $ someServiceApiServer v dbs pacts mr hs be pbl + $ someServiceApiServer dbs mr hs benv pbl serveServiceApiSocket - :: Show t - => CanReadablePayloadCas tbl - => Logger logger + :: Logger logger + => HasVersion => Settings -> Socket - -> ChainwebVersion - -> ChainwebServerDbs t tbl - -> [(ChainId, PactAPI.PactServerData logger tbl)] - -> Maybe (MiningCoordination logger tbl) + -> ChainwebServerDbs l t + -> Maybe (MiningCoordination logger) -> HeaderStream -> Maybe (BackupEnv logger) -> PayloadBatchLimit -> Middleware -> IO () -serveServiceApiSocket s sock v dbs pacts mr hs be pbl m = - runSettingsSocket s sock $ m $ serviceApiApplication v dbs pacts mr hs be pbl +serveServiceApiSocket s sock dbs mr hs benv pbl m = + runSettingsSocket s sock $ m $ serviceApiApplication dbs mr hs benv pbl diff --git a/src/Chainweb/RestAPI/Backup.hs b/src/Chainweb/RestAPI/Backup.hs index 6c9c9ec463..c20508c5b4 100644 --- a/src/Chainweb/RestAPI/Backup.hs +++ b/src/Chainweb/RestAPI/Backup.hs @@ -1,6 +1,7 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ImportQualifiedPost #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} @@ -17,25 +18,23 @@ module Chainweb.RestAPI.Backup ) where import Control.Concurrent.Async +import Chainweb.Backup qualified as Backup +import Chainweb.Logger +import Chainweb.RestAPI.Utils +import Chainweb.Time +import Chainweb.Utils +import Chainweb.Version import Control.Concurrent.STM import Control.Monad import Control.Monad.Catch import Control.Monad.IO.Class import Data.Proxy import Data.Text (Text) -import qualified Data.Text as T +import Data.Text qualified as T +import Servant import System.IO.Unsafe import System.LogLevel -import Servant - -import qualified Chainweb.Backup as Backup -import Chainweb.Logger -import Chainweb.Time - -import Chainweb.RestAPI.Utils -import Chainweb.Version - type BackupApi_ = "make-backup" :> QueryFlag "backupPact" :> PostAccepted '[PlainText] Text :<|> "check-backup" :> Capture "backup-name" FilePath :> Get '[PlainText] Backup.BackupStatus @@ -52,9 +51,10 @@ globalCurrentBackup = unsafePerformIO $! newTVarIO Nothing someBackupApi :: ChainwebVersion -> SomeApi someBackupApi (FromSingChainwebVersion (SChainwebVersion :: Sing v)) = SomeApi $ backupApi @v -someBackupServer :: Logger logger => ChainwebVersion -> Backup.BackupEnv logger -> SomeServer -someBackupServer (FromSingChainwebVersion (SChainwebVersion :: Sing vT)) backupEnv = - SomeServer (Proxy @(BackupApi vT)) $ makeBackup :<|> checkBackup +someBackupServer :: (HasVersion, Logger logger) => Backup.BackupEnv logger -> SomeServer +someBackupServer backupEnv = case implicitVersion of + (FromSingChainwebVersion (SChainwebVersion :: Sing vT)) -> + SomeServer (Proxy @(BackupApi vT)) $ makeBackup :<|> checkBackup where noSuchBackup = setErrText "no such backup" err404 makeBackup backupPactFlag = liftIO $ do @@ -86,5 +86,4 @@ someBackupServer (FromSingChainwebVersion (SChainwebVersion :: Sing vT)) backupE getNextBackupIdentifier :: IO Text getNextBackupIdentifier = do Time (epochToNow :: TimeSpan Integer) <- getCurrentTimeIntegral - return $ microsToText (timeSpanToMicros epochToNow) - + return $ toText (timeSpanToMicros epochToNow) diff --git a/src/Chainweb/RestAPI/Config.hs b/src/Chainweb/RestAPI/Config.hs index d150c5daea..426a66e797 100644 --- a/src/Chainweb/RestAPI/Config.hs +++ b/src/Chainweb/RestAPI/Config.hs @@ -28,7 +28,10 @@ import Servant -- internal modules import Chainweb.Chainweb.Configuration -import Chainweb.Miner.Config +import Chainweb.PayloadProvider.EVM +import Chainweb.PayloadProvider.Minimal (mpcRedeemAccount) +import Chainweb.PayloadProvider.Minimal.Payload (invalidAccount) +import Chainweb.PayloadProvider.Pact.Configuration (pactConfigMiner) import Chainweb.RestAPI.Utils import P2P.Node.Configuration @@ -54,12 +57,13 @@ someGetConfigServer config = SomeServer (Proxy @GetConfigApi) $ return $ set (configP2p . p2pConfigPeer . peerConfigKeyFile) Nothing -- Miner Info - $ set (configMining . miningCoordination . coordinationMiners) mempty - $ set (configMining . miningInNode . nodeMiner) invalidMiner + $ set (configPayloadProviders . payloadProviderConfigMinimal . mpcRedeemAccount) invalidAccount + $ set (configPayloadProviders . payloadProviderConfigPact . traversed . pactConfigMiner) Nothing + $ set (configPayloadProviders . payloadProviderConfigEvm . traversed . evmConfMinerAddress) Nothing + $ set (configPayloadProviders . payloadProviderConfigEvm . traversed . evmConfEngineJwtSecret) (_evmConfEngineJwtSecret defaultEvmProviderConfig) -- Service API port $ set (configServiceApi . serviceApiConfigPort) 0 $ set (configServiceApi . serviceApiConfigInterface) "invalid" $ set configBackup defaultBackupConfig config - diff --git a/src/Chainweb/RestAPI/NetworkID.hs b/src/Chainweb/RestAPI/NetworkID.hs index 9d8c46710e..641e4a02df 100644 --- a/src/Chainweb/RestAPI/NetworkID.hs +++ b/src/Chainweb/RestAPI/NetworkID.hs @@ -4,6 +4,7 @@ {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} +{-# LANGUAGE ImportQualifiedPost #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -42,24 +43,17 @@ module Chainweb.RestAPI.NetworkID ) where import Configuration.Utils - +import Chainweb.ChainId +import Chainweb.Utils hiding (check) import Control.DeepSeq import Control.Monad.Catch - import Data.Hashable import Data.Proxy -import qualified Data.Text as T - +import Data.Singletons +import Data.Text qualified as T import GHC.Generics (Generic) import GHC.Stack (HasCallStack) --- Internal imports - -import Chainweb.ChainId -import Chainweb.Utils hiding (check) - -import Data.Singletons - -- -------------------------------------------------------------------------- -- -- Network ID @@ -77,15 +71,15 @@ data NetworkId -- networkIdToText :: NetworkId -> T.Text networkIdToText CutNetwork = "cut" -networkIdToText (ChainNetwork cid) = "chain/" <> chainIdToText cid -networkIdToText (MempoolNetwork cid) = "chain/" <> chainIdToText cid <> "/mempool" +networkIdToText (ChainNetwork cid) = "chain/" <> toText cid +networkIdToText (MempoolNetwork cid) = "chain/" <> toText cid <> "/mempool" {-# INLINE networkIdToText #-} networkIdFromText :: MonadThrow m => T.Text -> m NetworkId networkIdFromText t = case T.split (== '/') t of ["cut"] -> return CutNetwork - ["chain", a, "mempool"] -> MempoolNetwork <$> chainIdFromText a - ["chain", a] -> ChainNetwork <$> chainIdFromText a + ["chain", a, "mempool"] -> MempoolNetwork <$> fromTextM a + ["chain", a] -> ChainNetwork <$> fromTextM a _ -> throwM $ TextFormatException $ "unrecognized network id: \"" <> t <> "\"." unsafeNetworkIdFromText :: HasCallStack => T.Text -> NetworkId diff --git a/src/Chainweb/RestAPI/NodeInfo.hs b/src/Chainweb/RestAPI/NodeInfo.hs index 56ee7b05f2..6e952a99fd 100644 --- a/src/Chainweb/RestAPI/NodeInfo.hs +++ b/src/Chainweb/RestAPI/NodeInfo.hs @@ -6,14 +6,16 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeOperators #-} +{-# LANGUAGE OverloadedStrings #-} {-# OPTIONS_GHC -fno-warn-orphans #-} +{-# LANGUAGE LambdaCase #-} -- | An endpoint for getting node information. module Chainweb.RestAPI.NodeInfo where -import Control.Lens +import Control.Lens hiding ((.=)) import Control.Monad.Trans import Data.Aeson import Data.Bifunctor @@ -35,6 +37,7 @@ import Chainweb.Cut.CutHashes import Chainweb.CutDB import Chainweb.Difficulty (BlockDelay) import Chainweb.Graph +import Chainweb.Ranked import Chainweb.RestAPI.Utils import Chainweb.Utils import Chainweb.Utils.Rule @@ -45,9 +48,9 @@ type NodeInfoApi = "info" :> Get '[JSON] NodeInfo someNodeInfoApi :: SomeApi someNodeInfoApi = SomeApi (Proxy @NodeInfoApi) -someNodeInfoServer :: ChainwebVersion -> CutDb tbl -> SomeServer -someNodeInfoServer v c = - SomeServer (Proxy @NodeInfoApi) (nodeInfoHandler v $ someCutDbVal v c) +someNodeInfoServer :: HasVersion => CutDb l -> SomeServer +someNodeInfoServer c = + SomeServer (Proxy @NodeInfoApi) (nodeInfoHandler $ someCutDbVal c) data NodeInfo = NodeInfo { nodeVersion :: ChainwebVersionName @@ -72,36 +75,49 @@ data NodeInfo = NodeInfo -- ^ All graph upgrades , nodeBlockDelay :: BlockDelay -- ^ The PoW block delay of the node (microseconds) + , nodePayloadProviders :: ChainMap Value } deriving (Show, Eq, Generic) deriving anyclass (ToJSON, FromJSON) -nodeInfoHandler :: ChainwebVersion -> SomeCutDb tbl -> Server NodeInfoApi -nodeInfoHandler v (SomeCutDb (CutDbT db :: CutDbT cas v)) = do +nodeInfoHandler :: HasVersion => SomeCutDb -> Server NodeInfoApi +nodeInfoHandler (SomeCutDb (CutDbT db :: CutDbT l v)) = do curCut <- liftIO $ _cut db let ch = cutToCutHashes Nothing curCut - let curHeight = maximum $ map _bhwhHeight $ HM.elems $ _cutHashes ch - let graphs = unpackGraphs v + let curHeight = maximum $ map _rankedHeight $ HM.elems $ _cutHashes ch + let graphs = unpackGraphs let curGraph = unsafeHead "Chainweb.RestAPI.NodeInfo.nodeInfoHandler.curGraph" $ dropWhile (\(h,_) -> h > curHeight) graphs let curChains = map fst $ snd curGraph return $ NodeInfo - { nodeVersion = _versionName v + { nodeVersion = _versionName implicitVersion , nodePackageVersion = chainwebNodeVersionHeaderValue , nodeApiVersion = prettyApiVersion , nodeChains = T.pack . show <$> curChains , nodeNumberOfChains = length curChains , nodeGraphHistory = graphs - , nodeLatestBehaviorHeight = latestBehaviorAt v - , nodeGenesisHeights = map (\c -> (chainIdToText c, genesisHeight v c)) $ HS.toList (chainIds v) - , nodeHistoricalChains = ruleElems $ fmap (HM.toList . HM.map HS.toList . toAdjacencySets) $ _versionGraphs v - , nodeBlockDelay = _versionBlockDelay v + , nodeLatestBehaviorHeight = latestBehaviorAt + , nodeGenesisHeights = map (\c -> (toText c, genesisHeight c)) $ HS.toList chainIds + , nodeHistoricalChains = + ruleElems $ HM.toList . HM.map HS.toList . toAdjacencySets <$> _versionGraphs implicitVersion + , nodeBlockDelay = _versionBlockDelay implicitVersion + , nodePayloadProviders = _versionPayloadProviderTypes implicitVersion <&> \case + EvmProvider n -> object + [ "type" .= ("eth" :: Text) + , "ethChainId" .= n + ] + PactProvider -> object + [ "type" .= ("pact" :: Text) + ] + MinimalProvider -> object + [ "type" .= ("parked" :: Text) + ] } -- | Converts chainwebGraphs to a simpler structure that has invertible JSON -- instances. -unpackGraphs :: ChainwebVersion -> [(BlockHeight, [(Int, [Int])])] -unpackGraphs v = gs +unpackGraphs :: HasVersion => [(BlockHeight, [(Int, [Int])])] +unpackGraphs = gs where - gs = map (second graphAdjacencies) $ NE.toList $ ruleElems $ _versionGraphs v + gs = map (second graphAdjacencies) $ NE.toList $ ruleElems $ _versionGraphs implicitVersion graphAdjacencies = map unChain . HM.toList . fmap HS.toList . G.adjacencySets . view chainGraphGraph unChain (a, bs) = (chainIdInt a, map chainIdInt bs) diff --git a/src/Chainweb/RestAPI/Orphans.hs b/src/Chainweb/RestAPI/Orphans.hs index 80e9843e48..fa8e69defe 100644 --- a/src/Chainweb/RestAPI/Orphans.hs +++ b/src/Chainweb/RestAPI/Orphans.hs @@ -32,7 +32,6 @@ module Chainweb.RestAPI.Orphans () where import Control.Monad -import Data.Bool import Data.Bifunctor import Data.Proxy import Data.Semigroup (Max(..), Min(..)) @@ -53,13 +52,14 @@ import Chainweb.Utils import Chainweb.Utils.Paging import Chainweb.Utils.Serialization import Chainweb.Version -import Chainweb.Pact.Types +-- import Chainweb.Pact.Types import P2P.Peer import Pact.Parse (ParsedInteger(..)) import Pact.Server.API () import Pact.Types.Gas (GasLimit(..)) +import Control.Monad.Catch -- -------------------------------------------------------------------------- -- -- HttpApiData @@ -74,7 +74,7 @@ instance ToHttpApiData PeerId where toUrlPiece = toText instance FromHttpApiData PeerId where - parseUrlPiece = first T.pack . eitherFromText + parseUrlPiece = first (T.pack . displayException) . fromText instance FromHttpApiData HostAddress where parseUrlPiece = first sshow . readHostAddressBytes . T.encodeUtf8 @@ -94,16 +94,16 @@ instance ToHttpApiData BlockPayloadHash where toUrlPiece = encodeB64UrlNoPaddingText . runPutS . encodeBlockPayloadHash instance FromHttpApiData ChainwebVersionName where - parseUrlPiece = first T.pack . eitherFromText + parseUrlPiece = first (T.pack . displayException) . fromText instance ToHttpApiData ChainwebVersionName where toUrlPiece = toText instance FromHttpApiData ChainId where - parseUrlPiece = first sshow . chainIdFromText + parseUrlPiece = first sshow . fromText instance ToHttpApiData ChainId where - toUrlPiece = chainIdToText + toUrlPiece = toText deriving newtype instance FromHttpApiData BlockHeight @@ -172,25 +172,3 @@ instance where type MkLink (sym :> sub) a = MkLink sub a toLink toA _ = toLink toA (Proxy @(ChainIdSymbol sym :> sub)) - -instance ToHttpApiData LocalPreflightSimulation where - toUrlPiece PreflightSimulation = toUrlPiece True - toUrlPiece LegacySimulation = toUrlPiece False - -instance FromHttpApiData LocalPreflightSimulation where - parseUrlPiece = fmap (bool LegacySimulation PreflightSimulation) . parseUrlPiece - -instance ToHttpApiData LocalSignatureVerification where - toUrlPiece Verify = toUrlPiece True - toUrlPiece NoVerify = toUrlPiece False - -instance FromHttpApiData LocalSignatureVerification where - parseUrlPiece = fmap (bool NoVerify Verify) . parseUrlPiece - -deriving newtype instance FromHttpApiData RewindDepth - -deriving newtype instance ToHttpApiData RewindDepth - -deriving newtype instance FromHttpApiData ConfirmationDepth - -deriving newtype instance ToHttpApiData ConfirmationDepth diff --git a/src/Chainweb/RestAPI/Utils.hs b/src/Chainweb/RestAPI/Utils.hs index b380101cb4..98c97e9aee 100644 --- a/src/Chainweb/RestAPI/Utils.hs +++ b/src/Chainweb/RestAPI/Utils.hs @@ -22,6 +22,7 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE RankNTypes #-} #ifndef CURRENT_PACKAGE_VERSION #define CURRENT_PACKAGE_VERSION "UNKNOWN" @@ -42,6 +43,7 @@ module Chainweb.RestAPI.Utils Reassoc , setErrText , setErrJSON +, setErrJSONPact -- * API Version , Version @@ -133,6 +135,7 @@ import Chainweb.RestAPI.Orphans () import Chainweb.Utils import Chainweb.Utils.Paging import Chainweb.Version +import qualified Pact.JSON.Encode as J -- -------------------------------------------------------------------------- -- -- Servant Utils @@ -168,6 +171,12 @@ setErrJSON m e = e , errHeaders = addHeader ("Content-Type", "application/json;charset=utf-8") (errHeaders e) } +setErrJSONPact :: J.Encode a => a -> ServerError -> ServerError +setErrJSONPact m e = e + { errBody = J.encode m + , errHeaders = addHeader ("Content-Type", "application/json;charset=utf-8") (errHeaders e) + } + -- -------------------------------------------------------------------------- -- -- API Version diff --git a/src/Chainweb/SPV.hs b/src/Chainweb/SPV.hs index 3eb66c09b0..aef9a1c0b3 100644 --- a/src/Chainweb/SPV.hs +++ b/src/Chainweb/SPV.hs @@ -3,8 +3,6 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} -{-# LANGUAGE ImportQualifiedPost #-} -{-# LANGUAGE NumericUnderscores #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -21,31 +19,34 @@ -- module Chainweb.SPV ( SpvException(..) -, TransactionProof(..) -, proofChainId , TransactionOutputProof(..) , outputProofChainId +, FakeEventProof(..) ) where - -import Chainweb.BlockHeader -import Chainweb.BlockHeight -import Chainweb.ChainId -import Chainweb.Utils import Control.Applicative import Control.DeepSeq import Control.Lens (Getter, to) import Control.Monad import Control.Monad.Catch -import Crypto.Hash.Algorithms + import Data.Aeson -import Data.Aeson.Types qualified as Aeson -import Data.ByteString qualified as B -import Data.MerkleLog hiding (Expected, Actual) -import Data.Text qualified as T +import qualified Data.Aeson.Types as Aeson +import Data.MerkleLog.Common hiding (Expected, Actual) +import qualified Data.MerkleLog.V1 as V1 +import qualified Data.Text as T + import GHC.Generics (Generic) + import Numeric.Natural -import Prelude hiding (lookup) + +-- internal modules + +import Chainweb.BlockHeader +import Chainweb.BlockHeight +import Chainweb.ChainId +import Chainweb.MerkleUniverse +import Chainweb.Utils -- -------------------------------------------------------------------------- -- -- Exceptions @@ -86,23 +87,26 @@ proofProperties :: forall e kv . KeyValue e kv => ChainId - -> MerkleProof SHA512t_256 + -> V1.MerkleProof ChainwebMerkleHashAlgorithm -> [kv] proofProperties cid p = [ "chain" .= cid - , "object" .= obj (_merkleProofObject p) - , "subject" .= JsonProofSubject (_getMerkleProofSubject $ _merkleProofSubject p) + , "object" .= obj (V1._merkleProofObject p) + , "subject" .= JsonProofSubject (V1._getMerkleProofSubject $ V1._merkleProofSubject p) , "algorithm" .= ("SHA512t_256" :: T.Text) ] where - obj = encodeB64UrlNoPaddingText . encodeMerkleProofObject + obj = encodeB64UrlNoPaddingText . V1.encodeMerkleProofObject -- | Internal helper type of holding the ToJSON dictionary for the -- legacy proof subject encoding. -- -newtype JsonProofSubject = JsonProofSubject (MerkleNodeType SHA512t_256 B.ByteString) +newtype JsonProofSubject = JsonProofSubject (MerkleNodeType ChainwebMerkleHashAlgorithm) -jsonProofSubjectProperties :: KeyValue e kv => JsonProofSubject -> [kv] +jsonProofSubjectProperties + :: KeyValue e kv + => JsonProofSubject + -> [kv] jsonProofSubjectProperties (JsonProofSubject (TreeNode h)) = [ "tree" .= encodeB64UrlNoPaddingText (encodeMerkleRoot h) ] @@ -118,7 +122,7 @@ instance ToJSON JsonProofSubject where parseProof :: String - -> (ChainId -> MerkleProof SHA512t_256 -> a) + -> (ChainId -> V1.MerkleProof ChainwebMerkleHashAlgorithm -> a) -> Value -> Aeson.Parser a parseProof name mkProof = withObject name $ \o -> mkProof @@ -126,11 +130,11 @@ parseProof name mkProof = withObject name $ \o -> mkProof <*> parse o <* (assertJSON ("SHA512t_256" :: T.Text) =<< o .: "algorithm") where - parse o = MerkleProof + parse o = V1.MerkleProof <$> (parseSubject =<< o .: "subject") <*> (parseObject =<< o .: "object") - parseSubject = withObject "ProofSubject" $ \o -> MerkleProofSubject + parseSubject = withObject "ProofSubject" $ \o -> V1.MerkleProofSubject <$> ((o .: "tree" >>= parseTreeNode) <|> (o .: "input" >>= parseInputNode)) parseTreeNode = withText "TreeNode" @@ -140,7 +144,7 @@ parseProof name mkProof = withObject name $ \o -> mkProof $ fmap InputNode . parseBinary pure parseObject = withText "ProofObject" - $ parseBinary decodeMerkleProofObject + $ parseBinary V1.decodeMerkleProofObject assertJSON e a = unless (e == a) $ fail $ "expected " <> sshow e <> ", got " <> sshow a @@ -149,62 +153,72 @@ parseProof name mkProof = withObject name $ \o -> mkProof p =<< decodeB64UrlNoPaddingText t -- -------------------------------------------------------------------------- -- --- Transaction Proofs +-- Output Proofs --- | Witness that a transaction is included in the head of a chain in a +-- | Witness that a transaction output is included in the head of a chain in a -- chainweb. -- -data TransactionProof a = TransactionProof +data TransactionOutputProof a = TransactionOutputProof !ChainId -- ^ the target chain of the proof, i.e the chain which contains -- the root of the proof. - !(MerkleProof a) + !(V1.MerkleProof a) -- ^ the Merkle proof blob, which contains both the proof object and -- the subject. deriving (Show, Eq) -instance ToJSON (TransactionProof SHA512t_256) where - toJSON (TransactionProof cid p) = object $ proofProperties cid p - toEncoding (TransactionProof cid p) = pairs . mconcat $ proofProperties cid p +instance ToJSON (TransactionOutputProof ChainwebMerkleHashAlgorithm) where + toJSON (TransactionOutputProof cid p) = object $ proofProperties cid p + toEncoding (TransactionOutputProof cid p) = pairs . mconcat $ proofProperties cid p {-# INLINE toJSON #-} {-# INLINE toEncoding #-} -instance FromJSON (TransactionProof SHA512t_256) where - parseJSON = parseProof "TransactionProof" TransactionProof +instance FromJSON (TransactionOutputProof ChainwebMerkleHashAlgorithm) where + parseJSON = parseProof "TransactionOutputProof" TransactionOutputProof {-# INLINE parseJSON #-} --- | Getter into the chain id of a 'TransactionProof' +-- | Getter into the chain id of a 'TransactionOutputProof' -- -proofChainId :: Getter (TransactionProof a) ChainId -proofChainId = to (\(TransactionProof cid _) -> cid) +outputProofChainId :: Getter (TransactionOutputProof a) ChainId +outputProofChainId = to (\(TransactionOutputProof cid _) -> cid) -- -------------------------------------------------------------------------- -- --- Output Proofs +-- Fake Event Proof --- | Witness that a transaction output is included in the head of a chain in a --- chainweb. +-- | Fake event proof -- -data TransactionOutputProof a = TransactionOutputProof +data FakeEventProof = FakeEventProof !ChainId -- ^ the target chain of the proof, i.e the chain which contains -- the root of the proof. - !(MerkleProof a) + !Value -- ^ the Merkle proof blob, which contains both the proof object and -- the subject. deriving (Show, Eq) -instance ToJSON (TransactionOutputProof SHA512t_256) where - toJSON (TransactionOutputProof cid p) = object $ proofProperties cid p - toEncoding (TransactionOutputProof cid p) = pairs . mconcat $ proofProperties cid p +instance ToJSON FakeEventProof where + toJSON = object . fakeEventProofProperties + toEncoding = pairs . mconcat . fakeEventProofProperties {-# INLINE toJSON #-} {-# INLINE toEncoding #-} -instance FromJSON (TransactionOutputProof SHA512t_256) where - parseJSON = parseProof "TransactionOutputProof" TransactionOutputProof +instance FromJSON FakeEventProof where + parseJSON = withObject "FakeEventProof" $ \o -> FakeEventProof + <$> o .: "chain" + <*> o .: "subject" {-# INLINE parseJSON #-} --- | Getter into the chain id of a 'TransactionOutputProof' --- -outputProofChainId :: Getter (TransactionOutputProof a) ChainId -outputProofChainId = to (\(TransactionOutputProof cid _) -> cid) +fakeEventProofProperties + :: forall e kv + . KeyValue e kv + => FakeEventProof + -> [kv] +fakeEventProofProperties (FakeEventProof cid v) = + [ "chain" .= cid + , "object" .= obj "SNAKEOIL" + , "subject" .= v + , "algorithm" .= ("SHA512t_256" :: T.Text) + ] + where + obj = encodeB64UrlNoPaddingText diff --git a/src/Chainweb/SPV/Argument.hs b/src/Chainweb/SPV/Argument.hs new file mode 100644 index 0000000000..8505fb910c --- /dev/null +++ b/src/Chainweb/SPV/Argument.hs @@ -0,0 +1,655 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeAbstractions #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -Wno-orphans #-} + +-- | +-- Module: Chainweb.SPV.Argument +-- Copyright: Copyright © 2025 Kadena LLC. +-- License: MIT +-- Maintainer: Lars Kuhtz +-- Stability: experimental +-- +module Chainweb.SPV.Argument +( Argument(..) +, argumentClaim +, SomeArgument(..) +, runArg +, compose +, validateTrieProof +) where + +import Chainweb.BlockHash +import Chainweb.BlockPayloadHash +import Chainweb.Crypto.MerkleLog +import Chainweb.MerkleLogHash +import Chainweb.MerkleUniverse +import Chainweb.Pact.Payload +import Chainweb.PayloadProvider.EVM.Header ({- IsMerkleLogEntry instances -}) +import Chainweb.PayloadProvider.EVM.Receipt qualified as EVM +import Control.Exception +import Control.Monad +import Control.Monad.Catch +import Data.ByteString qualified as B +import Data.Coerce +import Data.Kind +import Data.MerkleLog (MerkleRoot) +import Data.MerkleLog qualified as ML +import Data.MerkleLog.V1 qualified as V1 +import Data.Text qualified as T +import Data.Type.Equality +import Data.Typeable +import Data.Word +import Ethereum.Misc qualified as E +import Ethereum.RLP (getRlpL) +import Ethereum.RLP qualified as E +import Ethereum.Trie qualified as E +import Numeric.Natural + +-- -------------------------------------------------------------------------- -- +-- Alternative Approach + +-- Protocol flow: +-- +-- 1. Event emission [on-chain]: the user creates the event. The event may be the +-- native event format of the payload provider, a custom language extension, +-- or an agreement to write a particular value to the contract store. +-- +-- 2. Proof creation [off-chain]: the user creates a proof (usually through +-- calling an API) that contains the relevant event data along with evidence +-- for its inclusion on the source chain and its provenance. +-- +-- 3. Send redeem transaction [off-chain]: the user sends a transaction that +-- includes the proof to the target chain. +-- +-- 4. Proof verification [on-chain]: the execution environment on the receiving +-- chain verifies the evidence in the proof and extract the relevant message +-- and provenance data. It performance additional checks on that data and, if +-- successful, notifies the receiver contract. +-- +-- 4. Redeem [on-chain]: the receiving contract obtains the notification data. +-- It performs some checks on the data. If the checks succeed it performs the +-- redeem operations. +-- +-- +-- TOPIC FORMAT: +-- +-- 0: event type signature hash (keccak256()) +-- 1: targetChain [uint32, bigendian] +-- 2: target address [address, last 20 bytes] +-- 3: ignored (optional for indexing) +-- +-- LogData: +-- * receiver address B.ByteString (eth address 20 bytes) +-- * amount [uint256] + +-- -------------------------------------------------------------------------- -- +-- +-- Backward compatibility: +-- +-- * Proof format: +-- * Existing proof *must* continue to work during reorg and the transition. +-- * Can we skip proof verification during replay? +-- +-- Before EVM transition: +-- 1. Introduce support for validating new format +-- 2. Enable creation of new format. +-- +-- + +-- -------------------------------------------------------------------------- -- +-- TODO: +-- +-- The types in the Merkle Universe must be available to all payload providers +-- (the alternative would be to define a unique event format across all payload +-- providers and require that all payload providers support direct proofs of +-- those events in their respective payload Merkle tree. +-- +-- For instance the EVM provider could collect events from the EVM and transform +-- those to the common format and add those to a new event tree. +-- +-- We should create a package that collects and reexports all types from the +-- Chainweb Merkle universe. + +-- -------------------------------------------------------------------------- -- + +type ChainwebMerkleLogEntry a = + ( Eq a + , Typeable a + , Show a + , IsMerkleLogEntry ChainwebMerkleHashAlgorithm ChainwebHashTag a + ) + +tagVal' :: forall b . ChainwebMerkleLogEntry b => Word16 +tagVal' = tagVal @ChainwebHashTag @(Tag b) + +-- -------------------------------------------------------------------------- +-- Claims + +data Conjunct a b where + Conjunct + :: (ChainwebMerkleLogEntry a, ChainwebMerkleLogEntry b) + => a + -> b + -> Conjunct a b + +deriving instance (Show a, Show b) => Show (Conjunct a b) +deriving instance (Eq a, Eq b) => Eq (Conjunct a b) + +class InclusionClaim a +instance {-# OVERLAPPABLE #-} (ChainwebMerkleLogEntry a) => InclusionClaim a +instance {-# OVERLAPPING #-} InclusionClaim (Conjunct a b) + +-- -------------------------------------------------------------------------- -- +-- Exceptions + +newtype VerificationException = VerificationException T.Text + deriving (Show, Eq) + +instance Exception VerificationException + +-- -------------------------------------------------------------------------- -- + +-- TODO: replace concrete types by Tags? +-- +-- The types themself are not available to all payload providers, but the tags +-- are. +-- +-- TODO do we need extensible arguments, e.g. as a data family or just class? +-- +-- For now we try to the set of supported Proofs and claim types small and +-- fixed. +-- +-- The claim types are included in the Chainweb core library to which all +-- payload providers have access. Proof verification validates the evidence and +-- also deserializes the claim, which inlcudes verification of the tag. + +-- | Arguments +-- +-- An argument provides evidence for the statement: +-- +-- \(\text{root} \in \text{Chainweb} \rightarrow \text{claim} \in \text{Chainweb}\) +-- +-- where `claim` is a value that is stored on chain and has a type that is a +-- member of the Chainweb Merkle universe. +-- +-- This statement is established by applying the argument to the claim, which +-- may succeed or fail. +-- +data Argument (claim :: Type) (root :: Type) where + Trivial + :: + ( ChainwebMerkleLogEntry a + , Coercible a (MerkleRoot ChainwebMerkleHashAlgorithm) + ) + => a + -> Argument a a + PactLegacyProof + :: V1.MerkleProof ChainwebMerkleHashAlgorithm + -> Argument TransactionOutput BlockHash + HeaderArgument + :: ML.MerkleProof ChainwebMerkleHashAlgorithm + -> Argument BlockHash BlockHash + ParentHeaderArgument + :: ML.MerkleProof ChainwebMerkleHashAlgorithm + -> Argument BlockHash BlockHash + BlockPayloadHashArgument + :: ML.MerkleProof ChainwebMerkleHashAlgorithm + -> Argument BlockPayloadHash BlockHash + PactOutputArgument + :: + ( ChainwebMerkleLogEntry root + , Coercible root (MerkleRoot ChainwebMerkleHashAlgorithm) + ) + => ML.MerkleProof ChainwebMerkleHashAlgorithm + -> Argument TransactionOutput root + EthHeaderArgument + :: + ( ChainwebMerkleLogEntry root + , Coercible root (MerkleRoot ChainwebMerkleHashAlgorithm) + ) + => ML.MerkleProof ChainwebMerkleHashAlgorithm + -> Argument EVM.ReceiptsRoot root + EthReceiptArgument + :: E.Proof + -> Argument EVM.Receipt EVM.ReceiptsRoot + + -- Composed Arguments (used when the underlying proofs can't be composed) + ComposeArgument + :: + ( ChainwebMerkleLogEntry a + , ChainwebMerkleLogEntry claim + , ChainwebMerkleLogEntry root + ) + => Argument claim a + -> Argument a root + -> Argument claim root + + -- Future work: + -- + -- Conjunect a0 a1 is not a MerkleLogEntry. Hence we need create an + -- abstraction that that covers both MerkleLogEntries and Conjunctions of + -- MerkleLogEntries. + -- + -- ComposeArgument2 + -- :: + -- ( ChainwebMerkleLogEntry a0 + -- , ChainwebMerkleLogEntry a1 + -- , ChainwebMerkleLogEntry root + -- , ChainwebMerkleLogEntry claim0 + -- , ChainwebMerkleLogEntry claim1 + -- ) + -- => Argument claim0 a0 + -- -> Argument claim1 a1 + -- -> Argument (Conjunct a0 a1) root + -- -> Argument (Conjunct claim0 claim1) root + +deriving instance (Show claim, Show root) => Show (Argument claim root) + +argumentClaim :: MonadThrow m => Argument claim root -> m claim +argumentClaim (Trivial r) = return r +argumentClaim (PactLegacyProof p) = proofSubject p +argumentClaim (HeaderArgument p) = proofClaim p +argumentClaim (ParentHeaderArgument p) = proofClaim p +argumentClaim (BlockPayloadHashArgument p) = proofClaim p +argumentClaim (PactOutputArgument p) = proofClaim p +argumentClaim (EthHeaderArgument p) = proofClaim p +argumentClaim (EthReceiptArgument p) = case E._proofValue p of + Nothing -> throwM $ VerificationException "Invalid Receipt proof: missing claim" + Just r -> case E.get E.getRlp r of + Left e -> throwM $ VerificationException $ "Invalid receipt: " <> T.pack e + Right r' -> return r' +argumentClaim (ComposeArgument a0 _) = argumentClaim a0 +-- argumentClaim (ComposeArgument2 a0 a1 _) = Conjunct +-- <$> argumentClaim a0 +-- <*> argumentClaim a1 + +-- -------------------------------------------------------------------------- -- +-- Serialization + +data SomeArgument where + SomeArgument + :: forall (claim :: Type) (root :: Type) + . (ChainwebMerkleLogEntry claim, ChainwebMerkleLogEntry root) + => Argument claim root + -> SomeArgument + +instance MerkleHashAlgorithm a => E.RLP (MerkleRoot a) where + putRlp r = E.putRlp $ ML.encodeMerkleRoot r + getRlp = E.label "MerkleRoot " $ do + bs <- E.getRlp @B.ByteString + case ML.decodeMerkleRoot bs of + Left e -> fail $ "Invalid MerkleRoot: " <> show e + Right r -> return r + {-# INLINE putRlp #-} + {-# INLINE getRlp #-} + +instance MerkleHashAlgorithm a => E.RLP (ML.MerkleNodeType a) where + putRlp (ML.TreeNode h) = E.putRlpL + [ E.putRlp (0 :: Word8) + , E.putRlp h + ] + putRlp (ML.InputNode b) = E.putRlpL + [ E.putRlp (1 :: Word8) + , E.putRlp b + ] + getRlp = E.label "MerkleNodeType" $ do + E.getRlp @Word8 >>= \case + 0 -> E.label "TreeNode" (ML.TreeNode <$> E.getRlp) + 1 -> E.label "InputNode" (ML.InputNode <$> E.getRlp) + _ -> fail "invalid MerkleNodeType" + {-# INLINE putRlp #-} + {-# INLINE getRlp #-} + +instance MerkleHashAlgorithm a => E.RLP (V1.MerkleProof a) where + putRlp p = E.putRlpL + [ E.putRlp $ V1._getMerkleProofSubject (V1._merkleProofSubject p) + , E.putRlp $ V1.encodeMerkleProofObject (V1._merkleProofObject p) + ] + getRlp = E.label "V1.MerkleProof" $ V1.MerkleProof + <$> E.label "MerkleProofSubject" (V1.MerkleProofSubject <$> E.getRlp) + <*> E.label "MerkleProofObject" do + bs <- E.getRlp @B.ByteString + case V1.decodeMerkleProofObject bs of + Left e -> fail $ "Invalid MerkleProofObject: " <> show e + Right r -> return r + {-# INLINE putRlp #-} + {-# INLINE getRlp #-} + +instance E.RLP (ML.MerkleProof ChainwebMerkleHashAlgorithm) where + putRlp p = E.putRlpL + [ E.putRlp (ML._merkleProofClaim p) + , E.putRlp (fromIntegral @_ @Natural $ ML._merkleProofTrace p) + , E.putRlp (ML._merkleProofEvidence p) + ] + getRlp = E.label "MerkleProof" $ + ML.MerkleProof + <$> E.label "claim" E.getRlp + <*> E.label "trace" (fromIntegral @Natural <$> E.getRlp) + <*> E.label "evidence" E.getRlp + {-# INLINE putRlp #-} + {-# INLINE getRlp #-} + +instance MerkleHashAlgorithm a => E.RLP (BlockPayloadHash_ a) where + putRlp = E.putRlp . coerce @_ @(MerkleRoot a) + getRlp = E.label "BlockPayloadHash" $ coerce <$> E.getRlp @(MerkleRoot a) + {-# INLINE putRlp #-} + {-# INLINE getRlp #-} + +instance MerkleHashAlgorithm a => E.RLP (BlockHash_ a) where + putRlp = E.putRlp . coerce @_ @(MerkleRoot a) + getRlp = E.label "BlockHash" $ coerce <$> E.getRlp @(MerkleRoot a) + {-# INLINE putRlp #-} + {-# INLINE getRlp #-} + +instance E.RLP SomeArgument where + putRlp (SomeArgument @claim @root arg) = case arg of + (Trivial p) -> go 0 (coerce @_ @(MerkleRoot ChainwebMerkleHashAlgorithm) p) + (PactLegacyProof p) -> go 1 p + (HeaderArgument p) -> go 2 p + (ParentHeaderArgument p) -> go 3 p + (BlockPayloadHashArgument p) -> go 4 p + (PactOutputArgument p) -> go 5 p + (EthHeaderArgument p) -> go 6 p + (EthReceiptArgument p) -> go 7 p + (ComposeArgument a0 a1) -> E.putRlpL + [ E.putRlp (8 :: Word8) + , E.putRlp (SomeArgument a0) + , E.putRlp (SomeArgument a1) + ] + where + go :: E.RLP p => Word8 -> p -> E.Put + go tag p = E.putRlpL + [ E.putRlp (tag :: Word8) + , E.putRlp (tagVal' @claim) + , E.putRlp (tagVal' @root) + , E.putRlp p + ] + + getRlp = E.label "Argument" $ getRlpL $ do + tag <- E.label "Argument Tag" (E.getRlp @Word8) + claim <- E.label "Claim Tag" $ E.getRlp @Word16 + root <- E.label "Root Tag" $ E.getRlp @Word16 + case tag of + 0 -> E.label "Trivial" $ if + | root == tagVal' @BlockPayloadHash -> SomeArgument <$> + enforceType claim root (Trivial @BlockPayloadHash <$> E.getRlp) + | root == tagVal' @BlockHash -> SomeArgument <$> + enforceType claim root (Trivial @BlockHash <$> E.getRlp) + | otherwise -> + fail "invalid root type" + 1 -> E.label "PactLegacyProof" $ SomeArgument <$> + getTagged (PactLegacyProof <$> E.getRlp) + 2 -> E.label "HeaderArgument" $ SomeArgument <$> + getTagged (HeaderArgument <$> E.getRlp) + 3 -> E.label "ParentHeaderArgument" $ SomeArgument <$> + getTagged (ParentHeaderArgument <$> E.getRlp) + 4 -> E.label "BlockPayloadHashArgument" $ SomeArgument <$> + getTagged (BlockPayloadHashArgument <$> E.getRlp) + 5 -> E.label "PactOutputArgument" $ if + | root == tagVal' @BlockPayloadHash -> SomeArgument <$> + enforceType claim root (PactOutputArgument @BlockPayloadHash <$> E.getRlp) + | root == tagVal' @BlockHash -> SomeArgument <$> + enforceType claim root (PactOutputArgument @BlockHash <$> E.getRlp) + | otherwise -> + fail "invalid root type" + 6 -> E.label "EthHeaderArgument" $ if + | root == tagVal' @BlockPayloadHash -> SomeArgument <$> + enforceType claim root (EthHeaderArgument @BlockPayloadHash <$> E.getRlp) + | root == tagVal' @BlockHash -> SomeArgument <$> + enforceType claim root (EthHeaderArgument @BlockHash <$> E.getRlp) + | otherwise -> + fail "invalid root type" + 7 -> E.label "EthReceiptArgument" $ SomeArgument <$> + getTagged (EthReceiptArgument <$> E.getRlp) + 8 -> E.label "ComposeArgument" $ do + SomeArgument @c @a a0 <- E.getRlp + SomeArgument @a' @r a1 <- E.getRlp + arg <- getTagged @c @r $ case (eqT @a @a') of + Just Refl -> return $ ComposeArgument a0 a1 + _ -> fail "invalid compose argument" + return $ SomeArgument arg + _ -> fail "invalid argument type" + where + getTagged + :: forall claim root + . ChainwebMerkleLogEntry claim + => ChainwebMerkleLogEntry root + => E.Get (Argument claim root) + -> E.Get (Argument claim root) + getTagged p = do + claim <- E.label "Claim Tag" $ E.getRlp @Word16 + root <- E.label "Root Tag" $ E.getRlp @Word16 + enforceType claim root p + + enforceType + :: forall claim root + . ChainwebMerkleLogEntry claim + => ChainwebMerkleLogEntry root + => Word16 + -> Word16 + -> E.Get (Argument claim root) + -> E.Get (Argument claim root) + enforceType claim root p = do + unless (claim == tagVal' @claim) (fail "invalid claim type") + unless (root == tagVal' @root) (fail "invalid root type") + p + +-- -------------------------------------------------------------------------- -- +-- | Argument composition. +-- +-- The implementation balances the composition tree to be right associative. +-- This maximizes the composition on the lower level proofs. +-- +-- Nested calls to this can be quadratic in the worst case when associating from +-- the left. So one should avoid that. Instead arguments should be composed from +-- the right. +-- +compose + :: MonadThrow m + => ChainwebMerkleLogEntry a + => ChainwebMerkleLogEntry claim + => ChainwebMerkleLogEntry root + => Argument claim a + -> Argument a root + -> m (Argument claim root) +compose (Trivial _) a = return a -- FXME: check that claims match? +compose a (Trivial _) = return a -- FIXME: check that roots match? +compose (HeaderArgument m0) (HeaderArgument m1) + = HeaderArgument <$> ML.composeProofs m0 m1 +compose (ParentHeaderArgument m0) (HeaderArgument m1) + = ParentHeaderArgument <$> ML.composeProofs m0 m1 +compose (BlockPayloadHashArgument m0) (HeaderArgument m1) + = BlockPayloadHashArgument <$> ML.composeProofs m0 m1 +compose (PactOutputArgument m0) (BlockPayloadHashArgument m1) + = PactOutputArgument <$> ML.composeProofs m0 m1 +compose (PactOutputArgument m0) (ParentHeaderArgument m1) + = PactOutputArgument <$> ML.composeProofs m0 m1 +compose (EthHeaderArgument m0) (BlockPayloadHashArgument m1) + = EthHeaderArgument <$> ML.composeProofs m0 m1 +compose (ComposeArgument a0 a1) b = ComposeArgument a0 <$> compose a1 b +compose a (ComposeArgument b0 b1) = do + -- First compose a and b0. This may result in a ComposeArgument in which + -- case we and up with the previous case. + a' <- compose a b0 + compose a' b1 +compose a b = return (ComposeArgument a b) + + +-- -------------------------------------------------------------------------- -- +-- | Compute the proof root and provide evidence that the proof claim is +-- included in the root of the respective Chainweb Merkle tree. +-- +-- The claim is either a leave and a member of the Chainweb Merkle universe or +-- it is an inner node of the Chainweb Merkle tree. In case of the latter no +-- futher evidence about its type is included. +-- +-- IMPORTANT NOTE: +-- +-- If the result is an inner tree node (e.g. a 'BlockHash' or a +-- 'BlockPayloadHash') type is not checked and purely informational. There is no +-- evidence for it being correct. (we could add that evidence in the future, but +-- right now it is not provided.) +-- +-- It is an important security invariant of Chainweb that the preimage of each +-- root is completely guarded by types values in the Chainweb Merkle universe. +-- +runArg + :: MonadThrow m + => Argument claim root + -> m root +runArg (Trivial r) = return r +runArg (PactLegacyProof evidence) = do + r <- V1.runMerkleProof evidence + return (coerce r) +runArg (PactOutputArgument evidence) = do + return $ coerce $ ML.runProof evidence +runArg (ParentHeaderArgument evidence) = do + return $ coerce $ ML.runProof evidence +runArg (HeaderArgument evidence) = do + return $ coerce $ ML.runProof evidence +runArg (BlockPayloadHashArgument evidence) = do + return $ coerce $ ML.runProof evidence +runArg (EthReceiptArgument evidence) = do + -- We do not need to check the proof key because all values under this + -- root are receipts. However, we must make sure that the root has the + -- correct type, which is done either when checked against an oracle or when + -- it is used as claim in another proof. + r <- EVM.ReceiptsRoot <$> validateTrieProof evidence + return r +runArg (EthHeaderArgument evidence) = do + return $ coerce $ ML.runProof evidence +runArg (ComposeArgument a0 a1) = do + r0 <- runArg a0 + c1 <- argumentClaim a1 + when (r0 /= c1) $ throwM $ VerificationException "Composition failed" + runArg a1 + +-- runProof (Trivial r) = do +-- return r +-- runProof (ComposeArgument2 a0 a1 a3) (Conjunct c0 c1) = do +-- r0 <- runProof a0 c0 +-- r1 <- runProof a1 c1 +-- runProof a3 (Conjunct r0 r1) + +-- -------------------------------------------------------------------------- -- +-- | Ethereum Trie Proofs +-- + +validateTrieProof + :: MonadThrow m + => E.Proof + -> m E.Keccak256Hash +validateTrieProof p = case E.validateProof p of + Left _ -> + throwM (VerificationException "Malformed Proof") + Right False -> + throwM (VerificationException "Invalid Proof") + Right True -> + return $ E._proofRoot p + +-- -------------------------------------------------------------------------- -- +-- ATTIC + +-- -------------------------------------------------------------------------- -- +-- | Pact Output Proof + +-- instance E.RLP (ML.MerkleProof a) where +-- putRlp p = E.putRlp p +-- getRlp = E.label "MerkleProof" $ MerkleProof <$> E.getRlp +-- {-# INLINE putRlp #-} +-- {-# INLINE getRlp #-} + +-- createMerkleProof +-- :: [(B.ByteString, B.ByteString)] +-- -- ^ Key-value pairs that are stroed in the Trie +-- -> B.ByteString +-- -- ^ the key of the proofs +-- -> ML.MerkleProof a +-- createMerkleProof ps key = TrieProof +-- { _trieProofKey = E._proofKey p +-- , _trieProofNodes = E._proofNodes p +-- , _trieProofRoot = E._proofRoot p +-- } +-- where +-- p = E.createProof ps key + +-- -------------------------------------------------------------------------- -- +-- NEW SPV + +-- proofProperties +-- :: forall e kv +-- . KeyValue e kv +-- => ChainId +-- -> MerkleProof Sha2_512_256 +-- -> [kv] +-- proofProperties cid p = +-- [ "chain" .= cid +-- , "event" .= JsonProofSubject (_getMerkleProofSubject $ _merkleProofSubject p) +-- , "algorithm" .= ("Sha2_512_256" :: T.Text) +-- ] +-- where +-- obj = encodeB64UrlNoPaddingText . encodeMerkleProofObject +-- +-- data XChainMessage = XChainMessage +-- { _xChainMsgTargetChain :: !ChainId +-- , _xChainMsgReceiverAccount :: !B.ByteString +-- , _xChainMsgAmount :: !Stu +-- } +-- +-- data XChainEvent = XChainEvent +-- { _xChainSourceChain :: !ChainId +-- -- ^ not in the ETH log +-- , _xChainSourceContract :: !B.ByteString +-- -- ^ Added by the system +-- , _xChainSourceBlockHeight :: !Word64 +-- -- Not in EHT Log +-- , _xChainSourceTxIdx :: !Word64 +-- -- ^ this is not in the event it is provided by the user when they select +-- -- the event +-- , _xChainSourceEventIdx :: !Word64 +-- -- ^ this is not authenticated by the proof. It is provided by the user and +-- -- instructs the precompile to limit the proof to just this one event. +-- , _xChainMessage :: !XChainMessage +-- -- ^ The actual user payload. Cf. below for an example for simple ERC-20 +-- -- cross chain transfers. +-- } + + +-- data PayloadProof a = PayloadProof +-- { _payloadProofRootType :: !MerkleRootType +-- -- ^ The type of the Merle root. +-- , _payloadProofBlob :: !(MerkleProof a) +-- -- ^ The Merkle proof blob which coaintains both, the proof object and +-- -- the proof subject. +-- } deriving (Show, Eq, Generic, NFData) +-- +-- payloadProofProperties +-- :: forall a e kv +-- . MerkleHashAlgorithmName a +-- => KeyValue e kv +-- => PayloadProof a +-- -> [kv] +-- payloadProofProperties p = +-- [ "rootType" .= _payloadProofRootType p +-- , "object" .= (obj . _merkleProofObject) blob +-- , "subject" .= JsonProofSubject (_getMerkleProofSubject $ _merkleProofSubject blob) +-- , "algorithm" .= merkleHashAlgorithmName @a +-- ] +-- where +-- blob = _payloadProofBlob p +-- obj = encodeB64UrlNoPaddingText . encodeMerkleProofObject +-- {-# INLINE payloadProofProperties #-} diff --git a/src/Chainweb/SPV/CreateProof.hs b/src/Chainweb/SPV/CreateProof.hs index b954fdf633..b91d1e0439 100644 --- a/src/Chainweb/SPV/CreateProof.hs +++ b/src/Chainweb/SPV/CreateProof.hs @@ -1,5 +1,6 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ImportQualifiedPost #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -16,32 +17,17 @@ -- Construction of Merkle proofs in the Chainweb Merkle tree. -- module Chainweb.SPV.CreateProof -( createTransactionProof -, createTransactionProof_ -, createTransactionProof' -, createTransactionOutputProof -, createTransactionOutputProof_ -, createTransactionOutputProof' +( createTransactionOutputProof +, createSmallTransactionOutputProof ) where import Control.Applicative import Control.Lens hiding ((.=)) import Control.Monad import Control.Monad.Catch -import Control.Monad.Trans.Maybe - -import Crypto.Hash.Algorithms - -import qualified Data.ByteString as B -import qualified Data.List.NonEmpty as N -import Data.MerkleLog - -import GHC.Stack - -import Prelude hiding (lookup) - --- internal modules - +import Data.List.NonEmpty qualified as N +import Data.MerkleLog.Common +import Data.MerkleLog.V1 qualified as V1 import Chainweb.BlockHash import Chainweb.BlockHeader import Chainweb.BlockHeight @@ -50,119 +36,57 @@ import Chainweb.Crypto.MerkleLog import Chainweb.CutDB import Chainweb.Graph import Chainweb.MerkleUniverse -import Chainweb.Payload -import Chainweb.Payload.PayloadStore +import Chainweb.Parent +import Chainweb.PayloadProvider import Chainweb.SPV import Chainweb.TreeDB import Chainweb.Utils import Chainweb.Version import Chainweb.WebBlockHeaderDB - -import Chainweb.Storage.Table +import GHC.Stack +import Prelude hiding (lookup) -- -------------------------------------------------------------------------- -- --- Create Transaction Proof - --- | Creates a witness that a transaction is included in a chain of a chainweb. +-- FIXME -- --- The proof is of minimal size. It only witnesses inclusion in the chain for --- the header on the target chain that this closest to the source header. +-- With the introduction of non-uniform payload providers the architecture for +-- proof creation and verification must change. -- --- The size of the result is linear in the distance of the source and target --- chain in the chain graph plus the logarithm of the size of the source block. +-- CutDb will not include access to payloads. The logic for creating payload +-- proofs will be implemented in the payload provider. -- -createTransactionProof - :: HasCallStack - => CanReadablePayloadCas tbl - => CutDb tbl - -- ^ Block Header Database - -> ChainId - -- ^ target chain. The proof asserts that the subject is included in - -- this chain - -> ChainId - -- ^ source chain. This the chain of the subject - -> BlockHeight - -- ^ The block height of the transaction - -> Int - -- ^ The index of the transaction in the block - -> IO (TransactionProof SHA512t_256) -createTransactionProof cutDb = - createTransactionProof_ - (view cutDbWebBlockHeaderDb cutDb) - (view cutDbPayloadDb cutDb) - --- | Version without CutDb dependency +-- We have two options: -- -createTransactionProof_ - :: HasCallStack - => CanReadablePayloadCas tbl - => WebBlockHeaderDb - -> PayloadDb tbl - -> ChainId - -- ^ target chain. The proof asserts that the subject is included in - -- this chain - -> ChainId - -- ^ source chain. This the chain of the subject - -> BlockHeight - -- ^ The block height of the transaction - -> Int - -- ^ The index of the transaction in the block - -> IO (TransactionProof SHA512t_256) -createTransactionProof_ headerDb payloadDb tcid scid bh i = do - trgHeader <- minimumTrgHeader headerDb tcid scid bh - TransactionProof tcid - <$> createPayloadProof_ transactionProofPrefix headerDb payloadDb tcid scid bh i trgHeader - - --- | Creates a witness that a transaction is included in a chain of a chainweb. +-- 1. Make proof creation a consensus API. -- --- The target header is the current maximum block header in the target chain. --- Note, that this header may not yet be confirmed and may thus be volatile. +-- Pros: Consensus calls into the payload provider. The payload provider does +-- not need to initiate calls to the consensus API. -- -createTransactionProof' - :: HasCallStack - => CanReadablePayloadCas tbl - => CutDb tbl - -- ^ Block Header Database - -> ChainId - -- ^ target chain. The proof asserts that the subject is included in - -- this chain - -> ChainId - -- ^ source chain. This the chain of the subject - -> BlockHeight - -- ^ The block height of the transaction - -> Int - -- ^ The index of the transaction in the block - -> IO (TransactionProof SHA512t_256) -createTransactionProof' cutDb tcid scid bh i = TransactionProof tcid - <$> createPayloadProof transactionProofPrefix cutDb tcid scid bh i - -transactionProofPrefix - :: CanReadablePayloadCas tbl - => Int - -> BlockHeight - -> PayloadDb tbl - -> BlockPayload - -> IO PayloadProofPrefix -transactionProofPrefix i bh db payload = do - -- 1. TX proof - let - lookupOld = tableLookup - (_oldTransactionDbBlockTransactionsTbl $ _transactionDb db) - (_blockPayloadTransactionsHash payload) - lookupNew = tableLookup - (_newTransactionDbBlockTransactionsTbl $ _transactionDb db) - (bh, _blockPayloadTransactionsHash payload) - Just txs <- runMaybeT $ MaybeT lookupNew <|> MaybeT lookupOld - -- TODO: use the transaction tree cache - let (!subj, pos, t) = bodyTree @_ @ChainwebHashTag txs i - -- FIXME use log - let !tree = (pos, t) - -- we blindly trust the ix - - -- 2. Payload proof - let !proof = tree N.:| [headerTree_ @BlockTransactionsHash payload] - return (subj, proof) +-- Cons: The frontend API for proof creation is current exposed in the +-- payload provider API. The mapping from consensus to providers is on to +-- many and a consensus component is not generally aware of all payload +-- providers. This requires handling the case when a proof is requested for +-- an unsupported chain. +-- +-- 2. Keep proof creation as payload provider API. +-- +-- Pros: The API remains where it currently lives. Users don't need to +-- communicate directly with the consensus API. The is a consensus component +-- for each payload provider. Hence, requests can always be supported. +-- +-- Cons: Payload providers need to call into the consensus API. For that +-- providers need to be aware of the conensus component. +-- +-- The second solution seems more natural, but that relies on the fact that it +-- would generally seem more natural if payload providers depended/used +-- consensus. However, this would require that consensus could accept blocks +-- without validating the payload, which would require that either payload +-- validation is not relevant for consensus or block producers provided succinct +-- proofs for validation. Since this is not the case this argument becomes +-- irrelevant. +-- +-- The first solution is in alignment with the overall architecture of the +-- conensus protocol. -- -------------------------------------------------------------------------- -- -- Creates Output Proof @@ -177,8 +101,7 @@ transactionProofPrefix i bh db payload = do -- createTransactionOutputProof :: HasCallStack - => CanReadablePayloadCas tbl - => CutDb tbl + => CutDb l -- ^ Block Header Database -> ChainId -- ^ target chain. The proof asserts that the subject is included in @@ -189,21 +112,28 @@ createTransactionOutputProof -- ^ The block height of the transaction -> Int -- ^ The index of the transaction in the block - -> IO (TransactionOutputProof SHA512t_256) -createTransactionOutputProof cutDb = - createTransactionOutputProof_ - (view cutDbWebBlockHeaderDb cutDb) - (view cutDbPayloadDb cutDb) - + -> IO (TransactionOutputProof ChainwebMerkleHashAlgorithm) +createTransactionOutputProof _cutDb _tcid _scid = + error "Chainweb.SPV.CreateProof.createTransactionOutputProof: FIXME: not yet implemented" +-- createSmallTransactionOutputProof +-- (view cutDbWebBlockHeaderDb cutDb) +-- (view cutDbPayloadProviders cutDb ^?! ixg scid) +-- tcid +-- scid -- | Version without CutDb dependency -- -createTransactionOutputProof_ +-- The target header is the current minimum block header in the target chain. +-- Note, that this header may not yet be confirmed and may thus be volatile. +-- +createSmallTransactionOutputProof :: HasCallStack - => CanReadablePayloadCas tbl + => HasVersion + => PayloadProvider p => WebBlockHeaderDb - -> PayloadDb tbl -- ^ Block Header Database + -> p + -- ^ paylaod provider -> ChainId -- ^ target chain. The proof asserts that the subject is included in -- this chain @@ -213,66 +143,54 @@ createTransactionOutputProof_ -- ^ The block height of the transaction -> Int -- ^ The index of the transaction in the block - -> IO (TransactionOutputProof SHA512t_256) -createTransactionOutputProof_ headerDb payloadDb tcid scid bh i = do + -> IO (TransactionOutputProof ChainwebMerkleHashAlgorithm) +createSmallTransactionOutputProof headerDb provider tcid scid bh i = do trgHeader <- minimumTrgHeader headerDb tcid scid bh TransactionOutputProof tcid - <$> createPayloadProof_ outputProofPrefix headerDb payloadDb tcid scid bh i trgHeader - - --- | Creates a witness that a transaction is included in a chain of a chainweb. --- --- The target header is the current maximum block header in the target chain. --- Note, that this header may not yet be confirmed and may thus be volatile. --- -createTransactionOutputProof' - :: HasCallStack - => CanReadablePayloadCas tbl - => CutDb tbl - -- ^ Block Header Database - -> ChainId - -- ^ target chain. The proof asserts that the subject is included in - -- this chain - -> ChainId - -- ^ source chain. This the chain of the subject - -> BlockHeight - -- ^ The block height of the transaction - -> Int - -- ^ The index of the transaction in the block - -> IO (TransactionOutputProof SHA512t_256) -createTransactionOutputProof' cutDb tcid scid bh i - = TransactionOutputProof tcid - <$> createPayloadProof outputProofPrefix cutDb tcid scid bh i + <$> createPayloadProof_ getProofPrefix headerDb tcid scid bh i trgHeader + where + getProofPrefix = outputProofPrefix provider outputProofPrefix - :: CanReadablePayloadCas tbl - => Int + :: PayloadProvider p + => p + -> Int -- ^ transaction index -> BlockHeight - -> PayloadDb tbl - -> BlockPayload + -> BlockPayloadHash -> IO PayloadProofPrefix -outputProofPrefix i bh db payload = do - -- 1. TX proof - let - lookupOld = tableLookup - (_oldBlockOutputsTbl blockOutputs) - (_blockPayloadOutputsHash payload) - lookupNew = tableLookup - (_newBlockOutputsTbl blockOutputs) - (bh, _blockPayloadOutputsHash payload) - Just outs <- runMaybeT $ MaybeT lookupNew <|> MaybeT lookupOld - -- TODO: use the transaction tree cache - let (!subj, pos, t) = bodyTree @_ @ChainwebHashTag outs i - -- FIXME use log - let tree = (pos, t) - -- we blindly trust the ix - - -- 2. Payload proof - let !proof = tree N.:| [headerTree_ @BlockOutputsHash payload] - return (subj, proof) - where - blockOutputs = _payloadCacheBlockOutputs $ _payloadCache db +outputProofPrefix _provider _i _bh _ph = do + error "Chainweb.SPV.CreateProof.outputProofPrefix: FIXME: not yet implemented" +-- where +-- +-- -- 1. TX proof +-- let +-- lookupOld = tableLookup +-- (_oldBlockOutputsTbl blockOutputs) +-- (_blockPayloadOutputsHash payload) +-- lookupNew = tableLookup +-- (_newBlockOutputsTbl blockOutputs) +-- (bh, _blockPayloadOutputsHash payload) +-- Just outs <- runMaybeT $ MaybeT lookupNew <|> MaybeT lookupOld +-- -- TODO: use the transaction tree cache +-- let (!subj, pos, t) = bodyTree @_ @ChainwebHashTag outs i +-- -- FIXME use log +-- let tree = (pos, t) +-- -- we blindly trust the ix +-- +-- -- 2. Payload proof +-- let !proof = tree N.:| [headerTree_ @BlockOutputsHash payload] +-- return (subj, proof) +-- where +-- blockOutputs = _payloadCacheBlockOutputs $ _payloadCache db +-- +-- payload = do +-- Just pd <- lookupPayloadDataWithHeight payloadDb (Just $ view blockHeight txHeader) (view blockPayloadHash txHeader) +-- return $ BlockPayload +-- { _blockPayloadTransactionsHash = view payloadDataTransactionsHash pd +-- , _blockPayloadOutputsHash = view payloadDataOutputsHash pd +-- , _blockPayloadPayloadHash = view payloadDataPayloadHash pd +-- } -- -------------------------------------------------------------------------- -- -- Internal Proof Creation @@ -281,43 +199,18 @@ outputProofPrefix i bh db payload = do -- of merkle trees for the final proof. -- type PayloadProofPrefix = - (MerkleNodeType SHA512t_256 B.ByteString, N.NonEmpty (Int, MerkleTree SHA512t_256)) - --- | Creates a witness that a transaction is included in a chain of a chainweb. --- -createPayloadProof - :: HasCallStack - => CanReadablePayloadCas tbl - => (Int -> BlockHeight -> PayloadDb tbl -> BlockPayload -> IO PayloadProofPrefix) - -> CutDb tbl - -- ^ Block Header Database - -> ChainId - -- ^ target chain. The proof asserts that the subject is included in - -- this chain - -> ChainId - -- ^ source chain. This the chain of the subject - -> BlockHeight - -- ^ The block height of the transaction - -> Int - -- ^ The index of the transaction in the block - -> IO (MerkleProof SHA512t_256) -createPayloadProof getPrefix cutDb tcid scid txHeight txIx = do - trgHeadHeader <- maxEntry trgChain - createPayloadProof_ getPrefix headerDb payloadDb tcid scid txHeight txIx trgHeadHeader - where - headerDb = view cutDbWebBlockHeaderDb cutDb - payloadDb = view cutDbPayloadDb cutDb - trgChain = headerDb ^?! ixg tcid + ( MerkleNodeType ChainwebMerkleHashAlgorithm + , N.NonEmpty (Int, V1.MerkleTree ChainwebMerkleHashAlgorithm) + ) -- | Creates a witness that a transaction is included in a chain of a chainweb -- at the given target header. -- createPayloadProof_ :: HasCallStack - => CanReadablePayloadCas tbl - => (Int -> BlockHeight -> PayloadDb tbl -> BlockPayload -> IO PayloadProofPrefix) + => HasVersion + => (Int -> BlockHeight -> BlockPayloadHash -> IO PayloadProofPrefix) -> WebBlockHeaderDb - -> PayloadDb tbl -> ChainId -- ^ target chain. The proof asserts that the subject is included in -- this chain @@ -329,8 +222,8 @@ createPayloadProof_ -- ^ The index of the transaction in the block -> BlockHeader -- ^ the target header of the proof - -> IO (MerkleProof SHA512t_256) -createPayloadProof_ getPrefix headerDb payloadDb tcid scid txHeight txIx trgHeader = do + -> IO (V1.MerkleProof ChainwebMerkleHashAlgorithm) +createPayloadProof_ getPrefix headerDb tcid scid txHeight txIx trgHeader = do -- -- 1. TransactionTree -- 2. BlockPayload @@ -381,23 +274,18 @@ createPayloadProof_ getPrefix headerDb payloadDb tcid scid txHeight txIx trgHead , _spvExceptionTargetHeight = view blockHeight trgHeader } - Just pd <- lookupPayloadDataWithHeight payloadDb (Just $ view blockHeight txHeader) (view blockPayloadHash txHeader) - let payload = BlockPayload - { _blockPayloadTransactionsHash = view payloadDataTransactionsHash pd - , _blockPayloadOutputsHash = view payloadDataOutputsHash pd - , _blockPayloadPayloadHash = view payloadDataPayloadHash pd - } + let payloadHash = (view blockPayloadHash txHeader) -- ----------------------------- -- -- 1. Payload Proofs (TXs and Payload) - (subj, prefix) <- getPrefix txIx txHeight payloadDb payload + (subj, prefix) <- getPrefix txIx txHeight payloadHash -- ----------------------------- -- -- 2. BlockHeader proof -- - unless (view blockPayloadHash txHeader == _blockPayloadPayloadHash payload) + unless (view blockPayloadHash txHeader == payloadHash) $ throwM $ SpvExceptionInconsistentPayloadData { _spvExceptionMsg = "The stored payload hash doesn't match the the db index" , _spvExceptionMsgPayloadHash = view blockPayloadHash txHeader @@ -407,7 +295,7 @@ createPayloadProof_ getPrefix headerDb payloadDb tcid scid txHeight txIx trgHead -- 3. BlockHeader Chain Proof -- - let chainTrees = headerTree_ @BlockHash <$> chain + let chainTrees = headerTree_ @(Parent BlockHash) <$> chain -- 4. Cross Chain Proof -- @@ -415,7 +303,7 @@ createPayloadProof_ getPrefix headerDb payloadDb tcid scid txHeight txIx trgHead -- Put proofs together -- - merkleProof_ subj $ append prefix + V1.merkleTreeProof_ subj $ append prefix $ blockHeaderTree : chainTrees <> crossTrees @@ -433,7 +321,8 @@ createPayloadProof_ getPrefix headerDb payloadDb tcid scid txHeight txIx trgHead -- Returns 'Nothing' if @i >= view blockHeight h@. -- crumbsOnChain - :: WebBlockHeaderDb + :: HasVersion + => WebBlockHeaderDb -> BlockHeader -> BlockHeight -> IO (Maybe (N.NonEmpty BlockHeader)) @@ -444,7 +333,7 @@ crumbsOnChain db trgHeader srcHeight go cur acc | srcHeight == view blockHeight cur = return $! (cur N.:| acc) | otherwise = do - p <- lookupParentHeader db cur + Parent p <- lookupParentHeader db cur go p (cur : acc) -- | Create a path of bread crumbs from the source chain id to the target header @@ -453,16 +342,17 @@ crumbsOnChain db trgHeader srcHeight -- Returns 'Nothing' if no such path exists. -- crumbsToChain - :: WebBlockHeaderDb + :: HasVersion + => WebBlockHeaderDb -> ChainId -> BlockHeader -> IO (Maybe (BlockHeader, [(Int, BlockHeader)])) -- ^ bread crumbs that lead from to source Chain to targetHeader crumbsToChain db srcCid trgHeader - | (int (view blockHeight trgHeader) + 1) < length path = return Nothing + | int (view blockHeight trgHeader) + 1 < length path = return Nothing | otherwise = Just <$> go trgHeader path [] where - graph = chainGraphAt db (view blockHeight trgHeader) + graph = chainGraphAt (view blockHeight trgHeader) path = shortestPath (_chainId trgHeader) srcCid graph go @@ -472,7 +362,7 @@ crumbsToChain db srcCid trgHeader -> IO (BlockHeader, [(Int, BlockHeader)]) go !cur [] !acc = return (cur, acc) go !cur ((!h):t) !acc = do - adjpHdr <- lookupAdjacentParentHeader db cur h + Parent adjpHdr <- lookupAdjacentParentHeader db cur h unless (view blockHeight adjpHdr >= 0) $ throwM $ InternalInvariantViolation $ "crumbsToChain: Encountered Genesis block. Chain can't be reached for SPV proof." @@ -481,7 +371,8 @@ crumbsToChain db srcCid trgHeader go adjpHdr t ((adjIdx, cur) : acc) minimumTrgHeader - :: WebBlockHeaderDb + :: HasVersion + => WebBlockHeaderDb -> ChainId -- ^ target chain. The proof asserts that the subject is included in -- this chain @@ -510,7 +401,7 @@ minimumTrgHeader headerDb tcid scid bh = do -- This assumes that graph changes are at least graph-diameter -- blocks appart. - srcGraph = chainGraphAt headerDb bh + srcGraph = chainGraphAt bh srcDistance = length $ shortestPath tcid scid srcGraph - trgGraph = chainGraphAt headerDb (bh + int srcDistance) + trgGraph = chainGraphAt (bh + int srcDistance) trgDistance = length $ shortestPath tcid scid trgGraph diff --git a/src/Chainweb/SPV/EventProof.hs b/src/Chainweb/SPV/EventProof.hs index a8320b7d66..1f1c6b0cb1 100644 --- a/src/Chainweb/SPV/EventProof.hs +++ b/src/Chainweb/SPV/EventProof.hs @@ -12,6 +12,8 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE UndecidableInstances #-} -- | -- Module: Chainweb.SPV.EventProof @@ -104,17 +106,15 @@ import Control.Lens (view) import Control.Monad import Control.Monad.Catch -import Crypto.Hash.Algorithms - import Data.Aeson -import qualified Data.ByteArray as BA import qualified Data.ByteString as B import qualified Data.ByteString.Base16 as B16 import qualified Data.ByteString.Short as BS import Data.Decimal import Data.Foldable +import Data.Hash.Keccak (Keccak256) import Data.Hashable -import Data.MerkleLog hiding (Actual, Expected) +import qualified Data.MerkleLog.V1 as V1 import qualified Data.Text as T import qualified Data.Text.Encoding as T import qualified Data.Vector as V @@ -124,10 +124,8 @@ import GHC.Generics import Numeric.Natural -import Pact.Types.Command -import Pact.Types.PactValue -import Pact.Types.Pretty -import Pact.Types.Runtime hiding (fromText) +import Pact.Core.Command.Types +import Pact.Core.PactValue -- internal modules @@ -136,8 +134,8 @@ import Chainweb.BlockHeader import Chainweb.BlockHeaderDB import Chainweb.MerkleLogHash import Chainweb.MerkleUniverse -import Chainweb.Payload -import Chainweb.Payload.PayloadStore +import Chainweb.Pact.Payload +import Chainweb.Pact.Payload.PayloadStore import Chainweb.SPV import Chainweb.SPV.PayloadProof import Chainweb.TreeDB hiding (entries, root) @@ -145,6 +143,13 @@ import Chainweb.Utils import Chainweb.Utils.Serialization import Chainweb.Storage.Table +import Pact.Core.Names +import Pact.Core.Capabilities +import Pact.Core.Hash +import Pact.Core.ModRefs +import Pact.Core.Errors +import Pact.Core.Pretty (renderCompactText) +import Chainweb.Version (HasVersion) -- -------------------------------------------------------------------------- -- -- Pact Encoding Exceptions @@ -266,15 +271,15 @@ int256Hex x@(Int256 i) -- -------------------------------------------------------------------------- -- -- Pact Event Encoding -encodePactEvent :: PactEvent -> Put +encodePactEvent :: PactEvent PactValue -> Put encodePactEvent e = do - encodeString $ _eventName e - encodeModuleName $ _eventModule e - encodeHash $ _mhHash $ _eventModuleHash e - encodeArray (_eventParams e) encodeParam + encodeString $ _peName e + encodeModuleName $ _peModule e + encodeHash $ _mhHash $ _peModuleHash e + encodeArray (_peArgs e) encodeParam encodeModuleName :: ModuleName -> Put -encodeModuleName = encodeString . asString +encodeModuleName = encodeString . renderModuleName -- | This throws a pure exception of type 'PactEventEncodingException', if the -- input bytestring is too long. @@ -305,8 +310,7 @@ encodeHash :: Hash -> Put encodeHash = encodeBytes . BS.fromShort . unHash encodeModRef :: ModRef -> Put -encodeModRef n@(ModRef _ (Just _) _) = throw $ UnsupportedModRefWithSpec (renderCompactText n) -encodeModRef n@(ModRef _ _ (Info (Just _))) = throw $ UnsupportedModRefWithInfo (renderCompactText n) +encodeModRef n@(ModRef _ s) | not (null s) = throw $ UnsupportedModRefWithSpec (renderCompactText n) encodeModRef n = encodeString $ renderCompactText n -- | This throws a pure exception of type 'PactEventEncodingException', if the @@ -322,9 +326,9 @@ encodeArray a f | otherwise = putWord32le (int $ length a) >> traverse_ f a encodeParam :: PactValue -> Put -encodeParam (PLiteral (LString t)) = putWord8 0x0 >> encodeString t -encodeParam (PLiteral (LInteger i)) = putWord8 0x1 >> encodeInteger i -encodeParam (PLiteral (LDecimal i)) = putWord8 0x2 >> encodeDecimal i +encodeParam (PString t) = putWord8 0x0 >> encodeString t +encodeParam (PInteger i) = putWord8 0x1 >> encodeInteger i +encodeParam (PDecimal i) = putWord8 0x2 >> encodeDecimal i encodeParam (PModRef n) = putWord8 0x3 >> encodeModRef n encodeParam e = throw $ UnsupportedPactValueException e @@ -337,18 +341,17 @@ expect c = label "expect" $ do unless (c == c') $ fail $ "decodeOutputEvents: failed to decode, expected " <> show c <> " but got " <> show c' -decodePactEvent :: Get PactEvent +decodePactEvent :: Get (PactEvent PactValue) decodePactEvent = label "decodeEvent" $ do name <- decodeString m <- decodeModuleName mh <- ModuleHash <$> decodeHash params <- decodeArray decodeParam return $ PactEvent - { _eventModule = m - , _eventName = name - , _eventModuleHash = mh - , _eventParams = params - } + name + params + m + mh decodeArray :: Get a -> Get [a] decodeArray f = label "decodeArray" $ do @@ -380,23 +383,22 @@ decodeDecimal = label "decodeDecimal" $ integerToDecimal <$> decodeInteger decodeParam :: Get PactValue decodeParam = label "decodeParam" $ getWord8 >>= \case - 0x0 -> label "LString" $ PLiteral . LString <$> decodeString - 0x1 -> label "LInteger" $ PLiteral . LInteger <$> decodeInteger - 0x2 -> label "LDecimal" $ PLiteral . LDecimal <$> decodeDecimal + 0x0 -> label "LString" $ PString <$> decodeString + 0x1 -> label "LInteger" $ PInteger <$> decodeInteger + 0x2 -> label "LDecimal" $ PDecimal <$> decodeDecimal 0x3 -> label "PModRef" $ PModRef <$> decodeModRef e -> fail $ "decodeParam: unexpected parameter with type tag " <> show e decodeModuleName :: Get ModuleName decodeModuleName = label "decodeModuleName" $ decodeString >>= \t -> case parseModuleName t of - Left e -> fail e - Right m -> return m + Nothing -> fail "invalid module name" + Just m -> return m decodeModRef :: Get ModRef decodeModRef = label "ModRef" $ ModRef <$> decodeModuleName - <*> pure Nothing - <*> pure (Info Nothing) + <*> pure mempty -- -------------------------------------------------------------------------- -- -- Block Events Hash @@ -409,14 +411,10 @@ type BlockEventsHash = BlockEventsHash_ ChainwebMerkleHashAlgorithm newtype BlockEventsHash_ a = BlockEventsHash (MerkleLogHash a) deriving (Show, Eq, Ord, Generic) deriving anyclass (NFData) - deriving newtype (BA.ByteArrayAccess) - deriving newtype (Hashable, ToJSON, FromJSON) + deriving newtype (Hashable, ToJSON, FromJSON, HasTextRepresentation) + deriving (IsMerkleLogEntry a ChainwebHashTag) via MerkleRootLogEntry a 'BlockEventsHashTag -instance MerkleHashAlgorithm a => HasTextRepresentation (BlockEventsHash_ a) where - toText (BlockEventsHash h) = toText h - fromText t = BlockEventsHash <$> fromText t - -encodeBlockEventsHash :: BlockEventsHash_ a -> Put +encodeBlockEventsHash :: MerkleHashAlgorithm a => BlockEventsHash_ a -> Put encodeBlockEventsHash (BlockEventsHash w) = encodeMerkleLogHash w decodeBlockEventsHash @@ -424,13 +422,6 @@ decodeBlockEventsHash => Get (BlockEventsHash_ a) decodeBlockEventsHash = BlockEventsHash <$!> decodeMerkleLogHash -instance MerkleHashAlgorithm a => IsMerkleLogEntry a ChainwebHashTag (BlockEventsHash_ a) where - type Tag (BlockEventsHash_ a) = 'BlockEventsHashTag - toMerkleNode = encodeMerkleTreeNode - fromMerkleNode = decodeMerkleTreeNode - {-# INLINE toMerkleNode #-} - {-# INLINE fromMerkleNode #-} - -- -------------------------------------------------------------------------- -- -- Output Events @@ -444,7 +435,7 @@ instance MerkleHashAlgorithm a => IsMerkleLogEntry a ChainwebHashTag (BlockEvent -- data OutputEvents = OutputEvents { _outputEventsRequestKey :: !RequestKey - , _outputEventsEvents :: !(V.Vector PactEvent) + , _outputEventsEvents :: !(V.Vector (PactEvent PactValue)) } deriving (Show, Eq, Generic) @@ -517,7 +508,7 @@ getBlockEvents -> m (BlockEvents_ b) getBlockEvents p = fmap blockEvents $ forM (_payloadWithOutputsTransactions p) $ \(_, o) -> do - r <- decodeStrictOrThrow @_ @(CommandResult Hash) $ _transactionOutputBytes o + r <- decodeStrictOrThrow @_ @(CommandResult Hash PactOnChainError) $ _transactionOutputBytes o return $ OutputEvents (_crReqKey r) (V.fromList (_crEvents r)) -- -------------------------------------------------------------------------- -- @@ -530,7 +521,7 @@ eventsMerkleProof => PayloadWithOutputs_ h -> RequestKey -- ^ RequestKey of the transaction - -> m (MerkleProof a) + -> m (V1.MerkleProof a) eventsMerkleProof p reqKey = do events <- getBlockEvents @_ @a p @@ -541,7 +532,7 @@ eventsMerkleProof p reqKey = do -- Create proof from outputs tree and payload tree let (!subj, !pos, !t) = bodyTree events i - merkleProof subj pos t + V1.merkleTreeProof subj pos t createEventsProof_ :: forall a @@ -568,7 +559,7 @@ createEventsProofKeccak256 :: PayloadWithOutputs -> RequestKey -- ^ RequestKey of the transaction - -> IO (PayloadProof Keccak_256) + -> IO (PayloadProof Keccak256) createEventsProofKeccak256 = createEventsProof_ -- -------------------------------------------------------------------------- -- @@ -577,6 +568,7 @@ createEventsProofKeccak256 = createEventsProof_ createEventsProofDb_ :: forall a tbl . MerkleHashAlgorithm a + => HasVersion => CanReadablePayloadCas tbl => BlockHeaderDb -> PayloadDb tbl @@ -607,6 +599,7 @@ createEventsProofDb_ headerDb payloadDb d h reqKey = do createEventsProofDb :: CanReadablePayloadCas tbl + => HasVersion => BlockHeaderDb -> PayloadDb tbl -> Natural @@ -621,6 +614,7 @@ createEventsProofDb = createEventsProofDb_ createEventsProofDbKeccak256 :: CanReadablePayloadCas tbl + => HasVersion => BlockHeaderDb -> PayloadDb tbl -> Natural @@ -630,7 +624,7 @@ createEventsProofDbKeccak256 -- ^ the target header of the proof -> RequestKey -- ^ RequestKey of the transaction - -> IO (PayloadProof Keccak_256) + -> IO (PayloadProof Keccak256) createEventsProofDbKeccak256 = createEventsProofDb_ -- -------------------------------------------------------------------------- -- diff --git a/src/Chainweb/SPV/OutputProof.hs b/src/Chainweb/SPV/OutputProof.hs index adb6794501..6716edac25 100644 --- a/src/Chainweb/SPV/OutputProof.hs +++ b/src/Chainweb/SPV/OutputProof.hs @@ -4,6 +4,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} +{-# LANGUAGE ImportQualifiedPost #-} -- | -- Module: Chainweb.SPV.OutputProof @@ -36,18 +37,17 @@ import Control.Lens (view) import Control.Monad import Control.Monad.Catch -import Crypto.Hash.Algorithms - import qualified Data.List.NonEmpty as N -import Data.MerkleLog hiding (Expected, Actual) +import Data.MerkleLog.V1 qualified as V1 import qualified Data.Vector as V +import Data.Hash.Keccak (Keccak256) import GHC.Stack import Numeric.Natural -import Pact.Types.Command -import Pact.Types.Runtime hiding (ChainId) +import Pact.Core.Command.Types +import Pact.Core.Errors -- internal modules @@ -56,14 +56,15 @@ import Chainweb.BlockHeader import Chainweb.BlockHeaderDB import Chainweb.Crypto.MerkleLog import Chainweb.MerkleUniverse -import Chainweb.Payload -import Chainweb.Payload.PayloadStore +import Chainweb.Pact.Payload +import Chainweb.Pact.Payload.PayloadStore import Chainweb.SPV import Chainweb.SPV.PayloadProof import Chainweb.TreeDB import Chainweb.Utils import Chainweb.Storage.Table +import Chainweb.Version (HasVersion) -- -------------------------------------------------------------------------- -- -- Utils @@ -79,7 +80,7 @@ findTxIdx findTxIdx p reqKey = do -- get request keys reqKeys <- forM (_payloadWithOutputsTransactions p) $ \(_, o) -> do - result <- decodeStrictOrThrow @_ @(CommandResult Hash) $ _transactionOutputBytes o + result <- decodeStrictOrThrow @_ @(CommandResult Hash PactOnChainError) $ _transactionOutputBytes o return (_crReqKey result) -- find tx index case V.findIndex (== reqKey) reqKeys of @@ -100,7 +101,7 @@ getRequestKey getRequestKey p txIdx = case _payloadWithOutputsTransactions p V.!? txIdx of Nothing -> throwM $ TxIndexOutOfBoundsException txIdx Just (_, o) -> _crReqKey - <$> decodeStrictOrThrow @_ @(CommandResult Hash) (_transactionOutputBytes o) + <$> decodeStrictOrThrow @_ @(CommandResult Hash PactOnChainError) (_transactionOutputBytes o) -- -------------------------------------------------------------------------- -- -- Transaction Output Proofs By Index @@ -116,11 +117,11 @@ outputMerkleProofByIdx => PayloadWithOutputs_ h -> Int -- ^ The index of the transaction in the block - -> m (MerkleProof a) + -> m (V1.MerkleProof a) outputMerkleProofByIdx p txIdx = do -- Create proof from outputs tree and payload tree let (!subj, pos, t) = bodyTree outs txIdx - merkleProof_ subj + V1.merkleTreeProof_ subj $ (pos, t) N.:| [headerTree_ @(BlockOutputsHash_ a) payload] where @@ -150,7 +151,7 @@ outputMerkleProof => PayloadWithOutputs_ h -> RequestKey -- ^ The index of the transaction in the block - -> m (MerkleProof a) + -> m (V1.MerkleProof a) outputMerkleProof p = findTxIdx p >=> outputMerkleProofByIdx p -- | Creates a witness that a transaction is included in a chain of a chainweb @@ -189,7 +190,7 @@ createOutputProofKeccak256 :: PayloadWithOutputs -> RequestKey -- ^ The index of the transaction in the block - -> IO (PayloadProof Keccak_256) + -> IO (PayloadProof Keccak256) createOutputProofKeccak256 = createOutputProof_ -- | Creates a witness that a transaction is included in a chain of a chainweb @@ -199,6 +200,7 @@ createOutputProofDb_ :: forall a tbl . MerkleHashAlgorithm a => CanReadablePayloadCas tbl + => HasVersion => BlockHeaderDb -> PayloadDb tbl -> Natural @@ -231,6 +233,7 @@ createOutputProofDb_ headerDb payloadDb d h reqKey = do -- createOutputProofDb :: CanReadablePayloadCas tbl + => HasVersion => BlockHeaderDb -> PayloadDb tbl -> Natural @@ -248,6 +251,7 @@ createOutputProofDb = createOutputProofDb_ -- createOutputProofDbKeccak256 :: CanReadablePayloadCas tbl + => HasVersion => BlockHeaderDb -> PayloadDb tbl -> Natural @@ -257,7 +261,7 @@ createOutputProofDbKeccak256 -- ^ the target header of the proof -> RequestKey -- ^ RequestKey of the transaction - -> IO (PayloadProof Keccak_256) + -> IO (PayloadProof Keccak256) createOutputProofDbKeccak256 = createOutputProofDb_ -- -------------------------------------------------------------------------- -- diff --git a/src/Chainweb/SPV/PayloadProof.hs b/src/Chainweb/SPV/PayloadProof.hs index 23853a7700..58850ff041 100644 --- a/src/Chainweb/SPV/PayloadProof.hs +++ b/src/Chainweb/SPV/PayloadProof.hs @@ -16,6 +16,7 @@ {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE ImportQualifiedPost #-} -- | -- Module: Chainweb.SPV.PayloadProof @@ -42,16 +43,16 @@ import Control.DeepSeq import Control.Monad import Control.Monad.Catch -import Crypto.Hash.Algorithms +import Data.Hash.Keccak import Data.Aeson -import qualified Data.ByteString as B -import Data.MerkleLog -import qualified Data.Text as T +import Data.MerkleLog (MerkleNodeType(..)) +import Data.MerkleLog.V1 qualified as V1 +import Data.Text qualified as T import GHC.Generics -import Pact.Types.Command +import Pact.Core.Command.Types -- internal modules @@ -72,17 +73,21 @@ instance Exception RequestKeyNotFoundException -- | Internal helper type of holding the ToJSON dictionary for the -- proof subject encoding. -- -newtype JsonProofSubject a = JsonProofSubject (MerkleNodeType a B.ByteString) +newtype JsonProofSubject a = JsonProofSubject (MerkleNodeType a) -jsonProofSubjectProperties :: KeyValue e kv => JsonProofSubject a -> [kv] +jsonProofSubjectProperties + :: MerkleHashAlgorithm a + => KeyValue e kv + => JsonProofSubject a + -> [kv] jsonProofSubjectProperties (JsonProofSubject (TreeNode h)) = - [ "tree" .= encodeB64UrlNoPaddingText (encodeMerkleRoot h) + [ "tree" .= encodeB64UrlNoPaddingText (V1.encodeMerkleRoot h) ] jsonProofSubjectProperties (JsonProofSubject (InputNode bytes)) = [ "input" .= encodeB64UrlNoPaddingText bytes ] -instance ToJSON (JsonProofSubject a) where +instance MerkleHashAlgorithm a => ToJSON (JsonProofSubject a) where toJSON = object . jsonProofSubjectProperties toEncoding = pairs . mconcat . jsonProofSubjectProperties {-# INLINE toJSON #-} @@ -103,7 +108,7 @@ instance ToJSON (JsonProofSubject a) where data PayloadProof a = PayloadProof { _payloadProofRootType :: !MerkleRootType -- ^ The type of the Merle root. - , _payloadProofBlob :: !(MerkleProof a) + , _payloadProofBlob :: !(V1.MerkleProof a) -- ^ The Merkle proof blob which coaintains both, the proof object and -- the proof subject. } deriving (Show, Eq, Generic, NFData) @@ -111,21 +116,22 @@ data PayloadProof a = PayloadProof payloadProofProperties :: forall a e kv . MerkleHashAlgorithmName a + => MerkleHashAlgorithm a => KeyValue e kv => PayloadProof a -> [kv] payloadProofProperties p = [ "rootType" .= _payloadProofRootType p - , "object" .= (obj . _merkleProofObject) blob - , "subject" .= JsonProofSubject (_getMerkleProofSubject $ _merkleProofSubject blob) + , "object" .= (obj . V1._merkleProofObject) blob + , "subject" .= JsonProofSubject (V1._getMerkleProofSubject $ V1._merkleProofSubject blob) , "algorithm" .= merkleHashAlgorithmName @a ] where blob = _payloadProofBlob p - obj = encodeB64UrlNoPaddingText . encodeMerkleProofObject + obj = encodeB64UrlNoPaddingText . V1.encodeMerkleProofObject {-# INLINE payloadProofProperties #-} -instance MerkleHashAlgorithmName a => ToJSON (PayloadProof a) where +instance (MerkleHashAlgorithm a, MerkleHashAlgorithmName a) => ToJSON (PayloadProof a) where toJSON = object . payloadProofProperties toEncoding = pairs . mconcat . payloadProofProperties {-# INLINE toJSON #-} @@ -137,21 +143,21 @@ instance (MerkleHashAlgorithm a, MerkleHashAlgorithmName a) => FromJSON (Payload <*> o .: "rootType" <*> parse o where - parse o = MerkleProof + parse o = V1.MerkleProof <$> (parseSubject =<< o .: "subject") <*> (parseObject =<< o .: "object") - parseSubject = withObject "ProofSubject" $ \o -> MerkleProofSubject + parseSubject = withObject "ProofSubject" $ \o -> V1.MerkleProofSubject <$> ((o .: "tree" >>= parseTreeNode) <|> (o .: "input" >>= parseInputNode)) parseTreeNode = withText "TreeNode" - $ fmap TreeNode . parseBinary decodeMerkleRoot + $ fmap TreeNode . parseBinary V1.decodeMerkleRoot parseInputNode = withText "InputNode" $ fmap InputNode . parseBinary pure parseObject = withText "ProofObject" - $ parseBinary decodeMerkleProofObject + $ parseBinary V1.decodeMerkleProofObject assertJSON e a = unless (e == a) $ fail $ "expected " <> sshow e <> ", got " <> sshow a @@ -179,8 +185,8 @@ instance FromJSON SomePayloadProof where pick a | a == merkleHashAlgorithmName @ChainwebMerkleHashAlgorithm = SomePayloadProof @ChainwebMerkleHashAlgorithm <$> parseJSON v - | a == merkleHashAlgorithmName @Keccak_256 = - SomePayloadProof @Keccak_256 <$> parseJSON v + | a == merkleHashAlgorithmName @Keccak256 = + SomePayloadProof @Keccak256 <$> parseJSON v | otherwise = fail $ "unsupported Merkle hash algorithm: " <> T.unpack a {-# INLINE parseJSON #-} @@ -205,8 +211,8 @@ runPayloadProof => IsMerkleLogEntry a ChainwebHashTag b => PayloadProof a -> m (MerkleRootType, MerkleLogHash a, b) -runPayloadProof p = (_payloadProofRootType p, root,) <$> proofSubject blob +runPayloadProof p = do + root <- MerkleLogHash <$> V1.runMerkleProof blob + (_payloadProofRootType p, root,) <$> proofSubject blob where - root = MerkleLogHash $ runMerkleProof blob blob = _payloadProofBlob p - diff --git a/src/Chainweb/SPV/RestAPI.hs b/src/Chainweb/SPV/RestAPI.hs index dc7d742890..69c16f9f10 100644 --- a/src/Chainweb/SPV/RestAPI.hs +++ b/src/Chainweb/SPV/RestAPI.hs @@ -15,14 +15,14 @@ -- module Chainweb.SPV.RestAPI ( --- * Transaction Proof API - SpvGetTransactionProofApi -, spvGetTransactionProofApi - -- * Transaction Output Proof API -, SpvGetTransactionOutputProofApi + SpvGetTransactionOutputProofApi , spvGetTransactionOutputProofApi +-- * Event Proof API +, SpvGetEventProofApi +, spvGetEventProofApi + -- * SPV API , SpvApi , spvApi @@ -32,8 +32,6 @@ module Chainweb.SPV.RestAPI , someSpvApis ) where -import Crypto.Hash.Algorithms - import Data.Proxy import Numeric.Natural @@ -48,48 +46,52 @@ import Chainweb.RestAPI.Orphans () import Chainweb.RestAPI.Utils import Chainweb.SPV import Chainweb.Version +import Chainweb.MerkleUniverse -- -------------------------------------------------------------------------- -- --- GET Transaction Proof +-- GET Transaction Output Proof -type SpvGetTransactionProofApi_ +type SpvGetTransactionOutputProofApi_ = "spv" :> "chain" :> Capture "spvChain" ChainId :> "height" :> Capture "spvHeight" BlockHeight - :> "transaction" :> Capture "spvTransactionIndex" Natural - :> Get '[JSON] (TransactionProof SHA512t_256) + :> "output" :> Capture "spvTransactionOutputIndex" Natural + :> Get '[JSON] (TransactionOutputProof ChainwebMerkleHashAlgorithm) -type SpvGetTransactionProofApi (v :: ChainwebVersionT) (c :: ChainIdT) - = 'ChainwebEndpoint v :> ChainEndpoint c :> SpvGetTransactionProofApi_ +type SpvGetTransactionOutputProofApi (v :: ChainwebVersionT) (c :: ChainIdT) + = 'ChainwebEndpoint v :> ChainEndpoint c :> SpvGetTransactionOutputProofApi_ -spvGetTransactionProofApi +spvGetTransactionOutputProofApi :: forall (v :: ChainwebVersionT) (c :: ChainIdT) - . Proxy (SpvGetTransactionProofApi v c) -spvGetTransactionProofApi = Proxy + . Proxy (SpvGetTransactionOutputProofApi v c) +spvGetTransactionOutputProofApi = Proxy -- -------------------------------------------------------------------------- -- --- GET Transaction Output Proof +-- GET Event Output Proof -type SpvGetTransactionOutputProofApi_ +type SpvGetEventProofApi_ = "spv" :> "chain" :> Capture "spvChain" ChainId :> "height" :> Capture "spvHeight" BlockHeight - :> "output" :> Capture "spvTransactionOutputIndex" Natural - :> Get '[JSON] (TransactionOutputProof SHA512t_256) + :> "transaction" :> Capture "spvTransactionactionIndex" Natural + :> "event" :> Capture "spvEventIndex" Natural + :> Get '[JSON] FakeEventProof -type SpvGetTransactionOutputProofApi (v :: ChainwebVersionT) (c :: ChainIdT) - = 'ChainwebEndpoint v :> ChainEndpoint c :> SpvGetTransactionOutputProofApi_ +type SpvGetEventProofApi (v :: ChainwebVersionT) (c :: ChainIdT) + = 'ChainwebEndpoint v :> ChainEndpoint c :> SpvGetEventProofApi_ -spvGetTransactionOutputProofApi +spvGetEventProofApi :: forall (v :: ChainwebVersionT) (c :: ChainIdT) - . Proxy (SpvGetTransactionOutputProofApi v c) -spvGetTransactionOutputProofApi = Proxy + . Proxy (SpvGetEventProofApi v c) +spvGetEventProofApi = Proxy -- -------------------------------------------------------------------------- -- -- SPV API type SpvApi v c - = SpvGetTransactionProofApi v c :<|> SpvGetTransactionOutputProofApi v c + = SpvGetEventProofApi v c + -- :<|>SpvGetTransactionProofApi v c + -- :<|> SpvGetTransactionOutputProofApi v c spvApi :: forall (v :: ChainwebVersionT) (c :: ChainIdT) . Proxy (SpvApi v c) spvApi = Proxy diff --git a/src/Chainweb/SPV/RestAPI/Client.hs b/src/Chainweb/SPV/RestAPI/Client.hs index 53a2a132e9..81fcc2e28c 100644 --- a/src/Chainweb/SPV/RestAPI/Client.hs +++ b/src/Chainweb/SPV/RestAPI/Client.hs @@ -15,14 +15,11 @@ -- Client implementation of the SPV REST API -- module Chainweb.SPV.RestAPI.Client -( spvGetTransactionProofClient -, spvGetTransactionOutputProofClient +( spvGetTransactionOutputProofClient ) where import Control.Monad.Identity -import Crypto.Hash.Algorithms - import Data.Proxy import Numeric.Natural @@ -37,45 +34,7 @@ import Chainweb.RestAPI.Orphans () import Chainweb.SPV import Chainweb.SPV.RestAPI import Chainweb.Version - --- -------------------------------------------------------------------------- -- --- SPV Transaction Proof Client - -spvGetTransactionProofClient_ - :: forall (v :: ChainwebVersionT) (c :: ChainIdT) - . KnownChainwebVersionSymbol v - => KnownChainIdSymbol c - => ChainId - -- ^ the source chain of the proof. This is the chain where the proof - -- subject, the transaction for which inclusion is proven, is located. - -> BlockHeight - -- ^ the block height of the proof subject, the transaction for which - -- inclusion is proven. - -> Natural - -- ^ the index of the proof subject, the transaction for which inclusion - -- is proven. - -> ClientM (TransactionProof SHA512t_256) -spvGetTransactionProofClient_ = client (spvGetTransactionProofApi @v @c) - -spvGetTransactionProofClient - :: ChainwebVersion - -> ChainId - -- ^ the target chain of the proof. This is the chain for which - -- inclusion is proved. - -> ChainId - -- ^ the source chain of the proof. This is the chain where the proof - -- subject, the transaction for which inclusion is proven, is located. - -> BlockHeight - -- ^ the block height of the proof subject, the transaction for which - -- inclusion is proven. - -> Natural - -- ^ the index of the proof subject, the transaction for which inclusion - -- is proven. - -> ClientM (TransactionProof SHA512t_256) -spvGetTransactionProofClient v tcid scid h i = runIdentity $ do - SomeChainwebVersionT (_ :: Proxy v) <- return $ someChainwebVersionVal v - SomeChainIdT (_ :: Proxy c) <- return $ someChainIdVal tcid - return $ spvGetTransactionProofClient_ @v @c scid h i +import Chainweb.MerkleUniverse -- -------------------------------------------------------------------------- -- -- SPV Transaction Output Proof Client @@ -94,12 +53,12 @@ spvGetTransactionOutputProofClient_ -> Natural -- ^ the index of the proof subject, the transaction output for which -- inclusion is proven. - -> ClientM (TransactionOutputProof SHA512t_256) + -> ClientM (TransactionOutputProof ChainwebMerkleHashAlgorithm) spvGetTransactionOutputProofClient_ = client (spvGetTransactionOutputProofApi @v @c) spvGetTransactionOutputProofClient - :: ChainwebVersion - -> ChainId + :: HasVersion + => ChainId -- ^ the target chain of the proof. This is the chain for which inclusion -- is proved. -> ChainId @@ -112,8 +71,8 @@ spvGetTransactionOutputProofClient -> Natural -- ^ the index of the proof subject, the transaction output for which -- inclusion is proven. - -> ClientM (TransactionOutputProof SHA512t_256) -spvGetTransactionOutputProofClient v tcid scid h i = runIdentity $ do - SomeChainwebVersionT (_ :: Proxy v) <- return $ someChainwebVersionVal v + -> ClientM (TransactionOutputProof ChainwebMerkleHashAlgorithm) +spvGetTransactionOutputProofClient tcid scid h i = runIdentity $ do + SomeChainwebVersionT (_ :: Proxy v) <- return $ someChainwebVersionVal SomeChainIdT (_ :: Proxy c) <- return $ someChainIdVal tcid return $ spvGetTransactionOutputProofClient_ @v @c scid h i diff --git a/src/Chainweb/SPV/RestAPI/Server.hs b/src/Chainweb/SPV/RestAPI/Server.hs index 9bd9c59244..501680c06a 100644 --- a/src/Chainweb/SPV/RestAPI/Server.hs +++ b/src/Chainweb/SPV/RestAPI/Server.hs @@ -4,6 +4,8 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE LambdaCase #-} -- | -- Module: Chainweb.SPV.RestAPI.Server @@ -15,8 +17,7 @@ -- Server implementation of the SPV REST API -- module Chainweb.SPV.RestAPI.Server -( spvGetTransactionProofHandler -, spvGetTransactionOutputProofHandler +( spvGetTransactionOutputProofHandler , spvServer , spvApp , spvApiLayout @@ -24,61 +25,65 @@ module Chainweb.SPV.RestAPI.Server , someSpvServers ) where +import Control.Lens ((^?!)) import Control.Monad.IO.Class - -import Crypto.Hash.Algorithms - +import Control.Exception.Safe (try, Exception(..)) import Data.Foldable -import qualified Data.Text.IO as T - -import Numeric.Natural - -import Servant - --- internal modules - import Chainweb.BlockHeight import Chainweb.ChainId import Chainweb.CutDB -import Chainweb.Payload.PayloadStore +import Chainweb.PayloadProvider import Chainweb.RestAPI.Utils import Chainweb.SPV import Chainweb.SPV.CreateProof import Chainweb.SPV.RestAPI import Chainweb.Utils import Chainweb.Version - +import Control.Lens (view) import Data.Singletons +import Data.Text.IO qualified as T +import Numeric.Natural +import Servant +import qualified Data.ByteString.Lazy.Char8 as BL8 +import Chainweb.MerkleUniverse -- -------------------------------------------------------------------------- -- --- SPV Transaction Proof Handler +-- SPV Transaction Output Proof Handler -spvGetTransactionProofHandler - :: CanReadablePayloadCas tbl - => CutDb tbl +spvGetTransactionOutputProofHandler + :: HasVersion + => CutDb l -> ChainId - -- ^ the target chain of the proof. This is the chain for which - -- inclusion is proved. + -- ^ the target chain of the proof. This is the chain for which inclusion + -- is proved. -> ChainId -- ^ the source chain of the proof. This is the chain where the proof - -- subject, the transaction for which inclusion is proven, is located. + -- subject, the transaction output for which inclusion is proven, is + -- located. -> BlockHeight - -- ^ the block height of the proof subject, the transaction for which - -- inclusion is proven. + -- ^ the block height of the proof subject, the transaction output for + -- which inclusion is proven. -> Natural - -- ^ the index of the proof subject, the transaction for which inclusion - -- is proven. - -> Handler (TransactionProof SHA512t_256) -spvGetTransactionProofHandler db tcid scid bh i = - liftIO $ createTransactionProof db tcid scid bh (int i) + -- ^ the index of the proof subject, the transaction output for which + -- inclusion is proven. + -> Handler (TransactionOutputProof ChainwebMerkleHashAlgorithm) +spvGetTransactionOutputProofHandler db tcid scid bh i = + liftIO $ createTransactionOutputProof db tcid scid bh (int i) -- FIXME: add proper error handling -- -------------------------------------------------------------------------- -- --- SPV Transaction Output Proof Handler +-- SPV Event Output Proof Handler -spvGetTransactionOutputProofHandler - :: CanReadablePayloadCas tbl - => CutDb tbl +-- | TODO: we are probably missusing http status codes here. All +-- PayloadSPvExceptions represent Application level protocol failures and not +-- HTTP failures. +-- +-- On the other hand, adding another level of failure reporting might be +-- overkill. +-- +spvGetEventProofHandler + :: HasVersion + => CutDb l -> ChainId -- ^ the target chain of the proof. This is the chain for which inclusion -- is proved. @@ -92,23 +97,54 @@ spvGetTransactionOutputProofHandler -> Natural -- ^ the index of the proof subject, the transaction output for which -- inclusion is proven. - -> Handler (TransactionOutputProof SHA512t_256) -spvGetTransactionOutputProofHandler db tcid scid bh i = - liftIO $ createTransactionOutputProof db tcid scid bh (int i) - -- FIXME: add proper error handling + -> Natural + -- ^ The event index in the transaction + -> Handler FakeEventProof +spvGetEventProofHandler db tcid scid bh i e = do + try getProof >>= \case + Left err -> do + let msg = BL8.pack (displayException err) + throwError $ case err of + InvalidBlockHeight {} -> err404 { errBody = msg } + InvalidTransactionIndex {} -> err404 { errBody = msg } + InvalidEventIndex {} -> err404 { errBody = msg } + UnsupportedEventType {} -> err422 { errBody = msg } + InvalidEvent {} -> err422 { errBody = msg } + -- or err400? + ProofPending {} -> err404 { errBody = msg } + Right v -> + return $ FakeEventProof tcid v + where + getProof = case providers ^?! atChain scid of + ConfiguredPayloadProvider p -> do + -- trgHeader <- minimumTrgHeader headerDb tcid scid bh + -- TODO: check through block height whether a proof can possibly + -- already by available before we do any expensive computations. + (SpvProof v) <- liftIO $ eventProof p xevent + return v + DisabledPayloadProvider -> + throwError err404 { errBody = BL8.pack "disabled payload provider on chain" } + + providers = view cutDbPayloadProviders db + xevent = XEventId + { _xEventBlockHeight = bh + , _xEventTransactionIndex = int i + , _xEventEventIndex = int e + } -- -------------------------------------------------------------------------- -- -- SPV API Server spvServer - :: forall tbl v (c :: ChainIdT) - . CanReadablePayloadCas tbl - => KnownChainIdSymbol c - => CutDbT tbl v + :: forall v (c :: ChainIdT) l + . KnownChainIdSymbol c + => HasVersion + => CutDbT l v -> Server (SpvApi v c) spvServer (CutDbT db) - = spvGetTransactionProofHandler db tcid - :<|> spvGetTransactionOutputProofHandler db tcid + = spvGetEventProofHandler db tcid + -- = spvGetTransactionProofHandler db tcid + -- :<|> spvGetTransactionOutputProofHandler db tcid where tcid = fromSing (sing :: Sing c) @@ -116,40 +152,39 @@ spvServer (CutDbT db) -- Application for a single Chain spvApp - :: forall tbl v c - . CanReadablePayloadCas tbl - => KnownChainwebVersionSymbol v + :: forall v c l + . KnownChainwebVersionSymbol v + => HasVersion => KnownChainIdSymbol c - => CutDbT tbl v + => CutDbT l v -> Application -spvApp db = serve (Proxy @(SpvApi v c)) (spvServer @tbl @v @c db) +spvApp db = serve (Proxy @(SpvApi v c)) (spvServer @v @c db) spvApiLayout - :: forall tbl v c + :: forall v c l . KnownChainwebVersionSymbol v => KnownChainIdSymbol c - => CutDbT tbl v + => CutDbT l v -> IO () spvApiLayout _ = T.putStrLn $ layout (Proxy @(SpvApi v c)) someSpvServer - :: forall tbl c - . CanReadablePayloadCas tbl - => KnownChainIdSymbol c - => SomeCutDb tbl + :: forall c + . KnownChainIdSymbol c + => HasVersion + => SomeCutDb -> SomeServer -someSpvServer (SomeCutDb (db :: CutDbT tbl v)) - = SomeServer (Proxy @(SpvApi v c)) (spvServer @tbl @v @c db) +someSpvServer (SomeCutDb (db :: CutDbT l v)) + = SomeServer (Proxy @(SpvApi v c)) (spvServer @v @c db) -- -------------------------------------------------------------------------- -- -- Multichain Server someSpvServers - :: CanReadablePayloadCas tbl - => ChainwebVersion - -> CutDb tbl + :: HasVersion + => CutDb l -> SomeServer -someSpvServers v db = mconcat $ flip fmap cids $ \(FromSingChainId (SChainId :: Sing c)) -> - someSpvServer @_ @c (someCutDbVal v db) +someSpvServers db = mconcat $ flip fmap cids $ \(FromSingChainId (SChainId :: Sing c)) -> + someSpvServer @c (someCutDbVal db) where - cids = toList $ chainIds db + cids = toList chainIds diff --git a/src/Chainweb/SPV/VerifyProof.hs b/src/Chainweb/SPV/VerifyProof.hs index a1ec1443bf..da7e78ff7c 100644 --- a/src/Chainweb/SPV/VerifyProof.hs +++ b/src/Chainweb/SPV/VerifyProof.hs @@ -1,7 +1,7 @@ {-# LANGUAGE ImportQualifiedPost #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE OverloadedRecordDot #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} -- | -- Module: Chainweb.SPV.VerifyProof @@ -13,93 +13,44 @@ -- Verification of Merkle proofs in the Chainweb Merkle tree. -- module Chainweb.SPV.VerifyProof -( - -- * Transaction Proofs - runTransactionProof - , verifyTransactionProof - - -- * Transaction Output Proofs - , runTransactionOutputProof - , verifyTransactionOutputProof +( runTransactionOutputProof +, checkProofAndExtractOutput ) where -import Chainweb.BlockHash -import Chainweb.BlockHeader (blockHeight) -import Chainweb.BlockHeight (BlockHeight) -import Chainweb.ChainId (ChainId) -import Chainweb.ChainId (_chainId) -import Chainweb.Crypto.MerkleLog -import Chainweb.MerkleLogHash -import Chainweb.Payload -import Chainweb.SPV -import Chainweb.BlockHeaderDB.HeaderOracle (HeaderOracle) -import Chainweb.BlockHeaderDB.HeaderOracle qualified as Oracle -import Chainweb.Utils -import Chainweb.Version (ChainwebVersion, _chainwebVersion) -import Chainweb.Version.Guards qualified as CW -import Control.Lens (view) import Control.Monad.Catch -import Crypto.Hash.Algorithms -import Data.MerkleLog +import Control.Monad.Except +import Control.Monad.IO.Class import Data.Text (Text) -import Prelude hiding (lookup) --- -------------------------------------------------------------------------- -- --- Transaction Proofs +import Data.MerkleLog.V1 qualified as V1 --- | Runs a transaction proof. Returns the block hash on the target chain for --- which inclusion is proven. --- -runTransactionProof :: TransactionProof SHA512t_256 -> BlockHash -runTransactionProof (TransactionProof _ p) = BlockHash $ MerkleLogHash $ runMerkleProof p +-- internal modules --- | Verifies the proof against the current state of consensus. The result --- confirms that the subject of the proof occurs in the history of the winning --- fork of the target chain. --- -verifyTransactionProof - :: HeaderOracle - -> TransactionProof SHA512t_256 - -> IO Transaction -verifyTransactionProof oracle proof@(TransactionProof _cid p) = do - let h = runTransactionProof proof - whenM ((== Oracle.OutOfBounds) <$> Oracle.query oracle h) $ do - let u = Oracle.upperBound oracle - forkedError (_chainwebVersion u) (_chainId u) (view blockHeight u) - proofSubject p +import Chainweb.BlockHash +import Chainweb.Crypto.MerkleLog (proofSubject) +import Chainweb.MerkleLogHash +import Chainweb.MerkleUniverse +import Chainweb.Pact.Payload +import Chainweb.SPV +import Chainweb.Pact.Backend.Types (HeaderOracle (..)) +import Chainweb.Parent +import Chainweb.Utils (unlessM) -- -------------------------------------------------------------------------- -- --- Output Proofs - --- | Runs a transaction output proof. Returns the block hash on the target chain for --- which inclusion is proven. --- -runTransactionOutputProof :: TransactionOutputProof SHA512t_256 -> BlockHash -runTransactionOutputProof (TransactionOutputProof _ p) = BlockHash $ MerkleLogHash $ runMerkleProof p --- | Verifies the proof for the given block hash. The result confirms that the --- subject of the proof occurs in the history of the target chain before the --- given block hash. --- --- Throws 'TreeDbKeyNotFound' if the given block hash doesn't exist on target --- the chain or when the given BlockHeaderDb is not for the target chain. +-- | Runs a transaction Proof. Returns the block hash on the target chain for +-- which inclusion is proven. -- -verifyTransactionOutputProof - :: HeaderOracle - -> TransactionOutputProof SHA512t_256 - -> IO TransactionOutput -verifyTransactionOutputProof oracle proof@(TransactionOutputProof _cid p) = do - let h = runTransactionOutputProof proof - whenM ((== Oracle.OutOfBounds) <$> Oracle.query oracle h) $ do - let u = Oracle.upperBound oracle - forkedError (_chainwebVersion u) (_chainId u) (view blockHeight u) +runTransactionOutputProof + :: MonadThrow m + => TransactionOutputProof ChainwebMerkleHashAlgorithm + -> m BlockHash +runTransactionOutputProof (TransactionOutputProof _ p) + = BlockHash . MerkleLogHash <$> V1.runMerkleProof p + +checkProofAndExtractOutput :: HeaderOracle -> TransactionOutputProof ChainwebMerkleHashAlgorithm -> ExceptT Text IO TransactionOutput +checkProofAndExtractOutput oracle proof@(TransactionOutputProof _cid p) = do + h <- runTransactionOutputProof proof + unlessM (liftIO $ oracle.consult (Parent h)) $ throwError + "spv verification failed: target header is not in the chain" proofSubject p - -forkedError :: ChainwebVersion -> ChainId -> BlockHeight -> IO a -forkedError v cid h = throwM $ SpvExceptionVerificationFailed $ if CW.chainweb231Pact v cid h then errMsgPost231 else errMsgPre231 - where - errMsgPre231 :: Text - errMsgPre231 = "target header is not in the chain" - - errMsgPost231 :: Text - errMsgPost231 = "target header is not in the chain or is out of bounds" diff --git a/src/Chainweb/Scheduler.hs b/src/Chainweb/Scheduler.hs new file mode 100644 index 0000000000..9d5e4f87a0 --- /dev/null +++ b/src/Chainweb/Scheduler.hs @@ -0,0 +1,190 @@ +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE OverloadedStrings #-} + +-- | +-- Module: Chainweb.Scheduler +-- Copyright: Copyright © 2018 Kadena LLC. +-- License: MIT +-- Stability: experimental +-- +-- A small scheduler for cron-ish tasks that runs jobs on a bounded thread +-- pool. +-- +-- Each task is a recurring action with a name and an interval. A task +-- occupies a worker thread only for a single run of its action: after each +-- run the task is requeued for its next interval. Synchronous exceptions in +-- the action are logged and the task keeps its schedule (mirroring +-- 'Chainweb.Utils.runForever'); asynchronous exceptions propagate and stop +-- the worker. +-- +-- Tasks are kept in a time-priority queue: workers always pick the task that +-- is due next, and a worker that is waiting for a future task wakes up +-- immediately when an earlier task is submitted. +-- +module Chainweb.Scheduler +( +-- * Scheduler + Scheduler +, withScheduler +, schedule +, scheduleEvery + +-- * Task +, Task(..) +, seconds +, minutes +) where + +import Control.Concurrent.Async +import Control.Concurrent.STM +import Control.Monad (forever) +import Control.Monad.IO.Class (liftIO) +import Control.Monad.Trans.Resource (ResourceT, allocate) + +import Data.Map.Strict (Map) +import Data.Map.Strict qualified as M +import Data.Time.Clock.POSIX (getPOSIXTime) + +import qualified Data.Text as T + +import System.LogLevel + +import Chainweb.Utils (catchAllSynchronous, sshow) + +-- -------------------------------------------------------------------------- -- +-- Task + +-- | A recurring task: a name, an interval in microseconds between runs, and +-- the action to run. The action runs once per interval; after each run the +-- task is requeued, so it never occupies a worker thread for more than one +-- run. +-- +data Task = Task + { _taskName :: !T.Text + , _taskInterval :: !Int + -- ^ interval between runs in microseconds + , _taskAction :: IO () + } + +-- | One second in microseconds. +seconds :: Int -> Int +seconds = (* 1000000) + +-- | One minute in microseconds. +minutes :: Int -> Int +minutes = (* 60000000) + +-- -------------------------------------------------------------------------- -- +-- Scheduler + +-- | Time-priority queue of scheduled tasks, keyed by due time. +-- +newtype TaskQueue = TaskQueue (TVar (Map Integer [Task])) + +newTaskQueue :: IO TaskQueue +newTaskQueue = TaskQueue <$> newTVarIO M.empty + +-- | Return the due time of the earliest task, blocking if the queue is +-- empty. +-- +peekDue :: TaskQueue -> STM Integer +peekDue (TaskQueue v) = do + m <- readTVar v + case M.lookupMin m of + Nothing -> retry + Just (due, _) -> return due + +-- | Pop the earliest task together with its due time. Only safe to call when +-- the earliest task is due. +-- +popTask :: TaskQueue -> STM (Integer, Task) +popTask (TaskQueue v) = do + m <- readTVar v + case M.lookupMin m of + Just (due, t : ts) -> do + let m' = if null ts then M.delete due m else M.insert due ts m + writeTVar v $! m' + return (due, t) + _ -> retry + +enqueueTask :: TaskQueue -> Integer -> Task -> STM () +enqueueTask (TaskQueue v) due task = + modifyTVar' v $ M.insertWith (flip (++)) due [task] + +-- | A scheduler that runs tasks on a bounded thread pool. +-- +data Scheduler = Scheduler + { _schedulerLog :: LogLevel -> T.Text -> IO () + , _schedulerQueue :: TaskQueue + } + +-- | Create a scheduler with the given logging function and number of worker +-- threads. The worker threads are terminated when the surrounding +-- 'ResourceT' region exits. +-- +withScheduler + :: (LogLevel -> T.Text -> IO ()) + -- ^ logging function + -> Int + -- ^ number of worker threads + -> ResourceT IO Scheduler +withScheduler logfun n = do + q <- liftIO newTaskQueue + let sched = Scheduler logfun q + _ <- allocate + (async (mapConcurrently_ (const $ worker sched) [1..max 1 n])) + cancel + return sched + where + worker sched = forever $ do + waitForDue sched + (due, task) <- atomically $ popTask (_schedulerQueue sched) + runOnce sched task + reschedule sched due task + + -- Block until the earliest task in the queue is due, waking early if an + -- earlier task is submitted. + waitForDue sched = do + due <- atomically $ peekDue (_schedulerQueue sched) + now <- nowUs + if due <= now + then return () + else do + timer <- registerDelay (fromIntegral (due - now)) + atomically $ + (check =<< readTVar timer) `orElse` do + due' <- peekDue (_schedulerQueue sched) + check (due' < due) + + -- Run a single iteration, recovering from synchronous exceptions like + -- 'Chainweb.Utils.runForever' does. + runOnce sched task = + _taskAction task + `catchAllSynchronous` \e -> + _schedulerLog sched Error $ + _taskName task <> " failed: " <> sshow e <> ". Continuing ..." + + -- Requeue the task one interval after its previous due time, so the + -- schedule doesn't drift when runs finish late. + reschedule sched due task = do + let due' = due + fromIntegral (_taskInterval task) + atomically $ enqueueTask (_schedulerQueue sched) due' task + +nowUs :: IO Integer +nowUs = fmap (floor . (* 1000000)) getPOSIXTime + +-- | Submit a task to the scheduler. The first run happens one interval from +-- now. +-- +schedule :: Scheduler -> Task -> IO () +schedule sched task = do + due <- nowUs + let due' = due + fromIntegral (_taskInterval task) + atomically $ enqueueTask (_schedulerQueue sched) due' task + +-- | Submit a recurring task that runs at the given interval (in +-- microseconds). +-- +scheduleEvery :: Scheduler -> T.Text -> Int -> IO () -> IO () +scheduleEvery sched name interval action = + schedule sched (Task name interval action) diff --git a/src/Chainweb/Sync/ForkInfo.hs b/src/Chainweb/Sync/ForkInfo.hs new file mode 100644 index 0000000000..6922e47351 --- /dev/null +++ b/src/Chainweb/Sync/ForkInfo.hs @@ -0,0 +1,377 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE FlexibleContexts #-} + +-- | +-- Module: Chainweb.Sync.ForkInfo +-- Copyright: Copyright © 2025 Kadena LLC. +-- License: MIT +-- Maintainer: Lars Kuhtz +-- Stability: experimental +-- +module Chainweb.Sync.ForkInfo +( resolveForkInfo +, resolveForkInfoForProviderState +) where + +import Chainweb.BlockHeader +import Chainweb.BlockHeaderDB +import Chainweb.Core.Brief +import Chainweb.Parent +import Chainweb.PayloadProvider +import Chainweb.Ranked +import Chainweb.Storage.Table +import Chainweb.TreeDB +import Chainweb.Utils +import Chainweb.Version +import Control.Applicative +import Control.Lens +import Control.Monad.Catch +import Control.Monad.Trans.Maybe +import Data.List qualified as L +import Data.LogMessage +import Data.Maybe +import Data.Text qualified as T +import Data.These (partitionHereThere) +import GHC.Generics (Generic) +import GHC.Stack +import P2P.TaskQueue (TaskException(TaskFailed)) +import P2P.Utils +import Streaming.Prelude qualified as S +import System.LogLevel +import Control.Monad + +-- -------------------------------------------------------------------------- -- + +newtype ForkInfoSyncFailure = ForkInfoSyncFailure T.Text + deriving (Show, Eq, Ord, Generic) + +instance Exception ForkInfoSyncFailure + +-- -------------------------------------------------------------------------- -- +-- Synchronize Payload Provider +-- +-- 1. Submit initial ForkInfo +-- 2. If result is not as requested: let ph be the height of the payload provider state. +-- 3. Efficiently compute fork point (starting at min of ph and target height) +-- 4. Get chunk size prefix of branch from fork point to target block +-- 5. Submit new ForkInfo with that prefix +-- 6. If result height is smaller than fork point retry from start and eventually fail. +-- 7. If result is on prefix continue with next prefix chunk from result. +-- 8. If result is larger than fork point and not on branch compute new fork +-- point. If that forkpoint is on prefix continue with next prefix chunk form +-- forkpoint. Otherwise retry from start and eventually fail. +-- +-- We do not include a new block context for chunked forkinfo resolutions. +-- Mining should be performed only on a fully caught up payload provider. + +_forkInfoChunkSize :: Int +_forkInfoChunkSize = 1000 + +-- -------------------------------------------------------------------------- -- + +-- | Resolve a ForkInfo for an existing block header against a PayloadProvider. +-- +-- Typically an initial forkInfo is either for a block that has been validated +-- before or for a single new block header. In the former case the trace is +-- typically empty, in the latter case it contains a single entry. +-- +-- TODO: trace this operation! +-- TODO: check the size of trace and if needed take appropriate measures +-- +resolveForkInfo + :: HasCallStack + => HasVersion + => ReadableBlockHeaderCas hdrCas + => PayloadProvider p + => LogFunctionText + -> BlockHeaderDb -- FIXME use RankedBlockHeaderDb + -> hdrCas + -> p + -> Maybe Hints + -> ForkInfo + -> IO () +resolveForkInfo logg bhdb candidateHdrs provider hints finfo = do + + logg Info $ "resolveForkInfo: starting resolution" + <> "; target state: " <> brief (_forkInfoTargetState finfo) + <> "; base payload: " <> brief (_forkInfoBasePayloadHash finfo) + <> "; trace length: " <> sshow (length $ _forkInfoTrace finfo) + <> "; payload requested: " <> sshow (isJust $ _forkInfoNewBlockCtx finfo) + + -- Attempt payload validation for the given ForkInfo + -- + -- We assume that this forkInfo has a trace of "reasonable" size + -- + r <- syncToBlock provider hints finfo `catch` \(e :: SomeException) -> do + logg Warn $ "getBlockHeaderInternal payload validation for " + <> toText h <> " failed with: " <> T.pack (displayException e) + throwM e + + -- Check result of syncToBlock + -- + if r == _forkInfoTargetState finfo + + -- We are done + -- + then return () + + -- We are not in sync and need to resolve (could be a fork a + -- payload provider that is not caught up yet) + -- + else do + resolveForkInfoForProviderState logg bhdb candidateHdrs provider hints finfo r + where + h = _latestRankedBlockHash . _forkInfoTargetState $ finfo + +-- | Resolve a ForkInfo with respect to the current (or some past) state of the +-- payload provider. +-- +-- If necessarily resolution is done iteratively in chunks. FIXME chunking +-- is not yet implemented. +-- +-- The operation fails if no progress is made in a chunk. +-- +resolveForkInfoForProviderState + :: HasCallStack + => HasVersion + => ReadableBlockHeaderCas hdrCas + => PayloadProvider p + => LogFunctionText + -> BlockHeaderDb -- FIXME use RankedBlockHeaderDb + -> hdrCas + -> p + -> Maybe Hints + -> ForkInfo + -> ConsensusState + -> IO () +resolveForkInfoForProviderState logg bhdb candidateHdrs provider hints finfo ppKnownState + | ppLatestBlock == trgHash = do + -- nothing to do, we are at the target + logg Info "resolveForkInfo: payload provider is at target block" + -- If no payload production is requested we are done. Otherwise we + -- still need to issue the syncToBlock call to initiate payload + -- production. + case _forkInfoNewBlockCtx finfo of + Nothing -> return () + Just _ -> do + logg Info "resolveForkInfo: requesting payload production at target block" + void $ syncToBlock provider hints finfo + -- TODO consider double checking the result. + | otherwise = do + logg Info $ "resolveForkInfo: payload provider state: " <> brief ppKnownState + <> "; target state: " <> brief (_forkInfoTargetState finfo) + + let lookupBhdb rbh = lookupRanked bhdb (int $ _rankedHeight rbh) (_ranked rbh) + + hdr :: BlockHeader <- runMaybeT + (MaybeT (tableLookup candidateHdrs (_ranked trgHash)) <|> MaybeT (lookupBhdb trgHash)) + >>= \case + Nothing -> do + throwM $ InternalInvariantViolation $ + "validatePayload: target block is missing: " <> brief trgHash + Just hdr -> return hdr + + -- Finding a fork from the latest block can fail if we don't know the + -- state of the payload provider. + -- This can happen if: + -- 1. the payload provider db comes from an external source. + -- 2. the payload provider has moved to a fork that catchup has not + -- finished validating. + -- In this case we can only guess where a common fork point might be -- + -- in the worst case this is genesis. The more common case is 2. in + -- which case the "safe" block is probably known. + let ppSafeBlock = _syncStateRankedBlockHash $ _consensusStateSafe ppKnownState + let ppFinalBlock = _syncStateRankedBlockHash $ _consensusStateFinal ppKnownState + ppBlock <- runMaybeT + (MaybeT (lookupBhdb ppLatestBlock) + <|> MaybeT (lookupBhdb ppSafeBlock) + <|> MaybeT (lookupBhdb ppFinalBlock)) >>= \case + Nothing -> + throwM $ InternalInvariantViolation $ "Final payload provider block is missing: " <> brief ppFinalBlock + Just ppBlock -> return ppBlock + + -- Lookup the state of the Payload Provider and query the trace + -- from the fork point to the target block. + -- + + -- Before we do the potentially expensive branch diff call, we check + -- whether the ppKnownState is in the trace of the finfo. + -- TODO this could be done more efficiently, but for now it is fine. + let idx = L.elemIndex (view rankedBlockHash ppBlock) + $ unwrapParent . _evaluationCtxRankedParentHash <$> _forkInfoTrace finfo + + newForkInfo <- case idx of + Just i -> do + logg Info $ "resolveForkInfo: found payload provider state as parent in trace at index " <> sshow i + if i == 0 + then + -- assert: (Parent $ _ranked $ _syncStateRankedBlockPayloadHash ppKnownState) == _forkInfoBasePayloadHash finfo + return finfo + else + -- The the payload provider does a fast forward without rewind. + return finfo + { _forkInfoTrace = drop i (_forkInfoTrace finfo) + , _forkInfoBasePayloadHash = Parent $ _ranked $ view rankedBlockPayloadHash ppBlock + } + Nothing -> do + logg Info "resolveForkInfo: payload provider state not in trace, computing fork point" + + -- FIXME: this stream can be very long if the payload provider + -- is out of sync. We should limit it and proceed iteratively if + -- necessary. Ideally, we check the length based on block + -- heights before we compute the full trace below. We also have + -- to be careful, that we compute the fork point only once and + -- iterate from there, otherwise the complexity would become + -- quadratic. + -- + -- Note that as long as no other CL is interfering with us we + -- can proceed in chunks starting form the fork point. According + -- to the payload provider protocol, the payload provider may + -- process the ForkInfo only partially, in which case the result + -- is our branch and the forkpoint is forwarded. If we find that + -- the result is on a fork it means that there is interference. + -- We may check whether we still made progress, in which case we + -- are fine. If we find that we do not make progress we raise an + -- error. + + (forkBlocksDescendingStream S.:> forkPoint) <- S.toList + + -- Note that this assumes that the parent of hdr is in the + -- block header DB. With the current cut pipeline that is + -- always the case, because we never validate a header for + -- which the parent hasn't already been validated. In case + -- that this changes in the future we need to adjust the + -- branch diff to start from parent of the lowest processed + -- block. That block would certainly be on the canonical + -- chain, since we wouldn't validate block that aren't + -- extending the current head. + -- + $ branchDiff_ bhdb ppBlock hdr + + let forkBlocksAscending = reverse + $ snd + $ partitionHereThere forkBlocksDescendingStream + + let l = length forkBlocksAscending + logg Info $ "resolveForkInfo: fork point: " <> brief forkPoint + <> "; fork length: " <> sshow l + <> "; fork blocks: " <> brief forkBlocksAscending + + -- If the original forkinfo trace contained extra payload data + -- we must include it into the new trace as well. + -- + let newTrace = mergeTrace + (headersToTrace forkPoint forkBlocksAscending) + (_forkInfoTrace finfo) + + -- A couple of cheap consistency checks. + unless (length newTrace == length forkBlocksAscending) $ + throwM $ InternalInvariantViolation $ + "merged trace length does not match expected length" + <> "; merged trace length: " <> sshow (length newTrace) + <> "; expected length: " <> sshow (length forkBlocksAscending) + + unless (_forkInfoTrace finfo `L.isSuffixOf` newTrace) $ + throwM $ InternalInvariantViolation + "original trace is not a suffix of the merged trace" + + return finfo + { _forkInfoTrace = newTrace + , _forkInfoBasePayloadHash = + Parent (view blockPayloadHash forkPoint) + } + + -- FXIME: when we limit the trace we still need to adjust + -- the target. We also need to make sure that we eventually + -- reach the target. For that we should remember the + -- remaining trace. After each chunk we concatenate the + -- remaining trace form the chunk with the overall remaining + -- trace and compute the next chunk. + -- Also, do not request payload creation on non-final chunks. + -- + -- let (nextChunk, remainingTrace) = splitAt forkInfoChunkSize forkBlocksAscending + + -- Retry payload validation with the new ForkInfo + -- + newState <- syncToBlock provider hints newForkInfo `catch` \(e :: SomeException) -> do + logg Warn $ "getBlockHeaderInternal payload validation retry for " + <> brief trgHash <> " failed with: " <> renderException + [ Renderer $ \(TaskFailed es) -> encodeToText + $ renderExceptionJson [Renderer clientErrorValue] <$> es + ] + e + throwM e + + -- TODO: when this function is incremental, we will manage this more correctly. + if ppKnownState /= newState + then do + logg Info $ "resolveForkInfo: made progress" + <> "; previous payload provider state: " <> brief ppKnownState + <> "; new payload provider state: " <> brief newState + <> "; target state: " <> brief (_forkInfoTargetState newForkInfo) + -- continue. + -- TODO compute the new fork info here. + resolveForkInfoForProviderState logg bhdb candidateHdrs provider hints newForkInfo newState + else do + logg Warn $ "resolveForkInfo: no progress" + <> "; previous payload provider state: " <> brief ppKnownState + <> "; new payload provider state: " <> brief newState + <> "; target state: " <> brief (_forkInfoTargetState newForkInfo) + + -- If this fails, there is no way for the payload provider to + -- sync to the block without using the ordinary cut pipeline. + -- so, we raise an exception. + -- + throwM $ ForkInfoSyncFailure $ "unexpected result state" + <> "; previous payload provider state: " <> brief ppKnownState + <> "; new payload provider state: " <> brief newState + <> "; target state: " <> brief (_forkInfoTargetState newForkInfo) + <> "; trace: " <> brief (_forkInfoTrace newForkInfo) + where + trgHash = _latestRankedBlockHash . _forkInfoTargetState $ finfo + ppLatestBlock = _syncStateRankedBlockHash $ _consensusStateLatest ppKnownState + +-- -------------------------------------------------------------------------- -- +-- Trace Utils + +headersToTrace + :: HasVersion + => BlockHeader + -- ^ The fork point block header + -> [BlockHeader] + -- ^ The blocks from the fork point (exclusive) to the target block + -- (inclusive) in ascending order. + -> [EvaluationCtx ConsensusPayload] +headersToTrace forkPoint hdrs = zipWith f (forkPoint : hdrs) hdrs + where + f phdr hdr = ConsensusPayload (view blockPayloadHash hdr) Nothing + <$ blockHeaderToEvaluationCtx (Parent phdr) + + +-- | right-biased merge of two traces, where elements are matched by +-- '_evaluationCtxParentHash'. +-- +-- Precondition: one trace is a suffix of the other trace modulo the payload +-- data. +-- Postcondition: result is a suffix of the second argument. +-- +-- FIXME: this could be implemented more efficiently using a vector and the the +-- rank of th invovled headers. +-- +mergeTrace + :: [EvaluationCtx ConsensusPayload] + -> [EvaluationCtx ConsensusPayload] + -> [EvaluationCtx ConsensusPayload] +mergeTrace = go + where + go xs [] = xs + go [] ys = ys + go (x:xs) (y:ys) + | _evaluationCtxParentHash x == _evaluationCtxParentHash y + = y:ys + | otherwise + = x : go xs (y:ys) diff --git a/src/Chainweb/Sync/WebBlockHeaderStore.hs b/src/Chainweb/Sync/WebBlockHeaderStore.hs index 82e62ee43a..c093e7a94a 100644 --- a/src/Chainweb/Sync/WebBlockHeaderStore.hs +++ b/src/Chainweb/Sync/WebBlockHeaderStore.hs @@ -3,6 +3,7 @@ {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE ImportQualifiedPost #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NumericUnderscores #-} @@ -13,6 +14,7 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} + {-# OPTIONS_GHC -fno-warn-orphans #-} -- | @@ -29,65 +31,66 @@ module Chainweb.Sync.WebBlockHeaderStore ( WebBlockHeaderStore(..) , newWebBlockHeaderStore , getBlockHeader +, forkInfoForHeader -- * , WebBlockPayloadStore(..) -, newEmptyWebPayloadStore +-- , newEmptyWebPayloadStore , newWebPayloadStore -- * Utils , memoInsert -, PactExecutionService(..) ) where -import Control.Concurrent.Async -import Control.Lens -import Control.Monad -import Control.Monad.Catch - -import Data.Foldable -import Data.Hashable -import qualified Data.Text as T - -import GHC.Generics - -import qualified Network.HTTP.Client as HTTP - -import Servant.Client - -import System.LogLevel - --- internal modules - import Chainweb.BlockHash import Chainweb.BlockHeader import Chainweb.BlockHeader.Validation import Chainweb.BlockHeaderDB import Chainweb.BlockHeaderDB.RemoteDB -import Chainweb.BlockHeight import Chainweb.ChainId import Chainweb.ChainValue -import Chainweb.Payload -import Chainweb.Payload.PayloadStore -import Chainweb.Payload.RestAPI.Client +import Chainweb.Difficulty (WindowWidth(..)) +import Chainweb.MinerReward (blockMinerReward) +import Chainweb.Pact.Payload +import Chainweb.Pact.Payload.PayloadStore +import Chainweb.Parent +import Chainweb.PayloadProvider +import Chainweb.Storage.Table +import Chainweb.Sync.ForkInfo import Chainweb.Time import Chainweb.TreeDB -import qualified Chainweb.TreeDB as TDB +import Chainweb.TreeDB qualified as TDB import Chainweb.Utils +import Chainweb.Utils.Paging (Limit(..)) import Chainweb.Version +import Chainweb.Version.Utils (diameterAt) import Chainweb.WebBlockHeaderDB -import Chainweb.WebPactExecutionService - +import Control.Concurrent.Async +import Control.Lens +import Control.Monad +import Control.Monad.Catch +import Data.Foldable +import Data.Foldable qualified as F +import Data.Hashable +import Data.HashSet qualified as HS import Data.LogMessage import Data.PQueue +import Data.Semigroup (Min(..)) import Data.TaskMap - +import Data.Text qualified as T +import GHC.Generics (Generic) +import GHC.Stack +import Network.HTTP.Client qualified as HTTP +import Numeric.Natural (Natural) import P2P.Peer import P2P.TaskQueue - +import Servant.Client +import Streaming.Prelude qualified as S +import System.LogLevel import Utils.Logging.Trace - -import Chainweb.Storage.Table +import Chainweb.Logger +import Chainweb.Core.Brief +import Data.Maybe -- -------------------------------------------------------------------------- -- -- Response Timeout Constants @@ -120,10 +123,6 @@ setResponseTimeout t env = env newtype WebBlockHeaderCas = WebBlockHeaderCas WebBlockHeaderDb -instance HasChainwebVersion WebBlockHeaderCas where - _chainwebVersion (WebBlockHeaderCas db) = _chainwebVersion db - {-# INLINE _chainwebVersion #-} - -- -------------------------------------------------------------------------- -- -- Obtain and Validate Block Payloads @@ -138,9 +137,6 @@ data WebBlockPayloadStore tbl = WebBlockPayloadStore -- ^ LogFunction , _webBlockPayloadStoreMgr :: !HTTP.Manager -- ^ Manager object for making HTTP requests - , _webBlockPayloadStorePact :: !WebPactExecutionService - -- ^ handle to the pact execution service for validating transactions - -- and computing outputs. } -- -------------------------------------------------------------------------- -- @@ -158,18 +154,14 @@ data WebBlockPayloadStore tbl = WebBlockPayloadStore -- would be possible to run this on top of any CAS and API that offers -- a simple GET. -- -data WebBlockHeaderStore = WebBlockHeaderStore +data WebBlockHeaderStore l = WebBlockHeaderStore { _webBlockHeaderStoreCas :: !WebBlockHeaderDb , _webBlockHeaderStoreMemo :: !(TaskMap (ChainValue BlockHash) (ChainValue BlockHeader)) , _webBlockHeaderStoreQueue :: !(PQueue (Task ClientEnv (ChainValue BlockHeader))) - , _webBlockHeaderStoreLogFunction :: !LogFunction + , _webBlockHeaderStoreLogger :: l , _webBlockHeaderStoreMgr :: !HTTP.Manager } -instance HasChainwebVersion WebBlockHeaderStore where - _chainwebVersion = _chainwebVersion . _webBlockHeaderStoreCas - {-# INLINE _chainwebVersion #-} - -- -------------------------------------------------------------------------- -- -- Overlay CAS with asynchronous weak HashMap @@ -194,92 +186,116 @@ memoInsert cas m k a = tableLookup cas k >>= \case return v (Just !x) -> return x --- | Query a payload either from the local store, or the origin, or P2P network. +-- | For a given latest BlockHeader return the state of consensus -- --- The payload is only queried and not inserted into the local store. We want to --- insert it only after it got validate by pact in order to avoid accumlation of --- garbage. +-- THIS IS NOT FINAL! -- -getBlockPayload - :: CanReadablePayloadCas tbl - => Cas candidateCas PayloadData - => WebBlockPayloadStore tbl - -> candidateCas - -> Priority - -> Maybe PeerInfo - -- ^ Peer from with the BlockPayloadHash originated, if available. +-- TODO: +-- This should eventually become a consensus component on its own. It probably +-- needs to depend on the cut db (and it is not clear how that would fit in this +-- module). +-- +-- It should take into consideration the current hash power, weight, and +-- difficulty. It should probably also take into consideration historical hash +-- power, like the all time max. +-- +-- For instance, the confirmation depth should approach infinite as the honest +-- hash power degrades towards 50% (of the all time max). +-- +-- For now we use +-- +-- - safe: 6 times of the graph diameter block heights, ~ 9 min +-- - final: 4 epochs, 120 * 4 block heights, ~ 4 hours +-- +consensusState + :: HasCallStack + => HasVersion + => WebBlockHeaderDb -> BlockHeader - -- ^ The BlockHeader for which the payload is requested - -> IO PayloadData -getBlockPayload s candidateStore priority maybeOrigin h = do - logfun Debug $ "getBlockPayload: " <> sshow h - tableLookup candidateStore payloadHash >>= \case - Just !x -> return x - Nothing -> lookupPayloadWithHeight cas (Just $ view blockHeight h) payloadHash >>= \case - Just !x -> return $! payloadWithOutputsToPayloadData x - Nothing -> memo memoMap payloadHash $ \k -> - pullOrigin (view blockHeight h) k maybeOrigin >>= \case - Nothing -> do - t <- queryPayloadTask (view blockHeight h) k - pQueueInsert queue t - awaitTask t - (Just !x) -> return x - + -> IO ConsensusState +consensusState wdb hdr + | isGenesisBlockHeader hdr = return ConsensusState + { _consensusStateLatest = syncStateOfBlockHeader hdr + , _consensusStateSafe = syncStateOfBlockHeader hdr + , _consensusStateFinal = syncStateOfBlockHeader hdr + } + | otherwise = do + db <- getWebBlockHeaderDb wdb hdr + Parent phdr <- lookupParentHeader wdb hdr + safeHdr <- fromJuste <$> seekAncestor db phdr safeHeight + finalHdr <- fromJuste <$> seekAncestor db phdr finalHeight + return ConsensusState + { _consensusStateLatest = syncStateOfBlockHeader hdr + , _consensusStateSafe = syncStateOfBlockHeader safeHdr + , _consensusStateFinal = syncStateOfBlockHeader finalHdr + } where - v = _chainwebVersion h - payloadHash = view blockPayloadHash h - cid = _chainId h - - mgr = _webBlockPayloadStoreMgr s - cas = _webBlockPayloadStoreCas s - memoMap = _webBlockPayloadStoreMemo s - queue = _webBlockPayloadStoreQueue s + WindowWidth w = _versionWindow implicitVersion + cid = _chainId hdr + finalHeight = int @Int @_ $ max (int $ genesisHeight cid) (int height - int w * 4) + safeHeight = int @Int @_ $ max (int $ genesisHeight cid) (int height - 6 * (int diam + 1)) + height = view blockHeight hdr + diam = diameterAt height - logfun :: LogLevel -> T.Text -> IO () - logfun = _webBlockPayloadStoreLogFunction s - - traceLogfun :: LogMessage a => LogLevel -> a -> IO () - traceLogfun = _webBlockPayloadStoreLogFunction s - - taskMsg k msg = "payload task " <> sshow k <> " @ " <> sshow (view blockHash h) <> ": " <> msg - - traceLabel subfun = - "Chainweb.Sync.WebBlockHeaderStore.getBlockPayload." <> subfun +-- -------------------------------------------------------------------------- -- +-- ForkInfo For Header - -- | Try to pull a block payload from the given origin peer - -- - pullOrigin :: BlockHeight -> BlockPayloadHash -> Maybe PeerInfo -> IO (Maybe PayloadData) - pullOrigin _ k Nothing = do - logfun Debug $ taskMsg k "no origin" - return Nothing - pullOrigin bh k (Just origin) = do - let originEnv = setResponseTimeout pullOriginResponseTimeout $ peerInfoClientEnv mgr origin - logfun Debug $ taskMsg k "lookup origin" - !r <- trace traceLogfun (traceLabel "pullOrigin") k 0 - $ runClientM (payloadClient v cid k (Just bh)) originEnv - case r of - (Right !x) -> do - logfun Debug $ taskMsg k "received from origin" - return $ Just x - Left (e :: ClientError) -> do - logfun Debug $ taskMsg k $ "failed to receive from origin: " <> sshow e - return Nothing +-- | Compute ForkInfo Object for a single newly added BlockHeader +-- +forkInfoForHeader + :: HasVersion + => WebBlockHeaderDb + -> BlockHeader + -- ^ The block header of the target consensus state of the fork info. + -> Maybe EncodedPayloadData + -> Maybe (Parent BlockHeader) + -- ^ Parent header of the given header if available. But this is not + -- checked! + -- If not provided it will be looked up in the database by this function. + -- + -- TODO: we should probably check that this value is indeed the parent + -- of the given header. + -> Bool + -- ^ Whether to request payload production on the target state of + -- the fork info. + -> IO ForkInfo +forkInfoForHeader wdb hdr pldData parentHdr createPayload + + -- FIXME do we need this case??? We never add genesis headers... + | isGenesisBlockHeader hdr = do + state <- consensusState wdb hdr + return $ ForkInfo + { _forkInfoTrace = [] + , _forkInfoBasePayloadHash = Parent $ _latestPayloadHash state + , _forkInfoTargetState = state + , _forkInfoNewBlockCtx = nbctx + } + + | otherwise = do + phdr <- maybe (lookupParentHeader wdb hdr) return parentHdr + let consensusPayload = ConsensusPayload + { _consensusPayloadHash = pld + , _consensusPayloadData = pldData + } + + -- TargetState + state <- consensusState wdb hdr + return $ ForkInfo + { _forkInfoTrace = [consensusPayload <$ blockHeaderToEvaluationCtx phdr] + , _forkInfoBasePayloadHash = view blockPayloadHash <$> phdr + , _forkInfoTargetState = state + , _forkInfoNewBlockCtx = nbctx + } + where + pld = view blockPayloadHash hdr - -- | Query a block payload via the task queue - -- - queryPayloadTask :: BlockHeight -> BlockPayloadHash -> IO (Task ClientEnv PayloadData) - queryPayloadTask bh k = newTask (sshow k) priority $ \logg env -> do - logg @T.Text Debug $ taskMsg k "query remote block payload" - let taskEnv = setResponseTimeout taskResponseTimeout env - !r <- trace traceLogfun (traceLabel "queryPayloadTask") k (let Priority i = priority in i) - $ runClientM (payloadClient v cid k (Just bh)) taskEnv - case r of - (Right !x) -> do - logg @T.Text Debug $ taskMsg k "received remote block payload" - return x - Left (e :: ClientError) -> do - logg @T.Text Debug $ taskMsg k $ "failed: " <> sshow e - throwM e + nbctx + | createPayload = Just NewBlockCtx + { _newBlockCtxMinerReward = blockMinerReward (height + 1) + , _newBlockCtxParentCreationTime = Parent $ view blockCreationTime hdr + } + | otherwise = Nothing + height = view blockHeight hdr -- -------------------------------------------------------------------------- -- -- Obtain, Validate, and Store BlockHeaders @@ -299,21 +315,44 @@ instance Exception GetBlockHeaderFailure -- iterative algorithm is preferable. -- getBlockHeaderInternal - :: CanPayloadCas tbl + :: forall l candidateHeaderCas candidatePldTbl + . HasVersion => BlockHeaderCas candidateHeaderCas - => PayloadDataCas candidatePayloadCas - => WebBlockHeaderStore - -> WebBlockPayloadStore tbl + -- ^ CandidateHeaderCas is a content addressed store for BlockHeaders + => ReadableTable candidatePldTbl BlockPayloadHash EncodedPayloadData + => Logger l + => WebBlockHeaderStore l + -- ^ Block Header Store for all Chains -> candidateHeaderCas - -> candidatePayloadCas - -> Maybe (BlockPayloadHash, PayloadWithOutputs) + -- ^ Ephemeral store for block headers under consideration + -> candidatePldTbl + -> ChainMap ConfiguredPayloadProvider + -> Maybe (BlockPayloadHash, EncodedPayloadOutputs) + -- ^ Payload and Header data for the block, in case that it is + -- available. -> Priority + -- ^ Priority of P2P tasks for querying headers and payloads -> Maybe PeerInfo + -- ^ Origin hint for the block header and related data. -> ChainValue BlockHash + -- ^ The hash of the block that is processed, tagged by the chain -> IO (ChainValue BlockHeader) -getBlockHeaderInternal headerStore payloadStore candidateHeaderCas candidatePayloadCas localPayload priority maybeOrigin h = do - logg Debug $ "getBlockHeaderInternal: " <> sshow h + -- ^ If validation is successful the added block header is returned +getBlockHeaderInternal + headerStore + candidateHeaderCas + candidatePldTbl + providers + localPayload + priority + maybeOrigin + h + = do + logg Debug $ "getBlockHeaderInternal: " <> toText h !bh <- memoInsert cas memoMap h $ \k@(ChainValue cid k') -> do + -- assertion: h == k + + let taskLog = taskLogFun k -- query BlockHeader via -- @@ -323,6 +362,9 @@ getBlockHeaderInternal headerStore payloadStore candidateHeaderCas candidatePayl -- - cut origin, or -- - task queue of P2P network -- + -- we inser the header into the candidate cas, so that the + -- payload provider can use it. + -- (maybeOrigin', header) <- tableLookup candidateHeaderCas k' >>= \case Just !x -> return (maybeOrigin, x) Nothing -> pullOrigin k maybeOrigin >>= \case @@ -330,8 +372,11 @@ getBlockHeaderInternal headerStore payloadStore candidateHeaderCas candidatePayl t <- queryBlockHeaderTask k pQueueInsert queue t (ChainValue _ !x) <- awaitTask t + casInsert candidateHeaderCas x return (Nothing, x) - Just !x -> return (maybeOrigin, x) + Just !x -> do + casInsert candidateHeaderCas x + return (maybeOrigin, x) -- Check that the chain id is correct. The candidate cas is indexed just -- by the block hash. So, if this fails it is most likely a bug in code @@ -352,49 +397,87 @@ getBlockHeaderInternal headerStore payloadStore candidateHeaderCas candidatePayl -- prerequesite in the memo-table it is awaited, otherwise a new job is -- created. -- - let isGenesisParentHash p = _chainValueValue p == genesisParentBlockHash v p + let isGenesisParentHash p = _chainValueValue p == genesisParentBlockHash p queryAdjacentParent p = Concurrently $ unless (isGenesisParentHash p) $ void $ do - logg Debug $ taskMsg k - $ "getBlockHeaderInternal.getPrerequisteHeader (adjacent) for " <> sshow h - <> ": " <> sshow p + taskLog Debug + $ "getBlockHeaderInternal.getPrerequisiteHeader (adjacent)" + <> "; header: " <> toText (brief <$> h) + <> "; queried adjacent parent: " <> toText (brief <$> p) getBlockHeaderInternal headerStore - payloadStore candidateHeaderCas - candidatePayloadCas + candidatePldTbl + providers localPayload priority maybeOrigin' - p + (unwrapParent <$> p) -- Perform inductive (involving the parent) validations on the block -- header. There's another complete pass of block header validations -- after payload validation when the header is finally added to the db. -- - queryParent p = Concurrently $ void $ do - logg Debug $ taskMsg k - $ "getBlockHeaderInternal.getPrerequisteHeader (parent) for " <> sshow h - <> ": " <> sshow p - void $ getBlockHeaderInternal + queryParent p = Concurrently $ do + taskLog Debug + $ "getBlockHeaderInternal.getPrerequisiteHeader (parent)" + <> "; header: " <> toText (brief <$> h) + <> "; queried parent: " <> toText (brief <$> p) + parentHdr <- Parent <$> getBlockHeaderInternal headerStore - payloadStore candidateHeaderCas - candidatePayloadCas + candidatePldTbl + providers localPayload priority maybeOrigin' - p - chainDb <- getWebBlockHeaderDb (_webBlockHeaderStoreCas headerStore) header + (unwrapParent <$> p) + chainDb <- getWebBlockHeaderDb wdb header validateInductiveChainM (tableLookup chainDb) header - - !p <- runConcurrently - -- query payload - $ Concurrently - (getBlockPayload payloadStore candidatePayloadCas priority maybeOrigin' header) + return $ fmap _chainValueValue parentHdr + + -- Get the Payload Provider and + let hints = Hints <$> maybeOrigin' + pld <- tableLookup candidatePldTbl (view blockPayloadHash header) + + let prefetchProviderPayloads = case providers ^?! atChain cid of + ConfiguredPayloadProvider provider -> do + + -- FIXME: + -- It is is not clear how useful this is, since we prefetch + -- just a single payload here. In theory we could make an + -- educated guess here about what else might be missing. But + -- there are better strategies for that. + -- + -- For an efficient prefetch we would have to do a full fork + -- resolution. After we discover the fork point we would + -- have the full list of payloads to prefetch. But at the + -- moment we cannot do that because we don't yet have the + -- required consensus headers available. + -- + -- So, the proper solution is to implement batched header + -- prefetching based on the current fork height and the + -- height of the target header. After that we can also + -- prefetch the payloads of those headers in a single batch. + -- + -- Another option would be to provide an API that allows + -- fetching payloads from the canonical chain based on + -- height. + -- + -- FIXME: ensure that we do not prefetch locally mined blocks + -- can we check the origin hints for that? + when (isJust maybeOrigin && isNothing pld) $ do + prefetchPayloads provider hints + [flip ConsensusPayload Nothing <$> view rankedBlockPayloadHash header] + DisabledPayloadProvider -> return () + + parentHdr <- runConcurrently + -- instruct the payload provider to fetch payload data and prepare + -- validation. + $ Concurrently prefetchProviderPayloads -- query parent (recursively) -- - <* queryParent (view blockParent <$> chainValue header) + *> queryParent (view blockParent <$> chainValue header) -- query adjacent parents (recursively) <* mconcat (queryAdjacentParent <$> adjParents header) @@ -407,7 +490,7 @@ getBlockHeaderInternal headerStore payloadStore candidateHeaderCas candidatePayl -- -- This requires to provide a CPS version of memoInsert. - logg Debug $ taskMsg k $ "getBlockHeaderInternal got pre-requesites for " <> sshow h + taskLog Debug $ "getBlockHeaderInternal got pre-requesites for " <> toText h -- ------------------------------------------------------------------ -- -- Validation @@ -434,24 +517,35 @@ getBlockHeaderInternal headerStore payloadStore candidateHeaderCas candidatePayl -- 4. Validate block payload -- - -- Pact validation is done in the context of a particular header. Just - -- because the payload does already exist in the store doesn't mean that - -- validation succeeds in the context of a particular block header. + -- Payload validation is done in the context of a particular header. + -- Just because the payload does already exist in the store doesn't mean + -- that validation succeeds in the context of a particular block header. -- -- If we reach this point in the code we are certain that the header -- isn't yet in the block header database and thus we still must -- validate the payload for this block header. -- - logg Debug $ taskMsg k $ "getBlockHeaderInternal validate payload for " <> sshow h <> ": " <> sshow p - validateAndInsertPayload header p `catch` \(e :: SomeException) -> do - logg Warn $ taskMsg k $ "getBlockHeaderInternal pact validation for " <> sshow h <> " failed with :" <> sshow e - throwM e - logg Debug $ taskMsg k "getBlockHeaderInternal pact validation succeeded" + taskLog Debug $ "getBlockHeaderInternal: validate payload for " <> toText h + case providers ^?! atChain cid of + ConfiguredPayloadProvider provider -> do + -- Compute a ForkInfo FOR A SINGLE BLOCK. + -- + -- Do not produce payloads at this point; we may not stick around at + -- this block. + -- - logg Debug $ taskMsg k $ "getBlockHeaderInternal return header " <> sshow h + finfo <- forkInfoForHeader wdb header pld (Just parentHdr) False + bhdb <- getWebBlockHeaderDb wdb cid + resolveForkInfo taskLog bhdb candidateHeaderCas provider hints finfo + DisabledPayloadProvider -> do + taskLog Debug "getBlockHeaderInternal: payload provider disabled" + + taskLog Debug "getBlockHeaderInternal payload validation succeeded" + + taskLog Debug $ "getBlockHeaderInternal return header " <> toText h return $! chainValue header - logg Debug $ "getBlockHeaderInternal: got block header for " <> sshow h + logg Debug $ "getBlockHeaderInternal: got block header for " <> toText h return bh where @@ -460,53 +554,62 @@ getBlockHeaderInternal headerStore payloadStore candidateHeaderCas candidatePayl cas = WebBlockHeaderCas $ _webBlockHeaderStoreCas headerStore memoMap = _webBlockHeaderStoreMemo headerStore queue = _webBlockHeaderStoreQueue headerStore - v = _chainwebVersion cas + wdb = _webBlockHeaderStoreCas headerStore + + logger = _webBlockHeaderStoreLogger headerStore + + taskLogger :: forall a . Brief a => T.Text -> ChainValue a -> l + taskLogger taskType k + = addLabel (taskType, brief (_chainValueValue k)) + . addLabel ("chain", toText (_chainValueChainId k)) + $ logger + + taskLogFun k = logFunction (taskLogger "header" k) logfun :: LogFunction - logfun = _webBlockHeaderStoreLogFunction headerStore + logfun = logFunction logger logg :: LogFunctionText logg = logfun @T.Text - taskMsg k msg = "header task " <> sshow k <> ": " <> msg - traceLabel subfun = "Chainweb.Sync.WebBlockHeaderStore.getBlockHeaderInternal." <> subfun - pact = _pactValidateBlock - $ _webPactExecutionService - $ _webBlockPayloadStorePact payloadStore - - validateAndInsertPayload :: BlockHeader -> PayloadData -> IO () - validateAndInsertPayload hdr p = do - let payload = case localPayload of - Just (hsh, pwo) - | hsh == view blockPayloadHash hdr - -> CheckablePayloadWithOutputs pwo - _ -> CheckablePayload p - outs <- trace logfun - (traceLabel "pact") - (view blockHash hdr) - (length (view payloadDataTransactions p)) - $ pact hdr payload - addNewPayload (_webBlockPayloadStoreCas payloadStore) (view blockHeight hdr) outs + -- pact = _pactValidateBlock + -- $ _webPactExecutionService + -- $ _webBlockPayloadStorePact payloadStore + + -- validateAndInsertPayload :: BlockHeader -> PayloadData -> IO () + -- validateAndInsertPayload hdr p = do + -- let payload = case localPayload of + -- Just (hsh, pwo) + -- | hsh == view blockPayloadHash hdr + -- -> CheckablePayloadWithOutputs pwo + -- _ -> CheckablePayload p + -- outs <- trace logfun + -- (traceLabel "pact") + -- (view blockHash hdr) + -- (length (view payloadDataTransactions p)) + -- $ pact hdr payload + -- addNewPayload (_webBlockPayloadStoreCas payloadStore) (view blockHeight hdr) outs queryBlockHeaderTask ck@(ChainValue cid k) - = newTask (sshow ck) priority $ \l env -> chainValue <$> do - l @T.Text Debug $ taskMsg ck "query remote block header" + = newTask (TaskId (toText ck)) priority $ \l env -> chainValue <$> do + l @T.Text Debug $ taskMsg "query remote block header" let taskEnv = setResponseTimeout taskResponseTimeout env !r <- trace l (traceLabel "queryBlockHeaderTask") k (let Priority i = priority in i) $ TDB.lookupM (rDb cid taskEnv) k `catchAllSynchronous` \e -> do - l @T.Text Debug $ taskMsg ck $ "failed: " <> sshow e + l @T.Text Debug $ taskMsg $ "failed: " <> T.pack (displayException e) throwM e - l @T.Text Debug $ taskMsg ck "received remote block header" + l @T.Text Debug $ taskMsg "received remote block header" return r + where + taskMsg msg = "[" <> toText cid <> ":" <> brief k <> "] " <> msg rDb :: ChainId -> ClientEnv -> RemoteDb rDb cid env = RemoteDb { _remoteEnv = env , _remoteLogFunction = ALogFunction logfun - , _remoteVersion = v , _remoteChainId = cid } @@ -517,15 +620,23 @@ getBlockHeaderInternal headerStore payloadStore candidateHeaderCas candidatePayl -> Maybe PeerInfo -> IO (Maybe BlockHeader) pullOrigin ck Nothing = do - logg Debug $ taskMsg ck "no origin" + taskLogFun ck Debug "no origin" return Nothing pullOrigin ck@(ChainValue cid k) (Just origin) = do let originEnv = setResponseTimeout pullOriginResponseTimeout $ peerInfoClientEnv mgr origin - logg Debug $ taskMsg ck "lookup origin" + tlog Debug "lookup origin" !r <- trace logfun (traceLabel "pullOrigin") k 0 $ TDB.lookup (rDb cid originEnv) k - logg Debug $ taskMsg ck "received from origin" - return r + case r of + Nothing -> do + tlog Warn $ "failed to pull from origin " + <> toText origin <> " key " <> toText k + return Nothing + Just !v -> do + tlog Debug "received from origin" + return $ Just v + where + tlog = taskLogFun ck -- pullOriginDeps _ Nothing = return () -- pullOriginDeps ck@(ChainValue cid k) (Just origin) = do @@ -541,77 +652,150 @@ getBlockHeaderInternal headerStore payloadStore candidateHeaderCas candidatePayl -- return () newWebBlockHeaderStore - :: HTTP.Manager + :: Logger l + => HTTP.Manager -> WebBlockHeaderDb - -> LogFunction - -> IO WebBlockHeaderStore -newWebBlockHeaderStore mgr wdb logfun = do + -> l + -> IO (WebBlockHeaderStore l) +newWebBlockHeaderStore mgr wdb logger = do m <- new queue <- newEmptyPQueue _taskPriority _taskId Nothing - return $! WebBlockHeaderStore wdb m queue logfun mgr - -newEmptyWebPayloadStore - :: CanPayloadCas tbl - => ChainwebVersion - -> HTTP.Manager - -> WebPactExecutionService - -> LogFunction - -> PayloadDb tbl - -> IO (WebBlockPayloadStore tbl) -newEmptyWebPayloadStore v mgr pact logfun payloadDb = do - initializePayloadDb v payloadDb - newWebPayloadStore mgr pact payloadDb logfun + return $! WebBlockHeaderStore wdb m queue logger mgr newWebPayloadStore :: HTTP.Manager - -> WebPactExecutionService -> PayloadDb tbl -> LogFunction -> IO (WebBlockPayloadStore tbl) -newWebPayloadStore mgr pact payloadDb logfun = do +newWebPayloadStore mgr payloadDb logfun = do payloadTaskQueue <- newEmptyPQueue _taskPriority _taskId Nothing payloadMemo <- new return $! WebBlockPayloadStore - payloadDb payloadMemo payloadTaskQueue logfun mgr pact + payloadDb payloadMemo payloadTaskQueue logfun mgr + +-- | Maximum number of headers that are requested in a single prefetch +-- request. The remote endpoint pages its results, so larger missing +-- suffixes are still fetched completely, at one request per page. +-- +prefetchBranchLimit :: Limit +prefetchBranchLimit = Limit 1000 +-- | Prefetch the missing suffix of a chain from the cut origin in a single +-- batched branch query and make the headers available in the candidate +-- header store. +-- +-- Without this prefetch, catching up on a chain costs one HTTP round trip +-- per block height, because 'getBlockHeaderInternal' resolves prerequisites +-- recursively, one header at a time. A single branch query returns the same +-- headers in one round trip (per result page). +-- +-- The query asks for all headers on the branch of the target that are +-- strictly above the current local tip of the chain. If the target is not a +-- descendant of the local tip, the minimum rank bound still caps the result +-- to recent headers, and any headers that are actually needed but not +-- prefetched are obtained through the regular per-header code path. +-- +-- The prefetch is a pure optimization: all prefetched headers still go +-- through the full validation in 'getBlockHeaderInternal'. Any failure is +-- ignored, falling back to the regular per-header fetch. +-- +prefetchOriginBranch + :: HasVersion + => Logger l + => BlockHeaderCas candidateHeaderCas + => WebBlockHeaderStore l + -> candidateHeaderCas + -> Maybe PeerInfo + -> ChainValue RankedBlockHash + -> IO () +prefetchOriginBranch _ _ Nothing _ = return () +prefetchOriginBranch headerStore candidateHeaderCas (Just origin) (ChainValue cid target) = do + + -- The local tip defines the lower bound of the prefetch. If it can't be + -- determined, the prefetch is skipped entirely. + db <- getWebBlockHeaderDb wdb cid + etip <- try (maxEntry db) + + case etip of + Left (_ :: SomeException) -> return () + Right tip | int (rank tip) >= targetHeight -> return () + Right tip -> do + + let env = setResponseTimeout pullOriginResponseTimeout + $ peerInfoClientEnv mgr origin + rdb = RemoteDb + { _remoteEnv = env + , _remoteLogFunction = ALogFunction logfun + , _remoteChainId = cid + } + lower = HS.singleton (LowerBound (key tip)) + upper = HS.singleton (UpperBound targetHash) + mir = Just (MinRank (Min (succ $ rank tip))) + + headers <- + ( branchEntries rdb Nothing (Just prefetchBranchLimit) mir Nothing lower upper + S.toList_ + ) `catch` \(_ :: SomeException) -> return [] + unless (F.null headers) $ + logg Debug $ "prefetched " <> sshow (length headers) + <> " headers from origin for chain " <> toText cid + casInsertBatch candidateHeaderCas headers + + where + wdb = _webBlockHeaderStoreCas headerStore + mgr = _webBlockHeaderStoreMgr headerStore + logfun :: LogFunction + logfun = logFunction $ _webBlockHeaderStoreLogger headerStore + logg :: LogFunctionText + logg = logfun @T.Text + targetHash = _rankedBlockHashHash target + targetHeight = int $ _rankedBlockHashHeight target :: Natural + +-- | Obtain and validate all prerequisite block headers and payloads for the +-- given block hash and return the validated block header. +-- +-- Throws a TaskeFailed exception in case that some prerequisite cannot be +-- obtained or validated. The exception contains all underlying exceptions. +-- getBlockHeader - :: CanPayloadCas tbl + :: HasVersion => BlockHeaderCas candidateHeaderCas - => PayloadDataCas candidatePayloadCas - => WebBlockHeaderStore - -> WebBlockPayloadStore tbl + => ReadableTable candidatePldTbl BlockPayloadHash EncodedPayloadData + => Logger l + => WebBlockHeaderStore l -> candidateHeaderCas - -> candidatePayloadCas - -> Maybe (BlockPayloadHash, PayloadWithOutputs) - -> ChainId + -> candidatePldTbl + -> ChainMap ConfiguredPayloadProvider + -> Maybe (BlockPayloadHash, EncodedPayloadOutputs) -> Priority -> Maybe PeerInfo - -> BlockHash + -> ChainValue RankedBlockHash -> IO BlockHeader -getBlockHeader headerStore payloadStore candidateHeaderCas candidatePayloadCas localPayload cid priority maybeOrigin h - = ((\(ChainValue _ b) -> b) <$> go) - `catch` \(TaskFailed _es) -> throwM $ TreeDbKeyNotFound @BlockHeaderDb h +getBlockHeader headerStore candidateHeaderCas candidatePldTbl providers localPayload priority maybeOrigin ch + = do + prefetchOriginBranch headerStore candidateHeaderCas maybeOrigin ch + (\(ChainValue _ b) -> b) <$> go where go = getBlockHeaderInternal headerStore - payloadStore candidateHeaderCas - candidatePayloadCas + candidatePldTbl + providers localPayload priority maybeOrigin - (ChainValue cid h) + (_rankedBlockHashHash <$> ch) {-# INLINE getBlockHeader #-} -instance (CasKeyType (ChainValue BlockHeader) ~ k) => ReadableTable WebBlockHeaderCas k (ChainValue BlockHeader) where +instance (HasVersion, CasKeyType (ChainValue BlockHeader) ~ k) => ReadableTable WebBlockHeaderCas k (ChainValue BlockHeader) where tableLookup (WebBlockHeaderCas db) (ChainValue cid h) = (Just . ChainValue cid <$> lookupWebBlockHeaderDb db cid h) `catch` \e -> case e of - TDB.TreeDbKeyNotFound _ -> return Nothing + TDB.TreeDbKeyNotFound _ _ -> return Nothing _ -> throwM @_ @(TDB.TreeDbException BlockHeaderDb) e {-# INLINE tableLookup #-} -instance (CasKeyType (ChainValue BlockHeader) ~ k) => Table WebBlockHeaderCas k (ChainValue BlockHeader) where +instance (HasVersion, CasKeyType (ChainValue BlockHeader) ~ k) => Table WebBlockHeaderCas k (ChainValue BlockHeader) where tableInsert (WebBlockHeaderCas db) _ (ChainValue _ h) = insertWebBlockHeaderDb db h {-# INLINE tableInsert #-} diff --git a/src/Chainweb/Time.hs b/src/Chainweb/Time.hs index 50f12a21e8..5a1098d6a1 100644 --- a/src/Chainweb/Time.hs +++ b/src/Chainweb/Time.hs @@ -73,15 +73,11 @@ module Chainweb.Time , Seconds(..) , secondsToTimeSpan , timeSpanToSeconds -, secondsToText -, secondsFromText -- * Micros , Micros(..) , microsToTimeSpan , timeSpanToMicros -, microsToText -, microsFromText -- * Math, constants , add @@ -97,7 +93,6 @@ module Chainweb.Time import Control.DeepSeq import Control.Monad ((<$!>)) -import Control.Monad.Catch import Data.Aeson (FromJSON, ToJSON) import Data.Data @@ -105,7 +100,6 @@ import Data.Hashable (Hashable) import Data.Int import qualified Data.Memory.Endian as BA import Data.Ratio -import qualified Data.Text as T import Data.Time import Data.Time.Clock.POSIX import Data.Time.Clock.System @@ -179,7 +173,7 @@ addTimeSpan (TimeSpan a) (TimeSpan b) = TimeSpan (a + b) {-# INLINE addTimeSpan #-} divTimeSpan :: Integral a => Integral b => TimeSpan b -> a -> TimeSpan b -divTimeSpan (TimeSpan a) s = TimeSpan $ a `div` (int s) +divTimeSpan (TimeSpan a) s = TimeSpan $ a `div` int s {-# INLINE divTimeSpan #-} -- -------------------------------------------------------------------------- -- @@ -323,6 +317,7 @@ newtype Seconds = Seconds Int64 deriving anyclass (Hashable, NFData) deriving newtype (FromJSON, ToJSON) deriving newtype (Num, Enum, Real, Integral) + deriving newtype (HasTextRepresentation) deriving J.Encode via (J.Aeson Int64) secondsToTimeSpan :: Num a => Seconds -> TimeSpan a @@ -333,20 +328,6 @@ timeSpanToSeconds :: Integral a => TimeSpan a -> Seconds timeSpanToSeconds (TimeSpan us) = Seconds $! int $ us `div` 1000000 {-# INLINE timeSpanToSeconds #-} -secondsToText :: Seconds -> T.Text -secondsToText (Seconds s) = sshow s -{-# INLINE secondsToText #-} - -secondsFromText :: MonadThrow m => T.Text -> m Seconds -secondsFromText = fmap Seconds . treadM -{-# INLINABLE secondsFromText #-} - -instance HasTextRepresentation Seconds where - toText = secondsToText - {-# INLINE toText #-} - fromText = secondsFromText - {-# INLINE fromText #-} - -- -------------------------------------------------------------------------- -- -- Microseconds @@ -357,6 +338,7 @@ newtype Micros = Micros Int64 deriving anyclass (Hashable, NFData) deriving newtype (Num, Integral, Real, AdditiveGroup, AdditiveMonoid, AdditiveSemigroup) deriving newtype (ToJSON, FromJSON) + deriving newtype (HasTextRepresentation) deriving J.Encode via (J.Aeson Int64) microsToTimeSpan :: Num a => Micros -> TimeSpan a @@ -364,19 +346,6 @@ microsToTimeSpan (Micros us) = scaleTimeSpan us microsecond {-# INLINE microsToTimeSpan #-} timeSpanToMicros :: Integral a => TimeSpan a -> Micros -timeSpanToMicros (TimeSpan us) = Micros $! int $ us +timeSpanToMicros (TimeSpan us) = Micros $! int us {-# INLINE timeSpanToMicros #-} -microsToText :: Micros -> T.Text -microsToText (Micros us) = sshow us -{-# INLINE microsToText #-} - -microsFromText :: MonadThrow m => T.Text -> m Micros -microsFromText = fmap Micros . treadM -{-# INLINABLE microsFromText #-} - -instance HasTextRepresentation Micros where - toText = microsToText - {-# INLINE toText #-} - fromText = microsFromText - {-# INLINABLE fromText #-} diff --git a/src/Chainweb/TreeDB.hs b/src/Chainweb/TreeDB.hs index 29340cef30..62df5ffbf8 100644 --- a/src/Chainweb/TreeDB.hs +++ b/src/Chainweb/TreeDB.hs @@ -2,6 +2,7 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} @@ -62,7 +63,6 @@ module Chainweb.TreeDB , lookupM , lookupRankedM , lookupStreamM -, lookupParentM -- * Misc Utils , forkEntry @@ -120,14 +120,14 @@ import Chainweb.Utils.Paging -- Exceptions data TreeDbException db - = TreeDbParentMissing (DbEntry db) - | TreeDbKeyNotFound (DbKey db) + = TreeDbParentMissing (DbEntry db) T.Text + | TreeDbKeyNotFound (DbKey db) T.Text | TreeDbInvalidRank (DbEntry db) | TreeDbAncestorMissing (DbEntry db) Natural T.Text instance (Show (DbEntry db), Show (DbKey db)) => Show (TreeDbException db) where - show (TreeDbParentMissing e) = "TreeDbParentMissing: " ++ show e - show (TreeDbKeyNotFound e) = "TreeDbKeyNotFound: " ++ show e + show (TreeDbParentMissing e msg) = "TreeDbParentMissing: " ++ show e ++ ". " ++ T.unpack msg + show (TreeDbKeyNotFound e msg) = "TreeDbKeyNotFound: " ++ show e <> ". " ++ T.unpack msg show (TreeDbInvalidRank e) = "TreeDbInvalidRank: " ++ show e show (TreeDbAncestorMissing e r msg) = "TreeDbAncestorMissing: entry " ++ show e @@ -172,10 +172,12 @@ _getMaxRank (MaxRank (Max r)) = r newtype LowerBound k = LowerBound { _getLowerBound :: k } deriving stock (Eq, Show, Ord, Generic) deriving anyclass (Hashable) + deriving (Functor, Foldable, Traversable) newtype UpperBound k = UpperBound { _getUpperBound :: k } deriving stock (Eq, Show, Ord, Generic) deriving anyclass (Hashable) + deriving (Functor, Foldable, Traversable) data BranchBounds db = BranchBounds { _branchBoundsLower :: !(HS.HashSet (LowerBound (DbKey db))) @@ -206,6 +208,7 @@ instance class ( Show e , Show (Key e) + , HasTextRepresentation (Key e) , Eq e , Eq (Key e) , Hashable e @@ -235,6 +238,9 @@ class (Typeable db, TreeDbEntry (DbEntry db)) => TreeDb db where -- | Lookup a single entry by its key. -- + -- A missing key is reported by returning 'Nothing'. Database errors are + -- reported as exceptions. + -- -- Implementations are expected to provide \(\mathcal{O}(1)\) performance. -- -- prop> lookup db k == S.head_ (entries db k 1 Nothing Nothing) @@ -249,6 +255,9 @@ class (Typeable db, TreeDbEntry (DbEntry db)) => TreeDb db where -- Otherwise the default implementation just ignores the rank parameter -- falls back to 'lookup'. -- + -- A missing key is reported by returning 'Nothing'. Database errors are + -- reported as exceptions. + -- lookupRanked :: db -> Natural @@ -523,26 +532,30 @@ getBranch -> HS.HashSet (UpperBound (DbKey db)) -> S.Stream (Of (DbEntry db)) IO () getBranch db lowerBounds upperBounds = do - lowers <- getEntriesHs $ HS.map _getLowerBound lowerBounds - uppers <- getEntriesHs $ HS.map _getUpperBound upperBounds + lowers <- liftIO $ getEntriesHs _getLowerBound lowerBounds + uppers <- liftIO $ getEntriesHs _getUpperBound upperBounds - let mar = L.maximum $ HS.map rank (lowers <> uppers) + let mar = getMax $ fromJuste $ + foldMap' (foldMap' (Just . Max . rank)) [lowers, uppers] - go mar (active mar lowers mempty) (active mar uppers mempty) + go mar (activate mar lowers mempty) (activate mar uppers mempty) where - getEntriesHs = lift . streamToHashSet_ . lookupStream db . S.each - getParentsHs = lift . streamToHashSet_ . lookupParentStreamM GenesisParentNone db . S.each + getEntriesHs :: (a -> Key (DbEntry db)) -> HS.HashSet a -> IO (HS.HashSet (DbEntry db)) + getEntriesHs f = streamToHashSet_ . lookupStream db . S.map f . S.each + getParentsHs = streamToHashSet_ . lookupParentStreamM GenesisParentNone db . S.each + -- The newly active members of the set after advancing the highest ones + -- downwards. -- prop> all ((==) r . rank) $ snd (active r s c) -- - active + activate :: Natural -> HS.HashSet (DbEntry db) -> HS.HashSet (DbEntry db) -> (HS.HashSet (DbEntry db), HS.HashSet (DbEntry db)) - active r s c = - let (a, b) = hsPartition (\x -> rank x < r) s - in (a, c <> b) + activate r inactive active = + let (stillInactive, newlyActive) = hsPartition (\x -> rank x < r) inactive + in (stillInactive, active <> newlyActive) -- | The size of the input sets decreases monotonically. Space complexity is -- linear in the input and constant in the output size. @@ -552,15 +565,15 @@ getBranch db lowerBounds upperBounds = do -> (HS.HashSet (DbEntry db), HS.HashSet (DbEntry db)) -> (HS.HashSet (DbEntry db), HS.HashSet (DbEntry db)) -> S.Stream (Of (DbEntry db)) IO () - go r (ls0, ls1) (us0, us1) - | HS.null us0 && HS.null us1 = return () + go r (lowerInactive, lowerActive) (upperInactive, upperActive) + | HS.null upperInactive && HS.null upperActive = return () | otherwise = do - let us1' = us1 `HS.difference` ls1 - mapM_ S.yield us1' - us1p <- getParentsHs us1' - ls1p <- getParentsHs ls1 + let upperActiveFiltered = upperActive `HS.difference` lowerActive + mapM_ S.yield upperActiveFiltered + upperActive' <- liftIO $ getParentsHs upperActiveFiltered + lowerActive' <- liftIO $ getParentsHs lowerActive let r' = pred r - go r' (active r' ls0 ls1p) (active r' us0 us1p) + go r' (activate r' lowerInactive lowerActive') (activate r' upperInactive upperActive') hsPartition :: Hashable a @@ -640,8 +653,8 @@ lookupM -> DbKey db -> IO (DbEntry db) lookupM db k = lookup db k >>= \case - Nothing -> throwM $ TreeDbKeyNotFound @db k - (Just !x) -> return x + Nothing -> throwM $ TreeDbKeyNotFound @db k $ "lookupM " <> toText k + Just !x -> return x {-# INLINEABLE lookupM #-} lookupRankedM @@ -652,8 +665,8 @@ lookupRankedM -> DbKey db -> IO (DbEntry db) lookupRankedM db r k = lookupRanked db r k >>= \case - Nothing -> throwM $ TreeDbKeyNotFound @db k - (Just !x) -> return x + Nothing -> throwM $ TreeDbKeyNotFound @db k $ "lookupRankedM " <> sshow r <> "." <> toText k + Just !x -> return x {-# INLINEABLE lookupRankedM #-} -- | Lookup all entries in a stream of database keys and return the stream @@ -700,8 +713,8 @@ lookupParentM g db e = case parent e of _ -> throwM $ InternalInvariantViolation "Chainweb.TreeDB.lookupParentM: Called getParentEntry on genesis block" Just p -> lookup db p >>= \case - Nothing -> throwM $ TreeDbParentMissing @db e - (Just !x) -> return x + Nothing -> throwM $ TreeDbParentMissing @db e ("lookupParentM " <> toText p) + Just !x -> return x -- | Replace all entries in the stream by their parent entries. -- If the genesis block is part of the stream it is replaced by itself. @@ -720,8 +733,8 @@ lookupParentStreamM g db = S.mapMaybeM $ \e -> case parent e of GenesisParentThrow -> throwM $ InternalInvariantViolation "Chainweb.TreeDB.lookupParentStreamM: Called getParentEntry on genesis block. Most likely this means that the genesis headers haven't been generated correctly. If you are using a development or testing chainweb version consider resetting the databases." Just p -> lookup db p >>= \case - Nothing -> throwM $ TreeDbParentMissing @db e - (Just !x) -> return (Just x) + Nothing -> throwM $ TreeDbParentMissing @db e $ "lookupParentStreamM " <> toText p + Just !x -> return (Just x) -- | Interpret a given `BlockHeaderDb` as a native Haskell `Tree`. Should be -- used only for debugging purposes. @@ -809,7 +822,7 @@ collectForkBlocks -> IO (DbEntry db, Vector (DbEntry db), Vector (DbEntry db)) collectForkBlocks db lastHeader newHeader = do (oldL, newL) <- go (branchDiff db lastHeader newHeader) ([], []) - when (null oldL) $ throwM $ TreeDbParentMissing @db lastHeader + when (null oldL) $ throwM $ TreeDbParentMissing @db lastHeader "collectForkBlocks: no fork point" let !common = unsafeHead "Chainweb.TreeDB.collectForkBlocks.common" oldL let !old = V.fromList $ unsafeTail "Chainweb.TreeDB.collectForkBlocks.old" oldL let !new = V.fromList $ unsafeTail "Chainweb.TreeDB.collectForkBlocks.new" newL @@ -1042,9 +1055,9 @@ ancestorOfEntry -> IO Bool ancestorOfEntry db h ctx = lookup db h >>= \case Nothing -> return False - Just lh -> seekAncestor db ctx (rank lh) >>= \case + Just !lh -> seekAncestor db ctx (rank lh) >>= \case Nothing -> return False - Just x -> return $ key x == h + Just !x -> return $ key x == h -- | @ancestorOfEntry db h ctx@ returns @True@ if @h@ is an ancestor of @ctx@ -- in @db@. diff --git a/src/Chainweb/Utils.hs b/src/Chainweb/Utils.hs index b33a2409e5..bb47b949b7 100644 --- a/src/Chainweb/Utils.hs +++ b/src/Chainweb/Utils.hs @@ -1,6 +1,7 @@ {-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} +{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE DeriveAnyClass #-} @@ -17,11 +18,13 @@ {-# LANGUAGE MagicHash #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} {-# OPTIONS_GHC -fno-warn-orphans #-} {-# OPTIONS_GHC -fno-warn-deprecations #-} @@ -85,9 +88,6 @@ module Chainweb.Utils , interleaveIO , mutableVectorFromList , timeoutYield -, showClientError -, showHTTPRequestException -, matchOrDisplayException -- * Encoding and Serialization , EncodingException(..) @@ -100,7 +100,7 @@ module Chainweb.Utils , tread , treadM , HasTextRepresentation(..) -, eitherFromText +, fromTextM , unsafeFromText , parseM , parseText @@ -113,6 +113,7 @@ module Chainweb.Utils , decodeB64UrlText , encodeB64UrlNoPadding , encodeB64UrlNoPaddingText +, b64UrlNoPaddingPrism , b64UrlNoPaddingTextEncoding , decodeB64UrlNoPaddingText @@ -183,6 +184,7 @@ module Chainweb.Utils , reverseStream , foldChunksM , foldChunksM_ +, mergeN , progress -- * Type Level @@ -192,8 +194,10 @@ module Chainweb.Utils , intVal_ -- * Resource Management -, concurrentWith +, allocateConcurrently , withLink +, withAsyncR +, resourceToBracket , concurrentlies , concurrentlies_ @@ -240,13 +244,39 @@ module Chainweb.Utils , unsafeTail , withEarlyReturn +-- * Bits and Bytes +, Bytes(..) +, fromByteString +, toByteString +, buildByteString +, ByteSwap(..) +, be +, le +, peekByteString +, peekByteArray16 +, peekByteArray32 +, peekByteArray64 + +-- * Exception Rendering +, PureHandler(..) +, handleException +, type Renderer +, pattern Renderer +, renderException +, renderExceptionJson +, displayExceptionText +, showClientError +, showHTTPRequestException +, matchOrDisplayException , ResponseBodyTooLarge(..) ) where -import Configuration.Utils hiding (Error, Lens) +import Chainweb.Utils.Resource +import Chainweb.Utils.Tuple +import Chainweb.Utils.UnitPrefixes +import Configuration.Utils hiding (Error, Lens) import Control.Concurrent (threadDelay) -import Control.Concurrent.Async import Control.Concurrent.MVar import Control.Concurrent.TokenBucket import Control.DeepSeq @@ -258,11 +288,11 @@ import Control.Monad.Cont import Control.Monad.IO.Class import Control.Monad.Primitive import Control.Monad.Reader as Reader - import Data.Aeson.Text (encodeToLazyText) import Data.Aeson.Types qualified as Aeson +import Data.Array.Byte import Data.Attoparsec.Text qualified as A -import Data.Bifunctor +import Data.Bifunctor (first) import Data.Bool (bool) import Data.ByteString (ByteString) import Data.ByteString qualified as B @@ -271,12 +301,17 @@ import Data.ByteString.Base64.URL qualified as B64U import Data.ByteString.Builder qualified as BB import Data.ByteString.Char8 qualified as B8 import Data.ByteString.Lazy qualified as BL +import Data.ByteString.Short qualified as BS +import Data.ByteString.Unsafe qualified as B +import Data.Coerce import Data.Csv qualified as CSV -import Data.Decimal +import Data.Decimal hiding (allocate) +import Data.DoubleWord import Data.Functor.Of import Data.HashMap.Strict qualified as HM import Data.HashSet qualified as HS import Data.Hashable +import Data.Int import Data.String (IsString(..)) import Data.Text qualified as T import Data.Text.Encoding qualified as T @@ -286,82 +321,35 @@ import Data.Time import Data.Vector qualified as V import Data.Vector.Mutable qualified as MV import Data.Word - -import GHC.Exts (proxy#) +import Foreign (Storable (sizeOf), peek, castPtr) +import GHC.ByteOrder +import GHC.Exts (proxy#, byteSwap#, indexWord64Array#, indexWord16Array#, indexWord32Array#) import GHC.Generics import GHC.Stack (HasCallStack, callStack, prettyCallStack) import GHC.TypeLits (KnownSymbol, Symbol, symbolVal') import GHC.TypeLits qualified as Int (KnownNat, natVal') import GHC.TypeNats qualified as Nat (KnownNat, natVal') - +import GHC.Word (Word(W#), Word64 (W64#), Word16 (..), Word32 (..)) import Network.Connection qualified as HTTP import Network.HTTP.Client qualified as HTTP import Network.HTTP.Client.TLS qualified as HTTP import Network.HTTP.Types qualified as HTTP import Network.Socket hiding (Debug) import Network.TLS qualified as HTTP - +import Network.URI import Numeric.Natural - import Options.Applicative qualified as O - import Servant.Client qualified - import Streaming qualified as S (concats, effect, inspect) import Streaming.Prelude qualified as S - -import System.IO.Unsafe (unsafeInterleaveIO, unsafePerformIO) +import System.IO.Unsafe (unsafeInterleaveIO, unsafePerformIO, unsafeDupablePerformIO) import System.LogLevel import System.Random.MWC qualified as Prob import System.Random.MWC.Probability qualified as Prob import System.Timeout qualified as Timeout - import Text.Printf (printf) import Text.Read (readEither) --- -------------------------------------------------------------------------- -- --- SI unit prefixes - --- | cf. https://www.nist.gov/pml/owm/metric-si-prefixes --- -deci, centi, milli, micro, nano, pico, femto, atto, zepto, yocto :: Fractional a => a -deci = 10 ^^ (-1 :: Int) -centi = 10 ^^ (-2 :: Int) -milli = 10 ^^ (-3 :: Int) -micro = 10 ^^ (-6 :: Int) -nano = 10 ^^ (-9 :: Int) -pico = 10 ^^ (-12 :: Int) -femto = 10 ^^ (-15 :: Int) -atto = 10 ^^ (-18 :: Int) -zepto = 10 ^^ (-21 :: Int) -yocto = 10 ^^ (-24 :: Int) - --- | cf. https://www.nist.gov/pml/owm/metric-si-prefixes --- -deka, hecto, kilo, mega, giga, tera, peta, exa, zetta, yotta :: Num a => a -deka = 10 ^ (1 :: Int) -hecto = 10 ^ (2 :: Int) -kilo = 10 ^ (3 :: Int) -mega = 10 ^ (6 :: Int) -giga = 10 ^ (9 :: Int) -tera = 10 ^ (12 :: Int) -peta = 10 ^ (15 :: Int) -exa = 10 ^ (18 :: Int) -zetta = 10 ^ (21 :: Int) -yotta = 10 ^ (24 :: Int) - --- | IEC 60027-X unit prefixes for binary bases. --- --- cf. https://www.nist.gov/pml/special-publication-811/nist-guide-si-appendix-d-bibliography#05 --- -kibi, mebi, gibi, tebi, pebi, exbi:: Num a => a -kibi = 1024 ^ (1 :: Int) -mebi = 1024 ^ (2 :: Int) -gibi = 1024 ^ (3 :: Int) -tebi = 1024 ^ (4 :: Int) -pebi = 1024 ^ (5 :: Int) -exbi = 1024 ^ (6 :: Int) - -- -------------------------------------------------------------------------- -- -- Misc @@ -489,7 +477,7 @@ class IxedGet a where ixg :: Index a -> Fold a (IxValue a) default ixg :: Ixed a => Index a -> Fold a (IxValue a) - ixg i = ix i + ixg = ix {-# INLINE ixg #-} -- | A strict version of 'ix'. It requires a 'Monad' constraint on the context. @@ -539,21 +527,25 @@ sshow = fromString . show -- | Read a value from a textual encoding using its 'Read' instance. Returns and -- textual error message if the operation fails. -- -tread :: Read a => T.Text -> Either T.Text a -tread = first T.pack . readEither . T.unpack +tread :: Read a => T.Text -> Either SomeException a +tread = first (toException . TextFormatException . T.pack) . readEither . T.unpack {-# INLINE tread #-} -- | Throws 'TextFormatException' on failure. -- treadM :: MonadThrow m => Read a => T.Text -> m a -treadM = fromEitherM . first TextFormatException . tread +treadM = fromEitherM . tread {-# INLINE treadM #-} -- | Class of types that have an textual representation. -- class HasTextRepresentation a where toText :: a -> T.Text - fromText :: MonadThrow m => T.Text -> m a + fromText :: T.Text -> Either SomeException a + +fromTextM :: MonadThrow m => HasTextRepresentation a => T.Text -> m a +fromTextM = fromEitherM . fromText +{-# INLINE fromTextM #-} instance HasTextRepresentation T.Text where toText = id @@ -570,31 +562,73 @@ instance HasTextRepresentation [Char] where instance HasTextRepresentation Int where toText = sshow {-# INLINE toText #-} - fromText = treadM + fromText = tread {-# INLINE fromText #-} instance HasTextRepresentation Integer where toText = sshow {-# INLINE toText #-} - fromText = treadM + fromText = tread {-# INLINE fromText #-} instance HasTextRepresentation Natural where toText = sshow {-# INLINE toText #-} - fromText = treadM + fromText = tread {-# INLINE fromText #-} instance HasTextRepresentation Word where toText = sshow {-# INLINE toText #-} - fromText = treadM + fromText = tread + {-# INLINE fromText #-} + +instance HasTextRepresentation Word8 where + toText = sshow + {-# INLINE toText #-} + fromText = tread + {-# INLINE fromText #-} + +instance HasTextRepresentation Word16 where + toText = sshow + {-# INLINE toText #-} + fromText = tread + {-# INLINE fromText #-} + +instance HasTextRepresentation Word32 where + toText = sshow + {-# INLINE toText #-} + fromText = tread {-# INLINE fromText #-} instance HasTextRepresentation Word64 where toText = sshow {-# INLINE toText #-} - fromText = treadM + fromText = tread + {-# INLINE fromText #-} + +instance HasTextRepresentation Int8 where + toText = sshow + {-# INLINE toText #-} + fromText = tread + {-# INLINE fromText #-} + +instance HasTextRepresentation Int16 where + toText = sshow + {-# INLINE toText #-} + fromText = tread + {-# INLINE fromText #-} + +instance HasTextRepresentation Int32 where + toText = sshow + {-# INLINE toText #-} + fromText = tread + {-# INLINE fromText #-} + +instance HasTextRepresentation Int64 where + toText = sshow + {-# INLINE toText #-} + fromText = tread {-# INLINE fromText #-} instance HasTextRepresentation UTCTime where @@ -602,31 +636,35 @@ instance HasTextRepresentation UTCTime where {-# INLINE toText #-} fromText d = case parseTimeM False defaultTimeLocale fmt (T.unpack d) of - Nothing -> throwM $ TextFormatException $ "failed to parse utc date " <> sshow d + Nothing -> throwM $ TextFormatException ("failed to parse utc date " <> d) Just x -> return x where fmt = iso8601DateTimeFormat {-# INLINE fromText #-} --- | Decode a value from its textual representation. +-- | Textual representation for /absolute/ URIs. -- -eitherFromText - :: HasTextRepresentation a - => T.Text - -> Either String a -eitherFromText = either f return . fromText - where - f e = Left $ case fromException e of - Just (TextFormatException err) -> T.unpack err - _ -> displayException e -{-# INLINE eitherFromText #-} +instance HasTextRepresentation URI where + toText uri = T.pack $ uriToString id uri "" + fromText t = case parseAbsoluteURI (T.unpack t) of + Nothing -> throwM $ TextFormatException ("failed to parse URI " <> t) + Just u -> return u + {-# INLINE toText #-} + {-# INLINE fromText #-} -- | Unsafely decode a value rom its textual representation. It is an program -- error if decoding fails. +-- Marked NOINLINE heuristically, because usually the runtime performance is not +-- very important and if applied to a lot of literals at once (as in the +-- *Payload files) it can result in severe code blowup, slowing compilation. -- unsafeFromText :: HasCallStack => HasTextRepresentation a => T.Text -> a -unsafeFromText = fromJuste . fromText -{-# INLINE unsafeFromText #-} +unsafeFromText t = case fromText t of + Right a -> a + Left e -> error $ "Chainweb.Utils.unsafeFromText" + <> ": failed to parse" <> T.unpack t + <> "; " <> displayException e +{-# NOINLINE unsafeFromText #-} -- | Run a 'A.Parser' on a text input. All input must be consume by the parser. -- A 'TextFormatException' is thrown if parsing fails. @@ -711,6 +749,11 @@ encodeB64UrlNoPaddingText :: B.ByteString -> T.Text encodeB64UrlNoPaddingText = T.dropWhileEnd (== '=') . T.decodeUtf8 . B64U.encode {-# INLINE encodeB64UrlNoPaddingText #-} +-- | A prism for encoding/decoding unpadded base64-url as/from text. +-- +b64UrlNoPaddingPrism :: Prism' T.Text B.ByteString +b64UrlNoPaddingPrism = prism' encodeB64UrlNoPaddingText decodeB64UrlNoPaddingText + -- | Encode a binary value to a textual base64-url without padding -- representation. -- @@ -809,7 +852,7 @@ parseJsonFromText => String -> Value -> Aeson.Parser a -parseJsonFromText l = withText l $! either fail return . eitherFromText +parseJsonFromText l = withText l $! either (fail . displayException) return . fromText -- | A newtype wrapper for derving ToJSON and FromJSON instances via -- a 'HasTextRepresentation' instance @@ -827,7 +870,7 @@ instance ( KnownSymbol s , HasTextRepresentation a ) - => FromJSON (JsonTextRepresentation s a) + => FromJSON (JsonTextRepresentation s a) where parseJSON = fmap JsonTextRepresentation . parseJsonFromText (symbolVal_ @s) {-# INLINE parseJSON #-} @@ -840,7 +883,7 @@ newtype CsvDecimal = CsvDecimal { _csvDecimal :: Decimal } instance CSV.FromField CsvDecimal where parseField s = do - cs <- either (fail . show) pure $ T.unpack <$> T.decodeUtf8' s + cs <- either (fail . show) (pure . T.unpack) (T.decodeUtf8' s) either fail pure $ readEither cs {-# INLINE parseField #-} @@ -1036,14 +1079,14 @@ tryAllSynchronous = trySynchronous -- -- An info-level message is logged when processing starts and stops. -- -runForever :: (LogLevel -> T.Text -> IO ()) -> T.Text -> IO () -> IO () +runForever :: (LogLevel -> T.Text -> IO ()) -> T.Text -> IO () -> IO a runForever logfun name a = mask $ \umask -> do logfun Debug $ "start " <> name let go = do forever (umask a) `catchAllSynchronous` \e -> logfun Error $ name <> " failed: " <> sshow e <> ". Restarting ..." go - void go `finally` logfun Info (name <> " stopped") + go `finally` logfun Debug (name <> " stopped") -- | Repeatedly run a computation 'forever' at the given rate until it is -- stopped by receiving 'SomeAsyncException'. @@ -1062,7 +1105,7 @@ runForeverThrottled -> Word64 -- ^ rate limit (usec / call) -> IO () - -> IO () + -> IO a runForeverThrottled logfun name burst rate a = mask $ \umask -> do tokenBucket <- newTokenBucket logfun Debug $ "start " <> name @@ -1071,7 +1114,7 @@ runForeverThrottled logfun name burst rate a = mask $ \umask -> do forever (umask runThrottled) `catchAllSynchronous` \e -> logfun Error $ name <> " failed: " <> sshow e <> ". Restarting ..." go - void go `finally` logfun Info (name <> " stopped") + go `finally` logfun Debug (name <> " stopped") -- -------------------------------------------------------------------------- -- -- Configuration wrapper to enable and disable components @@ -1253,6 +1296,19 @@ foldChunksM_ foldChunksM_ f seed = fmap (fst . S.lazily) . foldChunksM f seed {-# INLINE foldChunksM_ #-} +-- | Left-biased k-way merge of streams, using a binary tree of merges. O(n log k) where k +-- is the number of streams and n is the total elements. +mergeN :: forall m k a. (Monad m, Ord k) => (a -> k) -> [S.Stream (S.Of a) m ()] -> S.Stream (S.Of a) m () +mergeN f = go + where + go [strm] = strm + go strms = go (mergePairs strms) + where + mergePairs (a:b:xs) = + let !x = () <$ S.mergeOn f a b + in x : mergePairs xs + mergePairs xs = xs + -- | Progress reporting for long-running streams. I calls an action -- every @n@ streams items. -- @@ -1281,148 +1337,6 @@ data Codec t = Codec , codecDecode :: ByteString -> Either String t } --- -------------------------------------------------------------------------- -- --- Resource Management - --- | Bracket style resource managment uses CPS style which only supports --- sequential componsition of different allocation functions. --- --- This function is a hack that allows to allocate and deallocate several --- resources concurrently and provide them to a single inner computation. --- -concurrentWith - :: forall a b t d - . Traversable t - => (forall c . a -> (b -> IO c) -> IO c) - -- concurrent resource allocation brackets. Given a value of type @a@, - -- allocates a resource of type @b@, it provides the inner function with - -- that value, and returns the result of the inner computation. - -> (t b -> IO d) - -- inner computation - -> t a - -- traversable that provides parameters to instantiate the resource - -- allocation bracktes. - -- - -- The value must be finite and is traversed twiced! - -- - -> IO d -concurrentWith alloc inner params = do - doneVar <- newEmptyMVar - paramsWithVar <- traverse (\p -> (p,) <$> newEmptyMVar) params - results <- concurrently (mapConcurrently (concAlloc doneVar) paramsWithVar) $ do - resources <- traverse (takeMVar . snd) paramsWithVar - result <- inner resources - putMVar doneVar () - return result - return $ snd results - where - concAlloc :: MVar () -> (a, MVar b) -> IO () - concAlloc doneVar (p, var) = alloc p $ \b -> do - putMVar var b - readMVar doneVar - --- | Run an async IO action, link it back to the main thread, and return --- the async result --- -withLink :: forall a. IO a -> IO (Async a) -withLink act = do - a <- async act - link a - return a - --- | Like `sequence` for IO but concurrent -concurrentlies :: forall a. [IO a] -> IO [a] -concurrentlies = runConcurrently . traverse Concurrently - --- | Like `sequence_` for IO but concurrent -concurrentlies_ :: forall a. [IO a] -> IO () -concurrentlies_ = void . concurrentlies - --- -------------------------------------------------------------------------- -- --- Tuples - -thd :: (a,b,c) -> c -thd (_,_,c) = c -{-# INLINE thd #-} - --- -------------------------------------------------------------------------- -- --- Strict Tuple - -data T2 a b = T2 !a !b - deriving (Show, Eq, Ord, Generic, NFData, Functor) - -instance (Semigroup a, Semigroup b) => Semigroup (T2 a b) where - T2 a b <> T2 a' b' = T2 (a <> a') (b <> b') - -instance (Monoid a, Monoid b) => Monoid (T2 a b) where - mappend = (<>) - mempty = T2 mempty mempty - -instance Bifunctor T2 where - bimap f g (T2 a b) = T2 (f a) (g b) - {-# INLINE bimap #-} -instance Field1 (T2 a b) (T2 x b) a x where - _1 = lens (\(T2 a _b) -> a) (\(T2 _a b) x -> T2 x b) -instance Field2 (T2 a b) (T2 a x) b x where - _2 = lens (\(T2 _a b) -> b) (\(T2 a _b) x -> T2 a x) - -data T3 a b c = T3 !a !b !c - deriving (Show, Eq, Ord, Generic, NFData, Functor) - -instance Bifunctor (T3 a) where - bimap f g (T3 a b c) = T3 a (f b) (g c) - {-# INLINE bimap #-} -instance Field1 (T3 a b c) (T3 x b c) a x where - _1 = lens (\(T3 a _b _c) -> a) (\(T3 _a b c) x -> T3 x b c) -instance Field2 (T3 a b c) (T3 a x c) b x where - _2 = lens (\(T3 _a b _c) -> b) (\(T3 a _b c) x -> T3 a x c) -instance Field3 (T3 a b c) (T3 a b x) c x where - _3 = lens (\(T3 _a _b c) -> c) (\(T3 a b _c) x -> T3 a b x) - -data T4 a b c d = T4 !a !b !c !d - deriving (Show, Eq, Ord, Generic, NFData, Functor) - -instance Field1 (T4 a b c d) (T4 x b c d) a x where - _1 = lens (\(T4 a _b _c _d) -> a) (\(T4 _a b c d) x -> T4 x b c d) -instance Field2 (T4 a b c d) (T4 a x c d) b x where - _2 = lens (\(T4 _a b _c _d) -> b) (\(T4 a _b c d) x -> T4 a x c d) -instance Field3 (T4 a b c d) (T4 a b x d) c x where - _3 = lens (\(T4 _a _b c _d) -> c) (\(T4 a b _c d) x -> T4 a b x d) -instance Field4 (T4 a b c d) (T4 a b c x) d x where - _4 = lens (\(T4 _a _b _c d) -> d) (\(T4 a b c _d) x -> T4 a b c x) - -sfst :: T2 a b -> a -sfst (T2 a _) = a -{-# INLINE sfst #-} - -ssnd :: T2 a b -> b -ssnd (T2 _ b) = b -{-# INLINE ssnd #-} - -scurry :: (T2 a b -> c) -> a -> b -> c -scurry f a b = f (T2 a b) -{-# INLINE scurry #-} - -suncurry :: (a -> b -> c) -> T2 a b -> c -suncurry k (T2 a b) = k a b -{-# INLINE suncurry #-} - -uncurry3 :: (a -> b -> c -> d) -> (a, b, c) -> d -uncurry3 k (a, b, c) = k a b c -{-# INLINE uncurry3 #-} - -suncurry3 :: (a -> b -> c -> d) -> T3 a b c -> d -suncurry3 k (T3 a b c) = k a b c -{-# INLINE suncurry3 #-} - -_T2 :: Iso (T2 a b) (T2 s t) (a,b) (s,t) -_T2 = iso (\(T2 a b) -> (a,b)) (uncurry T2) -{-# INLINE _T2 #-} - -_T3 :: Iso (T3 a b c) (T3 s t u) (a,b,c) (s,t,u) -_T3 = iso (\(T3 a b c) -> (a,b,c)) (\(a,b,c) -> T3 a b c) -{-# INLINE _T3 #-} - -- -------------------------------------------------------------------------- -- -- Approximate thread delays approximately :: Integral a => a -> Prob.GenIO -> IO a @@ -1450,8 +1364,7 @@ approximateThreadDelay d = withMVar threadDelayRng (approximately d) manager :: Int -> IO HTTP.Manager manager micros = HTTP.newManager - $ setManagerRequestTimeout micros - $ HTTP.tlsManagerSettings + $ setManagerRequestTimeout micros HTTP.tlsManagerSettings unsafeManager :: Int -> IO HTTP.Manager unsafeManager micros = HTTP.newTlsManagerWith @@ -1515,6 +1428,146 @@ hostArch = "x86_64" hostArch = "unknown" #endif +-- -------------------------------------------------------------------------- -- +-- Bits and Bytes + +-- | Class of types that can be coerced to ByteArray +-- +-- Morally this should have Coercible ByteArray as superclass. However, +-- Coercible dictionaries are not propagated by GHC in the same way like oher +-- constraints. In particular, it is available only if the constructor for the +-- respective type is brought into scope. +-- +class Bytes a where + byteArray :: a -> ByteArray + + default byteArray :: Coercible a ByteArray => a -> ByteArray + byteArray = coerce + {-# INLINE byteArray #-} + +instance Bytes ByteArray where +instance Bytes BS.ShortByteString where + +bytes :: Coercible ByteArray b => Bytes a => a -> b +bytes = coerce . byteArray +{-# INLINE bytes #-} + +class ByteSwap a where swap :: a -> a +instance ByteSwap Word where swap (W# w#) = W# (byteSwap# w#) +instance ByteSwap Word16 where swap = byteSwap16 +instance ByteSwap Word32 where swap = byteSwap32 +instance ByteSwap Word64 where swap = byteSwap64 +instance ByteSwap Word128 where swap (Word128 a b) = Word128 (swap b) (swap a) +instance ByteSwap Word256 where swap (Word256 a b) = Word256 (swap b) (swap a) + +toByteString :: Bytes a => a -> B.ByteString +toByteString = BS.fromShort . bytes +{-# INLINE toByteString #-} + +fromByteString :: Coercible ByteArray a => B.ByteString -> a +fromByteString = coerce . BS.toShort +{-# INLINE fromByteString #-} + +be :: ByteSwap a => a -> a +be + | targetByteOrder == BigEndian = id + | otherwise = swap +{-# INLINE be #-} + +le :: ByteSwap a => a -> a +le + | targetByteOrder == LittleEndian = id + | otherwise = swap +{-# INLINE le #-} + +buildByteString :: BB.Builder -> B.ByteString +buildByteString = BL.toStrict . BB.toLazyByteString +{-# INLINE buildByteString #-} + +peekByteString + :: forall w + . Storable w + => B.ByteString + -> Either T.Text w +peekByteString bs + | l < s = Left $ "peekByteString: size of input bytestring to small" + <> ". Expected: " <> sshow s + <> ". Actual: " <> sshow l + | otherwise = Right $ unsafeDupablePerformIO $ + B.unsafeUseAsCStringLen bs $ peek . castPtr . fst + where + l = B.length bs + s = sizeOf @w undefined + +peekByteArray16 + :: Bytes b + => b + -> Either T.Text Word16 +peekByteArray16 b + | l < 2 = Left $ "toWordBe: size of input bytestring to small" + <> ". Expected: 2" + <> ". Actual: " <> sshow l + | otherwise = Right $ W16# (indexWord16Array# s# 0#) + where + s = bytes b + !(BS.SBS s#) = coerce s + l = BS.length s + +peekByteArray32 + :: Bytes b + => b + -> Either T.Text Word32 +peekByteArray32 b + | l < 4 = Left $ "toWordBe: size of input bytestring to small" + <> ". Expected: 4" + <> ". Actual: " <> sshow l + | otherwise = Right $ W32# (indexWord32Array# s# 0#) + where + s = bytes b + !(BS.SBS s#) = coerce s + l = BS.length s + +peekByteArray64 + :: Bytes b + => b + -> Either T.Text Word64 +peekByteArray64 b + | l < 8 = Left $ "toWordBe: size of input bytestring to small" + <> ". Expected: 8" + <> ". Actual: " <> sshow l + | otherwise = Right $ W64# (indexWord64Array# s# 0#) + where + s = bytes b + !(BS.SBS s#) = coerce s + l = BS.length s + +-- -- | Convert a 'Word64' to a 'ByteArray'. +-- -- +-- word64ToByteArray :: Word64 -> ByteArray +-- word64ToByteArray !(W64# h) = ByteArray $ runRW# $ \s0 -> do +-- case newByteArray# 8# s0 of +-- (# s1, mba #) -> case writeWord64Array# mba 0# h s1 of +-- s2 -> case unsafeFreezeByteArray# mba s2 of +-- (# _, ba #) -> ba +-- +-- -- | Convert a 'Word32' to a 'ByteArray'. +-- -- +-- word32ToByteArray :: Word32 -> ByteArray +-- word32ToByteArray !(W32# h) = ByteArray $ runRW# $ \s0 -> do +-- case newByteArray# 4# s0 of +-- (# s1, mba #) -> case writeWord32Array# mba 0# h s1 of +-- s2 -> case unsafeFreezeByteArray# mba s2 of +-- (# _, ba #) -> ba +-- +-- -- | Convert a 'Word' to a 'ByteArray'. +-- -- +-- wordToByteArray :: Word -> ByteArray +-- wordToByteArray !(W# h) = ByteArray $ runRW# $ \s0 -> do +-- case newByteArray# (wordS s0 of +-- (# s1, mba #) -> case writeWord32Array# mba 0# h s1 of +-- s2 -> case unsafeFreezeByteArray# mba s2 of +-- (# _, ba #) -> ba + -- -------------------------------------------------------------------------- -- -- Debugging Tools @@ -1549,6 +1602,86 @@ timeoutYield :: Int -> IO a -> IO (Maybe a) timeoutYield time act = Timeout.timeout time (act <* threadDelay 1) +unsafeHead :: HasCallStack => String -> [a] -> a +unsafeHead msg = \case + x : _ -> x + [] -> error $ "unsafeHead: empty list: " <> msg + +unsafeTail :: HasCallStack => String -> [a] -> [a] +unsafeTail msg = \case + _ : xs -> xs + [] -> error $ "unsafeTail: empty list: " <> msg + +-- this is callCC but with a more permissive type signature, allowing the early return to +-- "return" values of any type, whenever it's used +withEarlyReturn :: ((forall b. a -> ContT r m b) -> ContT r m a) -> ContT r m a +withEarlyReturn f = ContT $ \ c -> runContT (f (\ x -> ContT $ \ _ -> c x)) c +{-# INLINE withEarlyReturn #-} + +-- -------------------------------------------------------------------------- -- +-- Exception rendering + +data PureHandler c a = forall e . (c e, Exception e) => PureHandler (e -> a) + +handlePure + :: (SomeException -> a) + -> [PureHandler c a] + -> SomeException + -> a +handlePure fallback handlers e = case asum $ apply <$> handlers of + Just r -> r + Nothing -> fallback e + where + apply (PureHandler f) = case fromException e of + Just e' -> Just $ f e' + Nothing -> Nothing + +-- | A pure exception handler, that holds a pure function that can be applied to +-- an exception of a specific type. +-- +-- Note, that unlike the handlers in `Control.Exception`, this handler does not +-- not catch exceptions. +-- +type ExceptionHandler a = PureHandler Exception a + +pattern ExceptionHandler :: () => (c e, Exception e) => (e -> a) -> PureHandler c a +pattern ExceptionHandler f = PureHandler f + +-- | Handle a given exception using a list of pure exception handlers. +-- +-- The first matching handler is applied to the exception. If no handler matches +-- the given fallback function is applied to cocmpute the result. +-- +handleException + :: (SomeException -> a) + -> [ExceptionHandler a] + -> SomeException + -> a +handleException = handlePure + +-- | An exception handler for rendering exceptions as 'T.Text'. +-- +type Renderer = ExceptionHandler T.Text + +-- | Pattern synonym for creating a 'Renderer'. +-- +pattern Renderer :: () => Exception e => (e -> a) -> ExceptionHandler a +pattern Renderer f = ExceptionHandler f +{-# COMPLETE Renderer #-} + +-- | Render an exception using a list of 'Renderer's. The first matching +-- renderer is used. If no renderer matches the exception the default +-- 'displayException' function is used to render the exception. +-- +renderException :: [Renderer] -> SomeException -> T.Text +renderException = handleException displayExceptionText + +renderExceptionJson :: [ExceptionHandler Value] -> SomeException -> Value +renderExceptionJson = handleException (String . displayExceptionText) + +displayExceptionText :: SomeException -> T.Text +displayExceptionText = T.pack . displayException + showClientError :: Servant.Client.ClientError -> T.Text showClientError (Servant.Client.FailureResponse _ resp) = "Error code " <> sshow (HTTP.statusCode $ Servant.Client.responseStatusCode resp) @@ -1583,19 +1716,3 @@ matchOrDisplayException display anyException = display specificException | otherwise = T.pack $ displayException anyException - -unsafeHead :: HasCallStack => String -> [a] -> a -unsafeHead msg = \case - x : _ -> x - [] -> error $ "unsafeHead: empty list: " <> msg - -unsafeTail :: HasCallStack => String -> [a] -> [a] -unsafeTail msg = \case - _ : xs -> xs - [] -> error $ "unsafeTail: empty list: " <> msg - --- this is callCC but with a more permissive type signature, allowing the early return to --- "return" values of any type, whenever it's used -withEarlyReturn :: ((forall b. a -> ContT r m b) -> ContT r m a) -> ContT r m a -withEarlyReturn f = ContT $ \ c -> runContT (f (\ x -> ContT $ \ _ -> c x)) c -{-# INLINE withEarlyReturn #-} diff --git a/src/Chainweb/Utils/Paging.hs b/src/Chainweb/Utils/Paging.hs index 0d371edb5a..0d923468f8 100644 --- a/src/Chainweb/Utils/Paging.hs +++ b/src/Chainweb/Utils/Paging.hs @@ -156,7 +156,7 @@ nextItemToText :: HasTextRepresentation k => NextItem k -> T.Text nextItemToText (Inclusive k) = "inclusive:" <> toText k nextItemToText (Exclusive k) = "exclusive:" <> toText k -nextItemFromText :: MonadThrow m => HasTextRepresentation k => T.Text -> m (NextItem k) +nextItemFromText :: HasTextRepresentation k => T.Text -> Either SomeException (NextItem k) nextItemFromText t = case T.break (== ':') t of (a, b) | a == "inclusive" -> Inclusive <$> fromText (T.drop 1 b) diff --git a/src/Chainweb/Utils/Resource.hs b/src/Chainweb/Utils/Resource.hs new file mode 100644 index 0000000000..42bbb72b82 --- /dev/null +++ b/src/Chainweb/Utils/Resource.hs @@ -0,0 +1,79 @@ +{-# LANGUAGE ScopedTypeVariables #-} + +-- | Resource management and concurrent initialization utilities. +module Chainweb.Utils.Resource +( allocateConcurrently, withLink, withAsyncR, resourceToBracket +, concurrentlies, concurrentlies_ +) where + +import Control.Concurrent.Async +import Control.Monad.Catch (uninterruptibleMask_) +import Control.Monad.IO.Class (liftIO) +import Control.Monad.Trans.Resource +import Data.Foldable (traverse_) +import Data.IORef (readIORef, writeIORef) + +-- -------------------------------------------------------------------------- -- +-- Resource Management + +-- | Concurrently initializes resources. +-- +-- This function is a bit of a hack that allows allocating several resources +-- concurrently and providing them to a single inner computation. +-- +allocateConcurrently + :: forall a t + . Traversable t + => t (ResourceT IO a) + -> ResourceT IO (t a) +allocateConcurrently mkResources = do + (_, resourcesAndInternalStates) <- allocate ( + -- threads inherit masking state, and allocate runs initializers masked. + forConcurrently mkResources $ \mkResource -> do + internalState <- createInternalState + -- runInternalState doesn't actually clean up the resources. + resource <- runInternalState mkResource internalState + return (resource, internalState) + ) + -- likewise finalizers are run masked. + (mapConcurrently_ (closeInternalState . snd)) + return $ fst <$> resourcesAndInternalStates + +-- | Run an async IO action, link it back to the main thread, and return +-- the async result +-- +withLink :: forall a. IO a -> IO (Async a) +withLink act = do + a <- async act + link a + return a + +-- | Spawn a thread to do the input action and kill it on exit. +withAsyncR :: IO a -> ResourceT IO (Async a) +withAsyncR act = snd <$> allocate (async act) uninterruptibleCancel + +-- | Use a ResourceT-allocated resource from @bracket@. +resourceToBracket + :: ResourceT IO a + -> (IO (a, InternalState) + , (a, InternalState) -> IO ()) +resourceToBracket res = do + let prime = do + r <- res + uninterruptibleMask_ $ do + s <- getInternalState + releaseMap <- liftIO $ readIORef s + s' <- createInternalState + liftIO $ writeIORef s =<< readIORef s' + liftIO $ writeIORef s' releaseMap + return (r, s') + + (runResourceT prime, \(_, s) -> closeInternalState s) + +-- | Like `sequence` for IO but concurrent +concurrentlies :: forall a. [IO a] -> IO [a] +concurrentlies = runConcurrently . traverse Concurrently + +-- | Like `sequence_` for IO but concurrent +concurrentlies_ :: forall a. [IO a] -> IO () +concurrentlies_ = runConcurrently . traverse_ Concurrently diff --git a/src/Chainweb/Utils/Rule.hs b/src/Chainweb/Utils/Rule.hs index b34ea328c5..c60fc25d4f 100644 --- a/src/Chainweb/Utils/Rule.hs +++ b/src/Chainweb/Utils/Rule.hs @@ -5,6 +5,8 @@ {-# language InstanceSigs #-} {-# language LambdaCase #-} {-# language TupleSections #-} +{-# language IncoherentInstances #-} +{-# LANGUAGE StandaloneDeriving #-} module Chainweb.Utils.Rule ( Rule(..) @@ -44,8 +46,9 @@ import GHC.Generics -- latest occurrence. -- data Rule h a = Above (h, a) (Rule h a) | Bottom (h, a) - deriving stock (Eq, Ord, Show, Foldable, Functor, Generic, Generic1, Traversable) + deriving stock (Eq, Ord, Foldable, Functor, Generic, Generic1, Traversable) deriving anyclass (Hashable, NFData) +deriving stock instance (Show h, Show a) => Show (Rule h a) infixr 7 `Above` @@ -93,7 +96,7 @@ ruleDropWhile _ t = t -- Leftmost fields are "below", rightmost fields are "above". data RuleZipper h a = BetweenZipper (Rule h a) [(h, a)] - deriving Show +deriving stock instance (Show h, Show a) => Show (RuleZipper h a) ruleZipperHere :: RuleZipper h a -> (h, a) ruleZipperHere (BetweenZipper r _) = ruleHead r diff --git a/src/Chainweb/Utils/Serialization.hs b/src/Chainweb/Utils/Serialization.hs index d43900ff1d..30d0726ac7 100644 --- a/src/Chainweb/Utils/Serialization.hs +++ b/src/Chainweb/Utils/Serialization.hs @@ -41,6 +41,7 @@ module Chainweb.Utils.Serialization , getShortByteString , putRawByteString , getRemainingLazyByteString + , skip -- abstract encoders and decoders , WordEncoding(..) @@ -181,6 +182,10 @@ putRawByteString = coerce (Binary.putBuilder . Builder.fromByteString) getRemainingLazyByteString :: Get BL.ByteString getRemainingLazyByteString = coerce Binary.getRemainingLazyByteString +skip :: Int -> Get () +skip = coerce . Binary.skip +{-# INLINE skip #-} + -------------------- -- Abstract encoders/decoders -------------------- @@ -192,7 +197,6 @@ class WordEncoding w where encodeWordBe :: w -> Put decodeWordBe :: Get w - instance WordEncoding Word8 where encodeWordLe = putWord8 decodeWordLe = getWord8 diff --git a/src/Chainweb/Utils/Tuple.hs b/src/Chainweb/Utils/Tuple.hs new file mode 100644 index 0000000000..61a2658efa --- /dev/null +++ b/src/Chainweb/Utils/Tuple.hs @@ -0,0 +1,101 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} + +-- | Tuple helpers and strict tuples. +module Chainweb.Utils.Tuple +( thd, T2(..), T3(..), T4(..), sfst, ssnd, scurry, suncurry +, suncurry3, uncurry3, _T2, _T3 +) where + +import Control.DeepSeq (NFData) +import Control.Lens (Field1(..), Field2(..), Field3(..), Field4(..), Iso, iso, lens) +import Data.Bifunctor (Bifunctor(..)) +import GHC.Generics (Generic) + +-- -------------------------------------------------------------------------- -- +-- Tuples + +thd :: (a,b,c) -> c +thd (_,_,c) = c +{-# INLINE thd #-} + +-- -------------------------------------------------------------------------- -- +-- Strict Tuple + +data T2 a b = T2 !a !b + deriving (Show, Eq, Ord, Generic, NFData, Functor, Foldable, Traversable) + +instance (Semigroup a, Semigroup b) => Semigroup (T2 a b) where + T2 a b <> T2 a' b' = T2 (a <> a') (b <> b') + +instance (Monoid a, Monoid b) => Monoid (T2 a b) where + mappend = (<>) + mempty = T2 mempty mempty + +instance Bifunctor T2 where + bimap f g (T2 a b) = T2 (f a) (g b) + {-# INLINE bimap #-} +instance Field1 (T2 a b) (T2 x b) a x where + _1 = lens (\(T2 a _b) -> a) (\(T2 _a b) x -> T2 x b) +instance Field2 (T2 a b) (T2 a x) b x where + _2 = lens (\(T2 _a b) -> b) (\(T2 a _b) x -> T2 a x) + +data T3 a b c = T3 !a !b !c + deriving (Show, Eq, Ord, Generic, NFData, Functor) + +instance Bifunctor (T3 a) where + bimap f g (T3 a b c) = T3 a (f b) (g c) + {-# INLINE bimap #-} +instance Field1 (T3 a b c) (T3 x b c) a x where + _1 = lens (\(T3 a _b _c) -> a) (\(T3 _a b c) x -> T3 x b c) +instance Field2 (T3 a b c) (T3 a x c) b x where + _2 = lens (\(T3 _a b _c) -> b) (\(T3 a _b c) x -> T3 a x c) +instance Field3 (T3 a b c) (T3 a b x) c x where + _3 = lens (\(T3 _a _b c) -> c) (\(T3 a b _c) x -> T3 a b x) + +data T4 a b c d = T4 !a !b !c !d + deriving (Show, Eq, Ord, Generic, NFData, Functor) + +instance Field1 (T4 a b c d) (T4 x b c d) a x where + _1 = lens (\(T4 a _b _c _d) -> a) (\(T4 _a b c d) x -> T4 x b c d) +instance Field2 (T4 a b c d) (T4 a x c d) b x where + _2 = lens (\(T4 _a b _c _d) -> b) (\(T4 a _b c d) x -> T4 a x c d) +instance Field3 (T4 a b c d) (T4 a b x d) c x where + _3 = lens (\(T4 _a _b c _d) -> c) (\(T4 a b _c d) x -> T4 a b x d) +instance Field4 (T4 a b c d) (T4 a b c x) d x where + _4 = lens (\(T4 _a _b _c d) -> d) (\(T4 a b c _d) x -> T4 a b c x) + +sfst :: T2 a b -> a +sfst (T2 a _) = a +{-# INLINE sfst #-} + +ssnd :: T2 a b -> b +ssnd (T2 _ b) = b +{-# INLINE ssnd #-} + +scurry :: (T2 a b -> c) -> a -> b -> c +scurry f a b = f (T2 a b) +{-# INLINE scurry #-} + +suncurry :: (a -> b -> c) -> T2 a b -> c +suncurry k (T2 a b) = k a b +{-# INLINE suncurry #-} + +uncurry3 :: (a -> b -> c -> d) -> (a, b, c) -> d +uncurry3 k (a, b, c) = k a b c +{-# INLINE uncurry3 #-} + +suncurry3 :: (a -> b -> c -> d) -> T3 a b c -> d +suncurry3 k (T3 a b c) = k a b c +{-# INLINE suncurry3 #-} + +_T2 :: Iso (T2 a b) (T2 s t) (a,b) (s,t) +_T2 = iso (\(T2 a b) -> (a,b)) (uncurry T2) +{-# INLINE _T2 #-} + +_T3 :: Iso (T3 a b c) (T3 s t u) (a,b,c) (s,t,u) +_T3 = iso (\(T3 a b c) -> (a,b,c)) (\(a,b,c) -> T3 a b c) +{-# INLINE _T3 #-} diff --git a/src/Chainweb/Utils/UnitPrefixes.hs b/src/Chainweb/Utils/UnitPrefixes.hs new file mode 100644 index 0000000000..b560b0875f --- /dev/null +++ b/src/Chainweb/Utils/UnitPrefixes.hs @@ -0,0 +1,49 @@ +-- | SI and binary unit prefixes. +module Chainweb.Utils.UnitPrefixes +( deci, centi, milli, micro, nano, pico, femto, atto, zepto, yocto +, deka, hecto, kilo, mega, giga, tera, peta, exa, zetta, yotta +, kibi, mebi, gibi, tebi, pebi, exbi +) where + +-- -------------------------------------------------------------------------- -- +-- SI unit prefixes + +-- | cf. https://www.nist.gov/pml/owm/metric-si-prefixes +-- +deci, centi, milli, micro, nano, pico, femto, atto, zepto, yocto :: Fractional a => a +deci = 10 ^^ (-1 :: Int) +centi = 10 ^^ (-2 :: Int) +milli = 10 ^^ (-3 :: Int) +micro = 10 ^^ (-6 :: Int) +nano = 10 ^^ (-9 :: Int) +pico = 10 ^^ (-12 :: Int) +femto = 10 ^^ (-15 :: Int) +atto = 10 ^^ (-18 :: Int) +zepto = 10 ^^ (-21 :: Int) +yocto = 10 ^^ (-24 :: Int) + +-- | cf. https://www.nist.gov/pml/owm/metric-si-prefixes +-- +deka, hecto, kilo, mega, giga, tera, peta, exa, zetta, yotta :: Num a => a +deka = 10 ^ (1 :: Int) +hecto = 10 ^ (2 :: Int) +kilo = 10 ^ (3 :: Int) +mega = 10 ^ (6 :: Int) +giga = 10 ^ (9 :: Int) +tera = 10 ^ (12 :: Int) +peta = 10 ^ (15 :: Int) +exa = 10 ^ (18 :: Int) +zetta = 10 ^ (21 :: Int) +yotta = 10 ^ (24 :: Int) + +-- | IEC 60027-X unit prefixes for binary bases. +-- +-- cf. https://www.nist.gov/pml/special-publication-811/nist-guide-si-appendix-d-bibliography#05 +-- +kibi, mebi, gibi, tebi, pebi, exbi:: Num a => a +kibi = 1024 ^ (1 :: Int) +mebi = 1024 ^ (2 :: Int) +gibi = 1024 ^ (3 :: Int) +tebi = 1024 ^ (4 :: Int) +pebi = 1024 ^ (5 :: Int) +exbi = 1024 ^ (6 :: Int) diff --git a/src/Chainweb/VerifierPlugin.hs b/src/Chainweb/VerifierPlugin.hs index 4399a5e066..a5a53dcd6e 100644 --- a/src/Chainweb/VerifierPlugin.hs +++ b/src/Chainweb/VerifierPlugin.hs @@ -35,22 +35,24 @@ import Data.Set(Set) import qualified Data.Set as Set import Data.STRef -import Pact.Types.Capability -import Pact.Types.Gas -import Pact.Types.PactValue -import Pact.Types.Verifier +import Pact.Core.Errors (VerifierError(..)) +import Pact.Core.Gas +import Pact.Core.Names +import Pact.Core.PactValue +import Pact.Core.Signer (SigCapability) +import Pact.Core.Verifiers import Chainweb.Version import Chainweb.BlockHeight import Chainweb.Logger import Chainweb.Utils -import Pact.Core.Errors (VerifierError(..)) newtype VerifierPlugin = VerifierPlugin { runVerifierPlugin :: forall s - . (ChainwebVersion, ChainId, BlockHeight) + . HasVersion + => (ChainId, BlockHeight) -> PactValue -> Set SigCapability -> STRef s Gas @@ -62,16 +64,16 @@ instance NFData VerifierPlugin where chargeGas :: STRef s Gas -> Gas -> ExceptT VerifierError (ST s) () chargeGas r g = do gasRemaining <- lift $ readSTRef r - when (g < 0) $ throwError $ VerifierError $ + when (_gas g < 0) $ throwError $ VerifierError $ "verifier attempted to charge negative gas amount: " <> sshow g when (g > gasRemaining) $ throwError $ VerifierError $ "gas exhausted in verifier. attempted to charge " <> sshow (case g of Gas g' -> g') <> " with only " <> sshow (case gasRemaining of Gas gasRemaining' -> gasRemaining') <> " remaining." - lift $ writeSTRef r (gasRemaining - g) + lift $ writeSTRef r (Gas $ _gas gasRemaining - _gas g) runVerifierPlugins - :: Logger logger - => (ChainwebVersion, ChainId, BlockHeight) + :: (Logger logger, HasVersion) + => (ChainId, BlockHeight) -> logger -> Map VerifierName VerifierPlugin -> Gas diff --git a/src/Chainweb/VerifierPlugin/Allow.hs b/src/Chainweb/VerifierPlugin/Allow.hs index 24676750ca..99298def62 100644 --- a/src/Chainweb/VerifierPlugin/Allow.hs +++ b/src/Chainweb/VerifierPlugin/Allow.hs @@ -10,24 +10,24 @@ import Data.Aeson import qualified Data.Set as Set import qualified Data.Text.Encoding as Text -import Pact.Types.Capability -import Pact.Types.Exp -import Pact.Types.PactValue +import Pact.Core.PactValue import Pact.Core.Errors (VerifierError(..)) import Chainweb.VerifierPlugin +import Pact.Core.Signer (SigCapability) +import Pact.Core.Gas -- This trivial verifier plugin takes as its "proof" a JSON-encoded capability, -- and grants only that capability. plugin :: VerifierPlugin plugin = VerifierPlugin $ \_ proof caps gasRef -> do - chargeGas gasRef 100 + chargeGas gasRef (Gas 100) decodedCap <- decodeArgToCap proof unless (caps == Set.singleton decodedCap) $ throwError $ VerifierError "granted capability is not the one in the proof" where decodeArgToCap :: MonadError VerifierError m => PactValue -> m SigCapability - decodeArgToCap (PLiteral (LString arg)) = + decodeArgToCap (PString arg) = case eitherDecodeStrict' (Text.encodeUtf8 arg) of Left _err -> throwError $ VerifierError $ "argument was not a JSON-encoded capability: " <> arg Right cap -> return cap diff --git a/src/Chainweb/VerifierPlugin/Hyperlane/Announcement.hs b/src/Chainweb/VerifierPlugin/Hyperlane/Announcement.hs index fa60c09723..129131cf85 100644 --- a/src/Chainweb/VerifierPlugin/Hyperlane/Announcement.hs +++ b/src/Chainweb/VerifierPlugin/Hyperlane/Announcement.hs @@ -23,22 +23,23 @@ import qualified Data.Set as Set import Ethereum.Misc hiding (Word256) -import Pact.Types.Runtime -import Pact.Types.PactValue -import Pact.Types.Capability +import Pact.Core.Capabilities +import Pact.Core.Errors (VerifierError(..)) +import Pact.Core.Gas +import Pact.Core.PactValue +import Pact.Core.Signer import Chainweb.VerifierPlugin.Hyperlane.Utils import Chainweb.Utils.Serialization (putRawByteString, runPutS, putWord32be) import Chainweb.VerifierPlugin import Chainweb.Utils (decodeB64UrlNoPaddingText, sshow) -import Pact.Core.Errors (VerifierError(..)) plugin :: VerifierPlugin plugin = VerifierPlugin $ \_ proof caps gasRef -> do -- extract capability values (capLocation, capSigner, capMailboxAddress) <- case Set.toList caps of - [cap] -> case _scArgs cap of + [SigCapability cap] -> case _ctArgs cap of [location, sig, mailbox] -> return (location, sig, mailbox) _ -> throwError $ VerifierError "Incorrect number of capability arguments. Expected: storageLocation, signer." _ -> throwError $ VerifierError "Expected one capability." @@ -46,18 +47,18 @@ plugin = VerifierPlugin $ \_ proof caps gasRef -> do -- extract proof object values (storageLocationText, signatureBase64, mailboxAddressText) <- case proof of (PList values) - | [PLiteral (LString loc), PLiteral (LString sig), PLiteral (LString mailbox)] <- V.toList values + | [PString loc, PString sig, PString mailbox] <- V.toList values -> pure (loc, sig, mailbox) _ -> throwError $ VerifierError "Expected a proof data as a list" -- validate storage location - let storageLocationPactValue = PLiteral $ LString storageLocationText + let storageLocationPactValue = PString storageLocationText unless (storageLocationPactValue == capLocation) $ throwError $ VerifierError $ "Incorrect storageLocation. Expected: " <> sshow storageLocationPactValue <> " but got " <> sshow capLocation -- validate mailbox address - let mailboxAddressPactValue = PLiteral $ LString mailboxAddressText + let mailboxAddressPactValue = PString mailboxAddressText unless (mailboxAddressPactValue == capMailboxAddress) $ throwError $ VerifierError $ "Incorrect mailbox address. Expected: " <> sshow mailboxAddressPactValue <> " but got " <> sshow capMailboxAddress @@ -83,12 +84,12 @@ plugin = VerifierPlugin $ \_ proof caps gasRef -> do putRawByteString $ Text.encodeUtf8 storageLocationText signatureBinary <- do - chargeGas gasRef 5 + chargeGas gasRef (Gas 5) sig <- decodeB64UrlNoPaddingText signatureBase64 return sig - address <- chargeGas gasRef 16250 >> recoverAddress announcementDigest signatureBinary - let addressPactValue = PLiteral . LString . encodeHex <$> address + address <- chargeGas gasRef (Gas 16250) >> recoverAddress announcementDigest signatureBinary + let addressPactValue = PString . encodeHex <$> address case addressPactValue of Just addressPactValue' -> diff --git a/src/Chainweb/VerifierPlugin/Hyperlane/Message.hs b/src/Chainweb/VerifierPlugin/Hyperlane/Message.hs index 891d100f4e..7b1b5e1777 100644 --- a/src/Chainweb/VerifierPlugin/Hyperlane/Message.hs +++ b/src/Chainweb/VerifierPlugin/Hyperlane/Message.hs @@ -20,7 +20,7 @@ import qualified Chainweb.VerifierPlugin.Hyperlane.Message.After225 as After225 import qualified Chainweb.VerifierPlugin.Hyperlane.Message.Before225 as Before225 plugin :: VerifierPlugin -plugin = VerifierPlugin $ \(v, cid, bh) proof caps gasRef -> - if chainweb225Pact v cid bh +plugin = VerifierPlugin $ \(cid, bh) proof caps gasRef -> + if chainweb225Pact cid bh then After225.runPlugin proof caps gasRef - else Before225.runPlugin proof caps gasRef \ No newline at end of file + else Before225.runPlugin proof caps gasRef diff --git a/src/Chainweb/VerifierPlugin/Hyperlane/Message/After225.hs b/src/Chainweb/VerifierPlugin/Hyperlane/Message/After225.hs index 4397c89cf4..f82a198c5d 100644 --- a/src/Chainweb/VerifierPlugin/Hyperlane/Message/After225.hs +++ b/src/Chainweb/VerifierPlugin/Hyperlane/Message/After225.hs @@ -18,7 +18,6 @@ module Chainweb.VerifierPlugin.Hyperlane.Message.After225 (runPlugin) where import Control.Lens -import Control.Error import Control.Exception (evaluate) import Control.Monad (unless) import Control.Monad.Except @@ -34,9 +33,13 @@ import Data.STRef import Ethereum.Misc hiding (Word256) -import Pact.Types.Runtime hiding (ChainId) -import Pact.Types.PactValue -import Pact.Types.Capability +import Pact.Core.Capabilities +import Pact.Core.Errors (VerifierError(..)) +import Pact.Core.Gas +import Pact.Core.Literal +import Pact.Core.Names +import Pact.Core.PactValue +import Pact.Core.Signer import Chainweb.Utils.Serialization (putRawByteString, runPutS, runGetS, putWord32be) @@ -44,13 +47,12 @@ import Chainweb.VerifierPlugin import Chainweb.VerifierPlugin.Hyperlane.Binary import Chainweb.VerifierPlugin.Hyperlane.Utils import Chainweb.Utils (encodeB64UrlNoPaddingText, decodeB64UrlNoPaddingText, sshow) -import Pact.Core.Errors (VerifierError(..)) evaluateST :: a -> ST s a evaluateST a = unsafeIOToST (evaluate a) base64DecodeGasCost :: Gas -base64DecodeGasCost = 5 +base64DecodeGasCost = Gas 5 runPlugin :: forall s . PactValue @@ -59,7 +61,7 @@ runPlugin :: forall s -> ExceptT VerifierError (ST s) () runPlugin proof caps gasRef = do -- extract capability values - SigCapability{..} <- case Set.toList caps of + SigCapability (CapToken { _ctArgs = capArgs }) <- case Set.toList caps of [cap] -> return cap _ -> throwError $ VerifierError "Expected one capability." @@ -71,18 +73,18 @@ runPlugin proof caps gasRef = do -> return i _ -> throwError $ VerifierError $ k <> " is not an integer" - (capMessageId, capMessage, capSigners, capThreshold) <- case _scArgs of + (capMessageId, capMessage, capSigners, capThreshold) <- case capArgs of [mid, mb, PList sigs, PLiteral literalThreshold] -> do threshold <- parseInt "Threshold" literalThreshold parsedSigners <- forM sigs $ \case - (PLiteral (LString v)) -> pure v + (PString v) -> pure v _ -> throwError $ VerifierError "Only string signers are supported" parsedObject <- case mb of - PObject (ObjectMap m) -> do + PObject m -> do let - parseField k = case (m ^? at (FieldKey k) . _Just . _PLiteral) of + parseField k = case (m ^? at (Field k) . _Just . _PLiteral) of Just l -> PLiteral . LInteger <$> parseInt k l _ -> throwError $ VerifierError $ k <> " is missing" @@ -91,7 +93,7 @@ runPlugin proof caps gasRef = do origin <- parseField "originDomain" destination <- parseField "destinationDomain" - return $ PObject $ ObjectMap $ m + return $ PObject $ m & at "version" .~ Just version & at "nonce" .~ Just nonce & at "originDomain" .~ Just origin @@ -106,7 +108,7 @@ runPlugin proof caps gasRef = do -- extract proof object values (hyperlaneMessageBase64, metadataBase64) <- case proof of PList values - | [PLiteral (LString msg), PLiteral (LString mtdt)] <- V.toList values -> + | [PString msg, PString mtdt] <- V.toList values -> pure (msg, mtdt) _ -> throwError $ VerifierError "Expected a proof data as a list" @@ -135,7 +137,7 @@ runPlugin proof caps gasRef = do hmRecipientPactValue = PLiteral $ LString $ encodeB64UrlNoPaddingText hmRecipient hmMessageBodyPactValue = PLiteral $ LString $ encodeB64UrlNoPaddingText hmMessageBody - hmMessagePactValue = PObject . ObjectMap . M.fromList $ + hmMessagePactValue = PObject . M.fromList $ [ ("version", hmVersionPactValue) , ("nonce", hmNoncePactValue) , ("originDomain", hmOriginDomainPactValue) @@ -167,7 +169,7 @@ runPlugin proof caps gasRef = do MerkleRootMultisigIsmMetadata{..} <- maybe (throwError $ VerifierError "error decoding metadata from bytes") return $ runGetS getMerkleRootMultisigIsmMetadata binMetadata - chargeGas gasRef 18 -- gas cost of the `branchRoot` + chargeGas gasRef (Gas 18) -- gas cost of the `branchRoot` root <- lift $ evaluateST $ branchRoot messageId mrmimMerkleProof mrmimMessageIdIndex let digestEnd = do putRawByteString root @@ -209,7 +211,7 @@ runPlugin proof caps gasRef = do verify [] _ = pure () verify (sig:sigs) validators = -- gas cost of the address recovery - chargeGas gasRef 16250 >> recoverAddress digest sig >>= \case + chargeGas gasRef (Gas 16250) >> recoverAddress digest sig >>= \case Just addr -> do case V.elemIndex (encodeHex addr) validators of Just i -> verify sigs (V.drop (i + 1) validators) diff --git a/src/Chainweb/VerifierPlugin/Hyperlane/Message/Before225.hs b/src/Chainweb/VerifierPlugin/Hyperlane/Message/Before225.hs index 78f858859c..c2a0342601 100644 --- a/src/Chainweb/VerifierPlugin/Hyperlane/Message/Before225.hs +++ b/src/Chainweb/VerifierPlugin/Hyperlane/Message/Before225.hs @@ -15,12 +15,13 @@ -- module Chainweb.VerifierPlugin.Hyperlane.Message.Before225 (runPlugin) where -import Control.Error +-- import Control.Error import Control.Monad (unless) import Control.Monad.Except import Control.Monad.ST import qualified Data.ByteString as BS +import Data.Maybe import qualified Data.Text.Encoding as Text import qualified Data.Vector as V import qualified Data.Set as Set @@ -28,9 +29,12 @@ import Data.STRef import Ethereum.Misc hiding (Word256) -import Pact.Types.Runtime hiding (ChainId) -import Pact.Types.PactValue -import Pact.Types.Capability +import Pact.Core.Capabilities +import Pact.Core.Errors (VerifierError(..)) +import Pact.Core.Gas +import Pact.Core.Literal +import Pact.Core.PactValue +import Pact.Core.Signer import Chainweb.Utils.Serialization (putRawByteString, runPutS, runGetS, putWord32be) @@ -38,10 +42,9 @@ import Chainweb.VerifierPlugin import Chainweb.VerifierPlugin.Hyperlane.Binary import Chainweb.VerifierPlugin.Hyperlane.Utils import Chainweb.Utils (encodeB64UrlNoPaddingText, decodeB64UrlNoPaddingText, sshow) -import Pact.Core.Errors (VerifierError(..)) base64DecodeGasCost :: Gas -base64DecodeGasCost = 5 +base64DecodeGasCost = Gas 5 runPlugin :: forall s . PactValue @@ -50,11 +53,11 @@ runPlugin :: forall s -> ExceptT VerifierError (ST s) () runPlugin proof caps gasRef = do -- extract capability values - SigCapability{..} <- case Set.toList caps of + SigCapability (CapToken {..}) <- case Set.toList caps of [cap] -> return cap _ -> throwError $ VerifierError "Expected one capability." - (capMessageBody, capRecipient, capSigners) <- case _scArgs of + (capMessageBody, capRecipient, capSigners) <- case _ctArgs of [mb, r, sigs] -> return (mb, r, sigs) _ -> throwError $ VerifierError $ "Incorrect number of capability arguments. Expected: messageBody, recipient, signers." @@ -111,7 +114,7 @@ runPlugin proof caps gasRef = do putRawByteString messageId -- 16250 is a gas cost of the address recovery - addresses <- catMaybes <$> mapM (\sig -> chargeGas gasRef 16250 >> recoverAddress digest sig) mmimSignatures + addresses <- catMaybes <$> mapM (\sig -> chargeGas gasRef (Gas 16250) >> recoverAddress digest sig) mmimSignatures let addressesVals = PList $ V.fromList $ map (PLiteral . LString . encodeHex) addresses -- Note, that we check the signers for the full equality including their order and amount. diff --git a/src/Chainweb/VerifierPlugin/SignedList.hs b/src/Chainweb/VerifierPlugin/SignedList.hs index 168e8f5d50..bc019d48ef 100644 --- a/src/Chainweb/VerifierPlugin/SignedList.hs +++ b/src/Chainweb/VerifierPlugin/SignedList.hs @@ -23,13 +23,12 @@ -- If any check fails, the transaction aborts with a VerifierError. module Chainweb.VerifierPlugin.SignedList - (plugin,parseHashList) where + (plugin,parseHashList) where import Control.Monad (unless, guard) import Control.Monad.Except import Data.Function ((&)) -import qualified Data.Set as Set import Data.Decimal (Decimal) import qualified Data.Text as T import qualified Data.Text.Encoding as T @@ -37,6 +36,8 @@ import qualified Data.Vector as V import qualified Data.ByteString as BS import qualified Data.ByteString.Base16 as B16 import qualified Data.ByteString.Short as SBS +import qualified Data.Set as Set +import qualified Data.Map as Map import Data.ByteArray (convert) import Crypto.Hash (hashWith, SHA3_256(..)) @@ -46,11 +47,12 @@ import Crypto.PubKey.ECC.ECDSA (PublicKey(..), Signature(..), verifyDigest) import Crypto.PubKey.ECC.Types (CurveName(SEC_p256k1), getCurveByName, Point(..)) import Crypto.Secp256k1 (ecdsaPublicKeyFromCompressed, ecdsaPublicKeyBytes) +import Pact.Core.Capabilities import Pact.Core.Errors (VerifierError(..)) -import Pact.Types.PactValue -import Pact.Types.Capability (SigCapability(..)) -import Pact.Types.Exp (Literal(..)) -import Pact.Types.Term (objectMapToListWith,Gas(..)) +import Pact.Core.Gas (Gas(..)) +import Pact.Core.Literal +import Pact.Core.PactValue +import Pact.Core.Signer import Chainweb.VerifierPlugin (VerifierPlugin(..), chargeGas) @@ -90,7 +92,7 @@ data HashList parseHashList :: PactValue -> Either T.Text HashList parseHashList (PList vec) = HLList <$> traverse parseHashListNode (V.toList vec) parseHashList (PObject om) = - case objectMapToListWith (,) om of + case Map.toList om of [("0x", PLiteral (LString hexStr))] -> Right $ HLHashHex hexStr _ -> Left $ "Malformed binary object at top-level, expected exactly one key '0x'" parseHashList _ = Left $ "Expected a list or binary object at the top-level" @@ -99,7 +101,7 @@ parseHashListNode :: PactValue -> Either T.Text HashListNode parseHashListNode = \case PLiteral (LString t) -> Right $ HLNString t PLiteral (LDecimal d) -> Right $ HLNDecimal d - PObject om -> case objectMapToListWith (,) om of + PObject om -> case Map.toList om of [("0x", PLiteral (LString hexStr))] -> Right $ HLNHashHex hexStr -- decoding is in foldHashList _ -> Left $ "Malformed binary object, expected exactly one key '0x'" PList lst -> HLNList <$> traverse parseHashListNode (V.toList lst) @@ -115,7 +117,7 @@ foldHashList -> ExceptT VerifierError (ST s) (BS.ByteString, PactValue) foldHashList gp gasRef = \case -- Top-level precomputed digest provided as hex. - + HLHashHex hexTxt -> do bs <- decodeHex hexTxt pure (bs, PList V.empty) @@ -165,7 +167,7 @@ plugin = VerifierPlugin $ \_ proof caps gasRef -> do -- Extract and validate capability arguments (capArgs :: [PactValue]) <- case Set.toList caps of - [SigCapability{_scArgs = as}] -> pure as + [SigCapability (CapToken { _ctArgs = as })] -> pure as _ -> throwError $ VerifierError "Expected exactly one capability" (capMsgParts, capPubKeyTxt) <- case capArgs of diff --git a/src/Chainweb/Version.hs b/src/Chainweb/Version.hs index 7860efa058..af4e932fb3 100644 --- a/src/Chainweb/Version.hs +++ b/src/Chainweb/Version.hs @@ -17,6 +17,7 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeAbstractions #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} @@ -79,6 +80,7 @@ module Chainweb.Version , versionQuirks , versionForkNumber , versionForkVoteCastingLength + , versionPayloadProviderTypes , genesisBlockPayload , genesisBlockPayloadHash , genesisBlockTarget @@ -90,15 +92,6 @@ module Chainweb.Version , forkEpochLength , PactUpgrade(..) - , PactVersion(..) - , PactVersionT(..) - , ForBothPactVersions(..) - , ForSomePactVersion(..) - , pattern ForPact4 - , _ForPact4 - , pattern ForPact5 - , _ForPact5 - , forAnyPactVersion -- * Typelevel ChainwebVersionName , ChainwebVersionT(..) @@ -108,13 +101,19 @@ module Chainweb.Version , KnownChainwebVersionSymbol , someChainwebVersionVal - -- * Singletons - , Sing(SChainwebVersion) + -- ** Singletons , SChainwebVersion , pattern FromSingChainwebVersion + -- * Payload Provider Type + , PayloadProviderType(..) + , HasPayloadProviderType(..) + , payloadProviderTypeForChain + , Sing(..) + -- * HasChainwebVersion - , HasChainwebVersion(..) + , HasVersion(..) + , withVersion , mkChainId , chainIds @@ -148,6 +147,8 @@ module Chainweb.Version , indexByForkHeights , latestBehaviorAt , onAllChains + , tabulateChains + , tabulateChainsM , domainAddr2PeerInfo -- * Internal. Don't use. Exported only for testing @@ -171,9 +172,11 @@ import Data.Ratio import Data.Text qualified as T import Data.Word import GHC.Generics(Generic) -import GHC.TypeLits +import GHC.TypeLits hiding (Nat, fromSNat, withSomeSNat) +import GHC.TypeNats import GHC.Stack -import Pact.Types.Runtime (Gas) +import Pact.Core.Gas (Gas) +import Pact.Core.Names (VerifierName) import Chainweb.BlockCreationTime import Chainweb.BlockHeight import Chainweb.ChainId @@ -182,17 +185,21 @@ import Chainweb.Difficulty import Chainweb.Graph import Chainweb.HostAddress import Chainweb.MerkleUniverse -import Chainweb.Payload +import Chainweb.Pact.Payload +import Chainweb.Pact.Transaction qualified as Pact import Chainweb.Pact4.Transaction qualified as Pact4 -import Chainweb.Pact5.Transaction qualified as Pact5 -import Chainweb.Pact5.InitialGasModel +import Chainweb.Pact.InitialGasModel import Chainweb.ForkState import Chainweb.Utils import Chainweb.Utils.Rule import Chainweb.Utils.Serialization import Data.Singletons import P2P.Peer -import Pact.Types.Verifier +import GHC.Exts (WithDict(..)) +import Data.Bifunctor + +-- -------------------------------------------------------------------------- -- +-- Forks -- | Data type representing changes to block validation, whether in the payload -- or in the header. Always add new forks at the end, not in the middle of the @@ -232,6 +239,7 @@ data Fork | Chainweb225Pact | Pact5Fork | Chainweb228Pact + | HashedAdjacentRecord | Chainweb230Pact | Chainweb231Pact | Chainweb31 @@ -274,10 +282,11 @@ instance HasTextRepresentation Fork where toText Chainweb225Pact = "chainweb225Pact" toText Pact5Fork = "pact5" toText Chainweb228Pact = "chainweb228Pact" + toText HashedAdjacentRecord = "hashedAdjacentRecord" toText Chainweb230Pact = "chainweb230Pact" toText Chainweb231Pact = "chainweb231Pact" - toText Chainweb31 = "Chainweb31" - toText Chainweb32 = "Chainweb32" + toText Chainweb31 = "chainweb31" + toText Chainweb32 = "chainweb32" toText MigratePlatformShare = "migratePlatformShare" fromText "slowEpoch" = return SlowEpoch @@ -312,10 +321,11 @@ instance HasTextRepresentation Fork where fromText "chainweb225Pact" = return Chainweb225Pact fromText "pact5" = return Pact5Fork fromText "chainweb228Pact" = return Chainweb228Pact + fromText "hashedAdjacentRecord" = return HashedAdjacentRecord fromText "chainweb230Pact" = return Chainweb230Pact fromText "chainweb231Pact" = return Chainweb231Pact - fromText "Chainweb31" = return Chainweb31 - fromText "Chainweb32" = return Chainweb32 + fromText "chainweb31" = return Chainweb31 + fromText "chainweb32" = return Chainweb32 fromText "migratePlatformShare" = return MigratePlatformShare fromText t = throwM . TextFormatException $ "Unknown Chainweb fork: " <> t @@ -326,7 +336,7 @@ instance ToJSONKey Fork where instance FromJSON Fork where parseJSON = parseJsonFromText "Fork" instance FromJSONKey Fork where - fromJSONKey = FromJSONKeyTextParser $ either fail return . eitherFromText + fromJSONKey = FromJSONKeyTextParser $ either fail return . first displayException . fromText data ForkHeight = ForkAtForkNumber !ForkNumber | ForkAtBlockHeight !BlockHeight | ForkAtGenesis | ForkNever deriving stock (Generic, Eq, Show) @@ -379,11 +389,14 @@ succByHeight _ = error "Only a Blockheight defined fork can be succ'ed" newtype ChainwebVersionName = ChainwebVersionName { getChainwebVersionName :: T.Text } deriving stock (Generic, Eq, Ord) - deriving newtype (ToJSON, FromJSON) + deriving newtype (ToJSON, FromJSON, HasTextRepresentation) deriving anyclass (Hashable, NFData) instance Show ChainwebVersionName where show = T.unpack . getChainwebVersionName +-- -------------------------------------------------------------------------- -- +-- Chainweb Version Code + newtype ChainwebVersionCode = ChainwebVersionCode { getChainwebVersionCode :: Word32 } deriving stock (Generic, Eq, Ord) @@ -396,53 +409,16 @@ encodeChainwebVersionCode = putWord32le . getChainwebVersionCode decodeChainwebVersionCode :: Get ChainwebVersionCode decodeChainwebVersionCode = ChainwebVersionCode <$> getWord32le +-- -------------------------------------------------------------------------- -- +-- Merkle Tree Hash Algorithm + instance MerkleHashAlgorithm a => IsMerkleLogEntry a ChainwebHashTag ChainwebVersionCode where type Tag ChainwebVersionCode = 'ChainwebVersionTag toMerkleNode = encodeMerkleInputNode encodeChainwebVersionCode fromMerkleNode = decodeMerkleInputNode decodeChainwebVersionCode -data PactVersion = Pact4 | Pact5 - deriving stock (Eq, Show) -data PactVersionT (v :: PactVersion) where - Pact4T :: PactVersionT Pact4 - Pact5T :: PactVersionT Pact5 -deriving stock instance Eq (PactVersionT v) -deriving stock instance Show (PactVersionT v) -instance NFData (PactVersionT v) where - rnf Pact4T = () - rnf Pact5T = () - -data ForSomePactVersion f = forall pv. ForSomePactVersion (PactVersionT pv) (f pv) -forAnyPactVersion :: (forall pv. f pv -> a) -> ForSomePactVersion f -> a -forAnyPactVersion k (ForSomePactVersion _ f) = k f -instance (forall pv. Eq (f pv)) => Eq (ForSomePactVersion f) where - ForSomePactVersion Pact4T f == ForSomePactVersion Pact4T f' = f == f' - ForSomePactVersion Pact5T f == ForSomePactVersion Pact5T f' = f == f' - ForSomePactVersion _ _ == ForSomePactVersion _ _ = False -deriving stock instance (forall pv. Show (f pv)) => Show (ForSomePactVersion f) -instance (forall pv. NFData (f pv)) => NFData (ForSomePactVersion f) where - rnf (ForSomePactVersion pv f) = rnf pv `seq` rnf f -pattern ForPact4 :: f Pact4 -> ForSomePactVersion f -pattern ForPact4 x = ForSomePactVersion Pact4T x -_ForPact4 :: Prism' (ForSomePactVersion f) (f Pact4) -_ForPact4 = prism' ForPact4 $ \case - ForPact4 x -> Just x - _ -> Nothing -_ForPact5 :: Prism' (ForSomePactVersion f) (f Pact5) -_ForPact5 = prism' ForPact5 $ \case - ForPact5 x -> Just x - _ -> Nothing -pattern ForPact5 :: f Pact5 -> ForSomePactVersion f -pattern ForPact5 x = ForSomePactVersion Pact5T x -{-# COMPLETE ForPact4, ForPact5 #-} -data ForBothPactVersions f = ForBothPactVersions - { _forPact4 :: f Pact4 - , _forPact5 :: f Pact5 - } -deriving stock instance (Eq (f Pact4), Eq (f Pact5)) => Eq (ForBothPactVersions f) -deriving stock instance (Show (f Pact4), Show (f Pact5)) => Show (ForBothPactVersions f) -instance (NFData (f Pact4), NFData (f Pact5)) => NFData (ForBothPactVersions f) where - rnf b = rnf (_forPact4 b) `seq` rnf (_forPact5 b) +-- -------------------------------------------------------------------------- -- +-- Pact Upgrade -- The type of upgrades, which are sets of transactions to run at certain block -- heights during coinbase. @@ -457,7 +433,7 @@ data PactUpgrade where -- unless you are sure you need it, this mostly exists for old upgrades. } -> PactUpgrade Pact5Upgrade :: - { _pact5UpgradeTransactions :: [Pact5.Transaction] + { _pact5UpgradeTransactions :: [Pact.Transaction] } -> PactUpgrade instance Eq PactUpgrade where @@ -484,19 +460,56 @@ newtype TxIdxInBlock = TxBlockIdx Word makePrisms ''TxIdxInBlock --- The type of quirks, i.e. special validation behaviors that are in some +-- | The type of quirks, i.e. special validation behaviors that are in some -- sense one-offs which can't be expressed as upgrade transactions and must be -- preserved. +-- newtype VersionQuirks = VersionQuirks { _quirkGasFees :: ChainMap (HashMap (BlockHeight, TxIdxInBlock) Gas) } deriving stock (Show, Eq, Ord, Generic) deriving anyclass (NFData) -noQuirks :: VersionQuirks -noQuirks = VersionQuirks - { _quirkGasFees = AllChains HM.empty - } +-- -------------------------------------------------------------------------- -- +-- Payload Provider Type + +data PayloadProviderType + = MinimalProvider + | PactProvider + | EvmProvider Natural + -- ^ The natural number is the Ethereum network id that is used with by + -- this instance of the EVM provider + deriving (Show, Read, Eq, Ord, Generic) + deriving anyclass (NFData) + +data instance Sing (p :: PayloadProviderType) where + SMinimalProvider :: Sing 'MinimalProvider + SPactProvider :: Sing 'PactProvider + SEvmProvider :: SNat n -> Sing ('EvmProvider (n :: Natural)) + +instance SingI 'MinimalProvider where sing = SMinimalProvider +instance SingI 'PactProvider where sing = SPactProvider +instance KnownNat n => SingI ('EvmProvider n) where sing = SEvmProvider (natSing @n) + +instance SingKind PayloadProviderType where + type Demote PayloadProviderType = PayloadProviderType + fromSing SMinimalProvider = MinimalProvider + fromSing SPactProvider = PactProvider + fromSing (SEvmProvider n) = EvmProvider (fromSNat n) + toSing MinimalProvider = SomeSing SMinimalProvider + toSing PactProvider = SomeSing SPactProvider + toSing (EvmProvider n) = withSomeSNat n (SomeSing . SEvmProvider) + {-# INLINE fromSing #-} + {-# INLINE toSing #-} + +instance HasTextRepresentation PayloadProviderType where + toText = sshow + fromText = treadM + {-# INLINE toText #-} + {-# INLINE fromText #-} + +-- -------------------------------------------------------------------------- -- +-- Chainweb Version -- | Chainweb versions are sets of properties that must remain consistent among -- all nodes on the same network. For examples see `Chainweb.Version.Mainnet`, @@ -549,7 +562,10 @@ data ChainwebVersion , _versionBootstraps :: [PeerInfo] -- ^ The locations of the bootstrap peers. , _versionGenesis :: VersionGenesis - -- ^ The information used to construct the genesis blocks. + -- ^ The information used to construct the genesis Headers. This + -- includes the BlockPayloadHashes. The gensis payloads themself are + -- constructed in the respectice payload providers. Chainweb.Version + -- must not depend on payload provider specific modules. , _versionCheats :: VersionCheats -- ^ Whether to disable any core functionality. , _versionDefaults :: VersionDefaults @@ -558,6 +574,8 @@ data ChainwebVersion -- ^ Verifier plugins that can be run to verify transaction contents. , _versionQuirks :: VersionQuirks -- ^ Modifications to behavior at particular blockheights + , _versionPayloadProviderTypes :: ChainMap PayloadProviderType + -- ^ The payload provider type for each chain , _versionForkNumber :: ForkNumber -- ^ The current fork number for this version. Starting with -- chainweb-node version 2.33, fork numbers replace named forks. Fork @@ -582,9 +600,17 @@ data ChainwebVersion deriving stock (Generic) deriving anyclass NFData +class HasVersion where + implicitVersion :: ChainwebVersion + +withVersion :: ChainwebVersion -> (HasVersion => a) -> a +withVersion = withDict @HasVersion + instance Show ChainwebVersion where show = show . _versionName +-- FIXME: why not compare on the version code? That should be unique! +-- Otherwise, at least the genesis hashes should be unique. instance Ord ChainwebVersion where v `compare` v' = fold [ _versionCode v `compare` _versionCode v' @@ -607,6 +633,7 @@ instance Ord ChainwebVersion where , _versionSpvProofRootValidWindow v `compare` _versionSpvProofRootValidWindow v' ] +-- FIXME this instance is not consistent with the Ord instance above instance Eq ChainwebVersion where v == v' = and [ compare v v' == EQ @@ -620,13 +647,13 @@ voteCountingLength :: Natural voteCountingLength = 120 -- | The length of the fork epoch, both vote casting and counting. -forkEpochLength :: ChainwebVersion -> Natural -forkEpochLength v = _versionForkVoteCastingLength v + voteCountingLength +forkEpochLength :: HasVersion => Natural +forkEpochLength = _versionForkVoteCastingLength implicitVersion + voteCountingLength -- | 2/3rds majority of the votes? -decideVotes :: ChainwebVersion -> ForkVotes -> Bool -decideVotes v votes = - round (votes % voteStep) * 3 >= _versionForkVoteCastingLength v * 2 +decideVotes :: HasVersion => ForkVotes -> Bool +decideVotes votes = + round (votes % voteStep) * 3 >= _versionForkVoteCastingLength implicitVersion * 2 data VersionDefaults = VersionDefaults { _disablePeerValidation :: Bool @@ -650,8 +677,17 @@ data VersionCheats = VersionCheats data VersionGenesis = VersionGenesis { _genesisBlockTarget :: ChainMap HashTarget - , _genesisBlockPayload :: ChainMap PayloadWithOutputs + , _genesisBlockPayload :: ChainMap BlockPayloadHash , _genesisTime :: ChainMap BlockCreationTime + -- ^ the value must match the time value in the respective genesis + -- blocks of the payload provider (assuming that the payload provider + -- has a notion of time). In theory this shoudl be /after/ the time in + -- the genesis payloads, because payload times are the times of the + -- parent header. Using the same time, in theory, creates a problem for + -- the payload for the next block after the genesis block, because it + -- would use the same time as the genesis blocks. However, Pact does not + -- care and the EVM payload provider adjusts the payload time forward , + -- which means that it does not match exactly the parent creation time. } deriving stock (Generic, Eq) deriving anyclass NFData @@ -665,12 +701,8 @@ makeLensesWith (lensRules & generateLazyPatterns .~ True) 'VersionCheats makeLensesWith (lensRules & generateLazyPatterns .~ True) 'VersionDefaults makeLensesWith (lensRules & generateLazyPatterns .~ True) 'VersionQuirks -genesisBlockPayloadHash :: ChainwebVersion -> ChainId -> BlockPayloadHash -genesisBlockPayloadHash v cid = v ^?! versionGenesis . genesisBlockPayload . atChain cid . to _payloadWithOutputsPayloadHash - -instance HasTextRepresentation ChainwebVersionName where - toText = getChainwebVersionName - fromText = pure . ChainwebVersionName +genesisBlockPayloadHash :: HasVersion => ChainId -> BlockPayloadHash +genesisBlockPayloadHash cid = implicitVersion ^?! versionGenesis . genesisBlockPayload . atChain cid -------------------------------------------------------------------------- -- -- Type level ChainwebVersion @@ -688,8 +720,8 @@ instance (KnownSymbol n) => KnownChainwebVersionSymbol ('ChainwebVersionT n) whe type ChainwebVersionSymbol ('ChainwebVersionT n) = n chainwebVersionSymbolVal _ = T.pack $ symbolVal (Proxy @n) -someChainwebVersionVal :: ChainwebVersion -> SomeChainwebVersionT -someChainwebVersionVal v = someChainwebVersionVal' (_versionName v) +someChainwebVersionVal :: HasVersion => SomeChainwebVersionT +someChainwebVersionVal = someChainwebVersionVal' (_versionName implicitVersion) someChainwebVersionVal' :: ChainwebVersionName -> SomeChainwebVersionT someChainwebVersionVal' v = case someSymbolVal (show v) of @@ -722,31 +754,45 @@ pattern FromSingChainwebVersion sng <- (\v -> withSomeSing (_versionName v) Some -------------------------------------------------------------------------- -- -- HasChainwebVersion Class -class HasChainwebVersion a where - _chainwebVersion :: a -> ChainwebVersion - _chainwebVersion = view chainwebVersion - - chainwebVersion :: Getter a ChainwebVersion - chainwebVersion = to _chainwebVersion - - {-# MINIMAL _chainwebVersion | chainwebVersion #-} - -instance HasChainwebVersion ChainwebVersion where - _chainwebVersion = id - -- | All known chainIds. This includes chains that are not yet "active". -- -chainIds :: HasChainwebVersion v => v -> HS.HashSet ChainId -chainIds = graphChainIds . snd . ruleHead . _versionGraphs . _chainwebVersion +chainIds :: HasVersion => HS.HashSet ChainId +chainIds = graphChainIds $ snd $ ruleHead $ _versionGraphs implicitVersion mkChainId - :: (MonadThrow m, HasChainwebVersion v) - => v -> BlockHeight -> Word32 -> m ChainId -mkChainId v h i = cid - <$ checkWebChainId (chainGraphAt (_chainwebVersion v) h) cid + :: (MonadThrow m, HasVersion) + => BlockHeight -> Word32 -> m ChainId +mkChainId h i = cid + <$ checkWebChainId (chainGraphAt h) cid where cid = unsafeChainId i +-- -------------------------------------------------------------------------- -- +-- HasPayloadProviderType Class + +class HasPayloadProviderType p where + _payloadProviderType :: p -> PayloadProviderType + _payloadProviderType = view payloadProviderType + + payloadProviderType :: Getter p PayloadProviderType + payloadProviderType = to _payloadProviderType + + {-# INLINE _payloadProviderType #-} + {-# INLINE payloadProviderType #-} + {-# MINIMAL _payloadProviderType | payloadProviderType #-} + +payloadProviderTypeForChain + :: HasVersion + => HasChainId c + => c + -> PayloadProviderType +payloadProviderTypeForChain c = implicitVersion + ^?! versionPayloadProviderTypes . atChain c + +instance (HasVersion, HasChainId p) => HasPayloadProviderType p where + _payloadProviderType = payloadProviderTypeForChain + {-# INLINE _payloadProviderType #-} + -------------------------------------------------------------------------- -- -- Properties of Chainweb Versions -------------------------------------------------------------------------- -- @@ -759,18 +805,15 @@ mkChainId v h i = cid -- This function is safe because of invariants provided by 'chainwebGraphs'. -- (There are also unit tests the confirm this.) chainwebGraphsAt - :: ChainwebVersion - -> BlockHeight + :: HasVersion + => BlockHeight -> Rule BlockHeight ChainGraph -chainwebGraphsAt v h = - ruleDropWhile (> h) (_versionGraphs v) +chainwebGraphsAt h = + ruleDropWhile (> h) (_versionGraphs implicitVersion) -- | The 'ChainGraph' for the given 'BlockHeight' -chainGraphAt :: HasChainwebVersion v => v -> BlockHeight -> ChainGraph -chainGraphAt v = snd . ruleHead . chainwebGraphsAt (_chainwebVersion v) - -instance HasChainGraph (ChainwebVersion, BlockHeight) where - _chainGraph = uncurry chainGraphAt +chainGraphAt :: HasVersion => BlockHeight -> ChainGraph +chainGraphAt = snd . ruleHead . chainwebGraphsAt -- | The genesis block height for a given chain. -- @@ -778,8 +821,8 @@ instance HasChainGraph (ChainwebVersion, BlockHeight) where -- (We generally assume that this invariant holds throughout the code base. -- It is enforced via the 'mkChainId' smart constructor for ChainId.) -- -genesisBlockHeight :: HasCallStack => ChainwebVersion -> ChainId -> BlockHeight -genesisBlockHeight v c = fst $ genesisHeightAndGraph v c +genesisBlockHeight :: (HasVersion, HasCallStack) => ChainId -> BlockHeight +genesisBlockHeight = fst . genesisHeightAndGraph {-# inlinable genesisBlockHeight #-} -- | The genesis graph for a given Chain @@ -792,13 +835,12 @@ genesisBlockHeight v c = fst $ genesisHeightAndGraph v c -- genesisHeightAndGraph :: HasCallStack - => HasChainwebVersion v + => HasVersion => HasChainId c - => v - -> c + => c -> (BlockHeight, ChainGraph) -genesisHeightAndGraph v c = - case ruleSeek (\_ g -> not (isWebChain g c)) (_versionGraphs (_chainwebVersion v)) of +genesisHeightAndGraph c = + case ruleSeek (\_ g -> not (isWebChain g c)) (_versionGraphs implicitVersion) of -- the chain was in every graph down to the bottom, -- so the bottom has the genesis graph (False, z) -> ruleZipperHere z @@ -811,7 +853,7 @@ genesisHeightAndGraph v c = where missingChainError = error $ "Invalid ChainId " <> show (_chainId c) - <> " for chainweb version " <> show (_versionName (_chainwebVersion v)) + <> " for chainweb version " <> show (_versionName implicitVersion) {-# inlinable genesisHeightAndGraph #-} -------------------------------------------------------------------------- -- @@ -823,10 +865,10 @@ domainAddr2PeerInfo = fmap (PeerInfo Nothing) -- | A utility to allow indexing behavior by forks, returning that behavior -- indexed by the block heights of those forks. indexByForkHeights - :: ChainwebVersion - -> [(Fork, ChainMap a)] + :: HasVersion + => [(Fork, ChainMap a)] -> ChainMap (HashMap BlockHeight a) -indexByForkHeights v = OnChains . foldl' go (HM.empty <$ HS.toMap (chainIds v)) +indexByForkHeights = ChainMap . foldl' go (HM.empty <$ HS.toMap chainIds) where conflictError fork h = error $ "conflicting behavior at block height " <> show h <> " when adding behavior for fork " <> show fork @@ -839,14 +881,14 @@ indexByForkHeights v = OnChains . foldl' go (HM.empty <$ HS.toMap (chainIds v)) [ (cid, HM.singleton forkHeight upg) | cid <- HM.keys acc , Just upg <- [txsPerChain ^? atChain cid] - , ForkAtBlockHeight forkHeight <- [v ^?! versionForks . at fork . _Just . atChain cid] + , ForkAtBlockHeight forkHeight <- [implicitVersion ^?! versionForks . at fork . _Just . atChain cid] , forkHeight /= maxBound ] -- | The block height at all chains at which the latest known behavior changes -- will have taken effect: forks, upgrade transactions, or graph changes. -latestBehaviorAt :: ChainwebVersion -> BlockHeight -latestBehaviorAt v = foldlOf' behaviorChanges max 0 v + 1 +latestBehaviorAt :: HasVersion => BlockHeight +latestBehaviorAt = foldlOf' behaviorChanges max 0 implicitVersion + 1 where behaviorChanges = fold [ versionForks . folded . folded . _ForkAtBlockHeight @@ -854,10 +896,21 @@ latestBehaviorAt v = foldlOf' behaviorChanges max 0 v + 1 , versionGraphs . to ruleHead . _1 ] +onAllChains :: HasVersion => a -> ChainMap a +onAllChains a = tabulateChains (const a) + +tabulateChains :: HasVersion => (ChainId -> a) -> ChainMap a +tabulateChains f = runIdentity $ tabulateChainsM (Identity . f) + -- | Easy construction of a `ChainMap` with entries for every chain -- in a `ChainwebVersion`. -onAllChains :: Applicative m => ChainwebVersion -> (ChainId -> m a) -> m (ChainMap a) -onAllChains v f = OnChains <$> +tabulateChainsM :: (HasVersion, Applicative m) => (ChainId -> m a) -> m (ChainMap a) +tabulateChainsM f = ChainMap <$> HM.traverseWithKey (\cid () -> f cid) - (HS.toMap (chainIds v)) + (HS.toMap chainIds) + +noQuirks :: HasVersion => VersionQuirks +noQuirks = VersionQuirks + { _quirkGasFees = onAllChains HM.empty + } diff --git a/src/Chainweb/Version/Development.hs b/src/Chainweb/Version/Development.hs index 401b50d623..223f02fbf8 100644 --- a/src/Chainweb/Version/Development.hs +++ b/src/Chainweb/Version/Development.hs @@ -5,48 +5,66 @@ {-# language QuasiQuotes #-} {-# language ViewPatterns #-} -module Chainweb.Version.Development(devnet, pattern Development) where +module Chainweb.Version.Development +( devnet +, pattern Development +) where import qualified Data.Set as Set import Chainweb.BlockCreationTime import Chainweb.ChainId import Chainweb.Difficulty -import Chainweb.Pact5.InitialGasModel +import Chainweb.Pact.InitialGasModel import Chainweb.Graph import Chainweb.Time import Chainweb.Utils import Chainweb.Utils.Rule import Chainweb.Version -import Pact.Types.Verifier - -import qualified Chainweb.BlockHeader.Genesis.Development0Payload as DN0 -import qualified Chainweb.BlockHeader.Genesis.Development1to19Payload as DNN +import Pact.Core.Names pattern Development :: ChainwebVersion pattern Development <- ((== devnet) -> True) where Development = devnet devnet :: ChainwebVersion -devnet = ChainwebVersion +devnet = withVersion devnet $ ChainwebVersion { _versionCode = ChainwebVersionCode 0x00000002 , _versionName = ChainwebVersionName "development" , _versionForks = tabulateHashMap $ \case - MigratePlatformShare -> AllChains ForkNever - _ -> AllChains ForkAtGenesis - , _versionUpgrades = AllChains mempty + MigratePlatformShare -> onAllChains ForkNever + _ -> onAllChains ForkAtGenesis + , _versionUpgrades = onAllChains mempty , _versionGraphs = Bottom (minBound, twentyChainGraph) , _versionBlockDelay = BlockDelay 30_000_000 , _versionWindow = WindowWidth 120 , _versionHeaderBaseSizeBytes = 318 - 110 , _versionBootstraps = [] , _versionGenesis = VersionGenesis - { _genesisBlockTarget = AllChains $ HashTarget (maxBound `div` 100_000) - , _genesisTime = AllChains $ BlockCreationTime [timeMicrosQQ| 2019-07-17T18:28:37.613832 |] - , _genesisBlockPayload = onChains $ concat - [ [(unsafeChainId 0, DN0.payloadBlock)] - , [(unsafeChainId i, DNN.payloadBlock) | i <- [1..19]] + { _genesisBlockTarget = onAllChains $ HashTarget (maxBound `div` 100_000) + , _genesisTime = onAllChains $ BlockCreationTime [timeMicrosQQ| 2019-07-17T18:28:37.613832 |] + , _genesisBlockPayload = onChains + [ (unsafeChainId 0, unsafeFromText "QzxVHFZ5go4PYd3QeAZhxP61hsVnICPw4BB9h-T3PDM") + , (unsafeChainId 1, unsafeFromText "66JSEmDIl6AqWTKN29LprukaeUmK0OOd4RufVO8e6-4") + , (unsafeChainId 2, unsafeFromText "66JSEmDIl6AqWTKN29LprukaeUmK0OOd4RufVO8e6-4") + , (unsafeChainId 3, unsafeFromText "66JSEmDIl6AqWTKN29LprukaeUmK0OOd4RufVO8e6-4") + , (unsafeChainId 4, unsafeFromText "66JSEmDIl6AqWTKN29LprukaeUmK0OOd4RufVO8e6-4") + , (unsafeChainId 5, unsafeFromText "66JSEmDIl6AqWTKN29LprukaeUmK0OOd4RufVO8e6-4") + , (unsafeChainId 6, unsafeFromText "66JSEmDIl6AqWTKN29LprukaeUmK0OOd4RufVO8e6-4") + , (unsafeChainId 7, unsafeFromText "66JSEmDIl6AqWTKN29LprukaeUmK0OOd4RufVO8e6-4") + , (unsafeChainId 8, unsafeFromText "66JSEmDIl6AqWTKN29LprukaeUmK0OOd4RufVO8e6-4") + , (unsafeChainId 9, unsafeFromText "66JSEmDIl6AqWTKN29LprukaeUmK0OOd4RufVO8e6-4") + , (unsafeChainId 10, unsafeFromText "66JSEmDIl6AqWTKN29LprukaeUmK0OOd4RufVO8e6-4") + , (unsafeChainId 11, unsafeFromText "66JSEmDIl6AqWTKN29LprukaeUmK0OOd4RufVO8e6-4") + , (unsafeChainId 12, unsafeFromText "66JSEmDIl6AqWTKN29LprukaeUmK0OOd4RufVO8e6-4") + , (unsafeChainId 13, unsafeFromText "66JSEmDIl6AqWTKN29LprukaeUmK0OOd4RufVO8e6-4") + , (unsafeChainId 14, unsafeFromText "66JSEmDIl6AqWTKN29LprukaeUmK0OOd4RufVO8e6-4") + , (unsafeChainId 15, unsafeFromText "66JSEmDIl6AqWTKN29LprukaeUmK0OOd4RufVO8e6-4") + , (unsafeChainId 16, unsafeFromText "66JSEmDIl6AqWTKN29LprukaeUmK0OOd4RufVO8e6-4") + , (unsafeChainId 17, unsafeFromText "66JSEmDIl6AqWTKN29LprukaeUmK0OOd4RufVO8e6-4") + , (unsafeChainId 18, unsafeFromText "66JSEmDIl6AqWTKN29LprukaeUmK0OOd4RufVO8e6-4") + , (unsafeChainId 19, unsafeFromText "66JSEmDIl6AqWTKN29LprukaeUmK0OOd4RufVO8e6-4") ] } @@ -54,7 +72,7 @@ devnet = ChainwebVersion -- defaultChainwebConfiguration._configBlockGasLimit , _versionMaxBlockGasLimit = Bottom (minBound, Nothing) , _versionSpvProofRootValidWindow = Bottom (minBound, Nothing) - , _versionInitialGasModel = AllChains $ Bottom (minBound, post32GasModel) + , _versionInitialGasModel = onAllChains $ Bottom (minBound, post32GasModel) , _versionCheats = VersionCheats { _disablePow = True , _fakeFirstEpochStart = True @@ -64,9 +82,10 @@ devnet = ChainwebVersion { _disablePeerValidation = True , _disableMempoolSync = False } - , _versionVerifierPluginNames = AllChains $ Bottom + , _versionVerifierPluginNames = onAllChains $ Bottom (minBound, Set.fromList $ map VerifierName ["hyperlane_v3_message", "allow", "signed_list"]) , _versionQuirks = noQuirks + , _versionPayloadProviderTypes = onAllChains PactProvider , _versionForkNumber = 1 , _versionForkVoteCastingLength = 120 * 119 -- 5 days } diff --git a/src/Chainweb/Version/EvmDevelopment.hs b/src/Chainweb/Version/EvmDevelopment.hs new file mode 100644 index 0000000000..0245094e21 --- /dev/null +++ b/src/Chainweb/Version/EvmDevelopment.hs @@ -0,0 +1,201 @@ +{-# language LambdaCase #-} +{-# language NumericUnderscores #-} +{-# language OverloadedStrings #-} +{-# language PatternSynonyms #-} +{-# language QuasiQuotes #-} +{-# language ViewPatterns #-} + +module Chainweb.Version.EvmDevelopment +( evmDevnet +, pattern EvmDevelopment +) where + +import qualified Data.Set as Set + +import Chainweb.Pact.InitialGasModel +import Chainweb.BlockCreationTime +import Chainweb.ChainId +import Chainweb.Difficulty +import Chainweb.Graph +import Chainweb.Time +import Chainweb.Utils +import Chainweb.Utils.Rule +import Chainweb.Version + +import Pact.Core.Names + +pattern EvmDevelopment :: ChainwebVersion +pattern EvmDevelopment <- ((== evmDevnet) -> True) where + EvmDevelopment = evmDevnet + +-- How to compute the hashes: +-- +-- Mininal Payload Provider: +-- +-- @ +-- -- create dummy payload hashes +-- import Chainweb.PayloadProvider.Minimal.Payload +-- import Chainweb.Version.EvmDevelopment +-- +-- mapM_ (\i -> T.putStrLn (sshow i <> " " <> encodeToText (view payloadHash $ genesisPayload EvmDevelopment $ unsafeChainId i))) [25..97] +-- @ +-- +-- EVM Payload Provider: +-- +-- @ +-- $(cabal list-bin evm-genesis) evm-development +-- @ +-- +-- Pact Provider: +-- +-- TODO (use ea?) + +evmDevnet :: ChainwebVersion +evmDevnet = withVersion evmDevnet $ ChainwebVersion + { _versionCode = ChainwebVersionCode 0x0000_000b + , _versionName = ChainwebVersionName "evm-development" + , _versionForks = tabulateHashMap $ const $ onAllChains ForkAtGenesis + , _versionUpgrades = onAllChains mempty + , _versionForkNumber = 1 + , _versionForkVoteCastingLength = 20 + , _versionSpvProofRootValidWindow = Bottom (minBound, Nothing) + , _versionInitialGasModel = onAllChains $ Bottom (minBound, post32GasModel) + , _versionGraphs = Bottom (minBound, d4k4ChainGraph) + , _versionBlockDelay = BlockDelay 30_000_000 + , _versionWindow = WindowWidth 120 + , _versionHeaderBaseSizeBytes = 318 - 110 + , _versionBootstraps = [] + , _versionGenesis = VersionGenesis + { _genesisBlockTarget = onAllChains $ HashTarget (maxBound `div` 100_000) + , _genesisTime = onChains + -- FIXME: is the creation time for the pact headers correct? + $ [ (unsafeChainId i, BlockCreationTime [timeMicrosQQ| 2025-01-01T00:00:00.000000 |]) | i <- [0..19] ] + <> [ (unsafeChainId i, BlockCreationTime (Time (secondsToTimeSpan 0x684c5d2a))) | i <- [20..24] ] + <> [ (unsafeChainId i, BlockCreationTime [timeMicrosQQ| 2025-01-01T00:00:00.000000 |]) | i <- [25..97] ] + , _genesisBlockPayload = onChains $ + -- Pact Payload Provider + [ (unsafeChainId 0, unsafeFromText "QzxVHFZ5go4PYd3QeAZhxP61hsVnICPw4BB9h-T3PDM") + , (unsafeChainId 1, unsafeFromText "66JSEmDIl6AqWTKN29LprukaeUmK0OOd4RufVO8e6-4") + , (unsafeChainId 2, unsafeFromText "66JSEmDIl6AqWTKN29LprukaeUmK0OOd4RufVO8e6-4") + , (unsafeChainId 3, unsafeFromText "66JSEmDIl6AqWTKN29LprukaeUmK0OOd4RufVO8e6-4") + , (unsafeChainId 4, unsafeFromText "66JSEmDIl6AqWTKN29LprukaeUmK0OOd4RufVO8e6-4") + , (unsafeChainId 5, unsafeFromText "66JSEmDIl6AqWTKN29LprukaeUmK0OOd4RufVO8e6-4") + , (unsafeChainId 6, unsafeFromText "66JSEmDIl6AqWTKN29LprukaeUmK0OOd4RufVO8e6-4") + , (unsafeChainId 7, unsafeFromText "66JSEmDIl6AqWTKN29LprukaeUmK0OOd4RufVO8e6-4") + , (unsafeChainId 8, unsafeFromText "66JSEmDIl6AqWTKN29LprukaeUmK0OOd4RufVO8e6-4") + , (unsafeChainId 9, unsafeFromText "66JSEmDIl6AqWTKN29LprukaeUmK0OOd4RufVO8e6-4") + , (unsafeChainId 10, unsafeFromText "66JSEmDIl6AqWTKN29LprukaeUmK0OOd4RufVO8e6-4") + , (unsafeChainId 11, unsafeFromText "66JSEmDIl6AqWTKN29LprukaeUmK0OOd4RufVO8e6-4") + , (unsafeChainId 12, unsafeFromText "66JSEmDIl6AqWTKN29LprukaeUmK0OOd4RufVO8e6-4") + , (unsafeChainId 13, unsafeFromText "66JSEmDIl6AqWTKN29LprukaeUmK0OOd4RufVO8e6-4") + , (unsafeChainId 14, unsafeFromText "66JSEmDIl6AqWTKN29LprukaeUmK0OOd4RufVO8e6-4") + , (unsafeChainId 15, unsafeFromText "66JSEmDIl6AqWTKN29LprukaeUmK0OOd4RufVO8e6-4") + , (unsafeChainId 16, unsafeFromText "66JSEmDIl6AqWTKN29LprukaeUmK0OOd4RufVO8e6-4") + , (unsafeChainId 17, unsafeFromText "66JSEmDIl6AqWTKN29LprukaeUmK0OOd4RufVO8e6-4") + , (unsafeChainId 18, unsafeFromText "66JSEmDIl6AqWTKN29LprukaeUmK0OOd4RufVO8e6-4") + , (unsafeChainId 19, unsafeFromText "66JSEmDIl6AqWTKN29LprukaeUmK0OOd4RufVO8e6-4") + -- EVM Payload Provider + , (unsafeChainId 20, unsafeFromText "ylbiSj9QqDiV6uxvruCxKVWIpQ0RryJJWSfAhsoVl34") + , (unsafeChainId 21, unsafeFromText "TgyW8yFzZ0MXHlru39gg8vK3BuEBzbREvkMcogyUk10") + , (unsafeChainId 22, unsafeFromText "ZWV82vuXA_PPPK6j9uwzkX3rMbUy1xAjq33zbw-JKXI") + , (unsafeChainId 23, unsafeFromText "ba9y4BtyQJPNeQzbEyyIvD7ZYR0qMpRIFmjSD2hKmFc") + , (unsafeChainId 24, unsafeFromText "__mJBSF-n1SRgtp52X-kRTNzzzpXgSkd8WLhPdBjsSM") + -- Minimal Payload Provider + , (unsafeChainId 25, unsafeFromText "Gt116uJVwjUEM0f07u_x8-SUFHgGpoH1xf3sfPoe0ZY") + , (unsafeChainId 26, unsafeFromText "NLRP0OiqRldiZclvoKBGhv9m5wO0TrhNKaZZslZuZvw") + , (unsafeChainId 27, unsafeFromText "xAOBFMKZ_lSHNVhHW-GhbhiWh6sX48S2KPyyPMjAnZM") + , (unsafeChainId 28, unsafeFromText "eav79QetdNuKo1HDW27Aeqbxr8oAt6Fh2U6ZtSfVyYU") + , (unsafeChainId 29, unsafeFromText "jlcxQ4wXUrApJDUQRS8KxuSyoG7ZFEwLV4-92wmqLOQ") + , (unsafeChainId 30, unsafeFromText "odUxYpZ8ZeW0WuQcibJH3isuI045MuEEeQqLrkivWEk") + , (unsafeChainId 31, unsafeFromText "poJ65aDiZYYthbhrgUI2jJS_8vK1CTHRE2C6dLbjTXA") + , (unsafeChainId 32, unsafeFromText "SC3ol1uFOHAewfQrMQczKrvhE8Dw1Bp9fBzNi9l_zTw") + , (unsafeChainId 33, unsafeFromText "p38GsNdY-T8ULYN1OTpYyO1E7WOGwzE2g92aIPereUw") + , (unsafeChainId 34, unsafeFromText "1V0SzqA9fHDOMnfvXvSd57H0r-iycjjLu3CKkRLcjRk") + , (unsafeChainId 35, unsafeFromText "SeiRMENBv5XqR7wXUYSR2orjGHSUrtawx5gLrDCfZYA") + , (unsafeChainId 36, unsafeFromText "JpsiIjm8aZEbyrcsMqLDneT0BNoJAJunk4BYqDO_1Y0") + , (unsafeChainId 37, unsafeFromText "0yx4OFT3sbLS_wrqpULgPpgzzxmMRwM6VTmkasitTlA") + , (unsafeChainId 38, unsafeFromText "Z3LE9JHGpSYuR3SvoYWPae7zB9-X05vFLjwD4GnXX_A") + , (unsafeChainId 39, unsafeFromText "9ZHBlxeYPWjhvMySgVx3ThEyooYx724zjORClgmq8Lk") + , (unsafeChainId 40, unsafeFromText "H3VBsNGh-SQE-0d_qlYSHnS2obzUeo6Zi1XDDvhndYo") + , (unsafeChainId 41, unsafeFromText "N6hVHz6vo0frpS3eyqvtMeZg1eFbAMJ1CS315M-JpWw") + , (unsafeChainId 42, unsafeFromText "9mo8CRwvTLLJ4cSQtErBfOIxzwpale-AwnbXPWQd184") + , (unsafeChainId 43, unsafeFromText "SotTkMw2Eq5UbOObv5kyaUlMqHp6-PUSKDeLHWYCr2s") + , (unsafeChainId 44, unsafeFromText "1IB27CAQ6MpXFV-OiyDVIxbXh91BK2Bl6PYiAwvyg-E") + , (unsafeChainId 45, unsafeFromText "ou9ns1_Q72IsaXoVjCErGGGmzsI07IIx6Vo14gU0Fl8") + , (unsafeChainId 46, unsafeFromText "dZsEBdKKdeLkTS35IV54npY01mB9HOWO3TvoXE0xoWg") + , (unsafeChainId 47, unsafeFromText "oLbpBWhnhCdKHy_q009-06PYug12KMtA5u9mv82_I8s") + , (unsafeChainId 48, unsafeFromText "coBTWu6iFvyDX_3W2dSnuwK9WheRa9_40kh564myiXw") + , (unsafeChainId 49, unsafeFromText "fiOvn4JEAf7NXGAP3YkXhygalCnKCwzhe2dC1VO4YiU") + , (unsafeChainId 50, unsafeFromText "UL6_gjNoxuryRd3xBj3OU00A6IjvHtdnggucOISDgc4") + , (unsafeChainId 51, unsafeFromText "Wtu06D5r5DcNSZ8ZxxPv3Jvq4dtYW1PnHJtrxmdVSzw") + , (unsafeChainId 52, unsafeFromText "yrSDpQnAtnw-WYVrXMd-zAt2ZCOBNz7mACG-UjX5Tl0") + , (unsafeChainId 53, unsafeFromText "c743P-dTKKA6PpKCJ6ZC9im7bo1BpJWViZ6xjZJokkw") + , (unsafeChainId 54, unsafeFromText "qlj-G-PO_TtM5mp2C6UI6GgVWR2H1um2v6VOMrXjX4M") + , (unsafeChainId 55, unsafeFromText "XO6ZWLmRlyiGygt2pdDZpxZfwHrmkLsBM99rJSxa31M") + , (unsafeChainId 56, unsafeFromText "jiXkFn_Nv73-X8d3xUtsY25lNN2g35sjSsu43X1pOEM") + , (unsafeChainId 57, unsafeFromText "Dr15tRuU6JSXOARB46_r1DGb9e2WX4a61BoiJ9Uq5p0") + , (unsafeChainId 58, unsafeFromText "KYlhzAW01sBwnO2dXl9_0BuRNV64nJJCSSo6JdDNMZA") + , (unsafeChainId 59, unsafeFromText "ywo1yl72s89SQibkkKuRm4tmBnp8guONArOLa03lETU") + , (unsafeChainId 60, unsafeFromText "t4u3_IuTXANdi2NrM2prmWCOFSc3AkrwHYziL1LSsEU") + , (unsafeChainId 61, unsafeFromText "Ucp32OmDetbZPozGHES6F7HKqbAnIfynOsfCzUo3lDI") + , (unsafeChainId 62, unsafeFromText "VEsZDVjM1lJkfJUWTXEyC7wH27vgDoviFD2Rt22vJ1I") + , (unsafeChainId 63, unsafeFromText "NDsftZSHa8N1yDdkgQJQ1rk1J3vRFFxFzCSrd8SzEUo") + , (unsafeChainId 64, unsafeFromText "80yIgBalnINZyprtYhZVCgOgMbB2DoW5Xq42FJf7nKk") + , (unsafeChainId 65, unsafeFromText "BMi5YZ0GpYTemGe6x_FtXEI5JTO9rinekaNnhEV87Jc") + , (unsafeChainId 66, unsafeFromText "uAIl8FGVbOPzitFHovTPJtPHaCQzYA8ZOaE6PxBx3Ng") + , (unsafeChainId 67, unsafeFromText "tmzmkzngbTHNfywBySBDE-OLXwhjgn2gNhqK86uFRXk") + , (unsafeChainId 68, unsafeFromText "MNkeZut1raJk7-Vh6Yf2HR-Lhf7x97ZYqtZvM-czHmA") + , (unsafeChainId 69, unsafeFromText "BMa_Ucv2c0Q9TU9wE8HZaX5hFv919yqh57s_ijfb0aA") + , (unsafeChainId 70, unsafeFromText "YZlG4QzDr285OQMCs5k9ZS6SNYSNjq2gr9RnJ1DmyBw") + , (unsafeChainId 71, unsafeFromText "ZDwNBLBZSTRertPlENXC6CUj6StykJLucUnN_DydnLc") + , (unsafeChainId 72, unsafeFromText "BtxzFZrXiRYOMouRmU7eA9pohvahn_GdKPREhcuGCY4") + , (unsafeChainId 73, unsafeFromText "cGIf74TXx8V_XrUUr2B9MU8adtQeQc1hpk6XOey1GOU") + , (unsafeChainId 74, unsafeFromText "j3hvD0Yjztjc_trqX4OMHPOqEWTd04GKvPfmt4r92D8") + , (unsafeChainId 75, unsafeFromText "eSIZD24zvKNw-2OJtWJujayy3AKU2h11RhRWZUC6MtM") + , (unsafeChainId 76, unsafeFromText "P3H3_4I6vJTQOszcrYreI6LOhSRVgVv7Hb0nFawzbsM") + , (unsafeChainId 77, unsafeFromText "CKomlT6tiEs6DCa2VNy3519TjAiwFNx8EkkI54JKY0I") + , (unsafeChainId 78, unsafeFromText "2NldG3su7R_RXpes25X09t8evnjNMuZoL8j3PcNMfXE") + , (unsafeChainId 79, unsafeFromText "fMlZOHs-mzu5u2DXAiCKzhZNOlCMROY2YXxHMCdiHyo") + , (unsafeChainId 80, unsafeFromText "mDocxA63bstQQ-vqzM02_avZmSjrPFFxcvcVa6ZCYMU") + , (unsafeChainId 81, unsafeFromText "hqkNDhLpy-9usTAyu77mvwoCD8YDlW9O66EFQ98ARsg") + , (unsafeChainId 82, unsafeFromText "jSGKQqn_KP4RbFsbTT_6VWFTj9WOqAqv-INoMyJntAw") + , (unsafeChainId 83, unsafeFromText "fvOd-k-4j_OFmAQo1M2Vy1T2O18UkpcjRYlSMVcjxXo") + , (unsafeChainId 84, unsafeFromText "s26jheDzrGXuWZ8mddMkIDU9UICfsRg9z-TQwDCRWos") + , (unsafeChainId 85, unsafeFromText "ZTR2dcyy-ZgOX5OVsKMV0t4Bkp4mf2ocvUs8KGZVw74") + , (unsafeChainId 86, unsafeFromText "AnmY1tCYiwIf35bZZXXdx3ZVOfmwsT0jvOlLA0s0NHY") + , (unsafeChainId 87, unsafeFromText "aBL54Dj7EkUqrrWykyQfFGa9vCf3nS34QogArm33188") + , (unsafeChainId 88, unsafeFromText "YGs9zbwtzR0FqoVwAITceumfKfCMilFYfSxkJU6pf70") + , (unsafeChainId 89, unsafeFromText "J1CdN2TlCux7xAoX8m7fdGyJHV_IeEgboyQMvI2ToO8") + , (unsafeChainId 90, unsafeFromText "_mphcuK5KOq2_-DQB9bqlM6C4f6eAnO7cCLSK--gLsE") + , (unsafeChainId 91, unsafeFromText "TvoF0OcZ86zj_C9nExaubCzXRgGTGMQ9wViM1Zm0f-A") + , (unsafeChainId 92, unsafeFromText "dAAvn6c3IkClNgEpjSTt-ZrPCG8YcqBsma_vvLnRji4") + , (unsafeChainId 93, unsafeFromText "RBJolQY0GKyqcGBUef18tAr51aRS52IQ8HJoJX6EPR8") + , (unsafeChainId 94, unsafeFromText "lPLkYdoQHw_auHSFnlcNL3fI_oI2b5jCCpaSXbw5rZ4") + , (unsafeChainId 95, unsafeFromText "M4Webe0zta7bJ_53pHTIjU5d25TLG6FISfiLw1eFFgg") + , (unsafeChainId 96, unsafeFromText "jiQb8cx7bl48fvqA6QeLXh_YXP2Bzg8gSroKGfceqUk") + , (unsafeChainId 97, unsafeFromText "ZE5xfgDK6KW4q8o98qCWZ4NJL74NiMG1hu3DUZrHatI") + ] + } + + -- still the *default* block gas limit is set, see + -- defaultChainwebConfiguration._configBlockGasLimit + , _versionMaxBlockGasLimit = Bottom (minBound, Nothing) + , _versionCheats = VersionCheats + { _disablePow = True + , _fakeFirstEpochStart = True + , _disablePact = False + } + , _versionDefaults = VersionDefaults + { _disablePeerValidation = True + , _disableMempoolSync = False + } + , _versionVerifierPluginNames = onAllChains $ Bottom + (minBound, Set.fromList $ map VerifierName ["hyperlane_v3_message", "allow"]) + , _versionQuirks = noQuirks + + -- FIXME make this safe for graph changes + , _versionPayloadProviderTypes = onChains + $ [ (unsafeChainId i, PactProvider) | i <- [0..19] ] + <> [ (unsafeChainId i, EvmProvider (1789 - 20 + int i)) | i <- [20..24] ] + <> [ (unsafeChainId i, MinimalProvider) | i <- [25..97] ] + } diff --git a/src/Chainweb/Version/EvmDevelopmentSingleton.hs b/src/Chainweb/Version/EvmDevelopmentSingleton.hs new file mode 100644 index 0000000000..a359f9df49 --- /dev/null +++ b/src/Chainweb/Version/EvmDevelopmentSingleton.hs @@ -0,0 +1,155 @@ +{-# language LambdaCase #-} +{-# language NumericUnderscores #-} +{-# language OverloadedStrings #-} +{-# language PatternSynonyms #-} +{-# language QuasiQuotes #-} +{-# language ViewPatterns #-} + +module Chainweb.Version.EvmDevelopmentSingleton +( evmDevnetSingleton +, pattern EvmDevelopmentSingleton +, evmDevnetPair +, pattern EvmDevelopmentPair +) where + +import qualified Data.Set as Set + +import Chainweb.BlockCreationTime +import Chainweb.ChainId +import Chainweb.Difficulty +import Chainweb.Graph +import Chainweb.Time +import Chainweb.Utils +import Chainweb.Utils.Rule +import Chainweb.Pact.InitialGasModel (post32GasModel) +import Chainweb.Version + +import Pact.Core.Names + +pattern EvmDevelopmentSingleton :: ChainwebVersion +pattern EvmDevelopmentSingleton <- ((== evmDevnetSingleton) -> True) where + EvmDevelopmentSingleton = evmDevnetSingleton + +pattern EvmDevelopmentPair :: ChainwebVersion +pattern EvmDevelopmentPair <- ((== evmDevnetPair) -> True) where + EvmDevelopmentPair = evmDevnetPair + +-- How to compute the hashes: +-- +-- Mininal Payload Provider: +-- +-- @ +-- -- create dummy payload hashes +-- import Chainweb.PayloadProvider.Minimal.Payload +-- import Chainweb.Version.EvmDevelopmentSingleton +-- +-- mapM_ (\i -> T.putStrLn (sshow i <> " " <> encodeToText (view payloadHash $ genesisPayload EvmDevelopment $ unsafeChainId i))) [25..97] +-- @ +-- +-- EVM Payload Provider: +-- +-- @ +-- cabal run evm-genesis -- evm-development +-- @ +-- +-- Pact Provider: +-- +-- TODO (use ea?) + +evmDevnetPair :: ChainwebVersion +evmDevnetPair = withVersion evmDevnetPair $ ChainwebVersion + { _versionCode = ChainwebVersionCode 0x0001_000b + , _versionName = ChainwebVersionName "evm-development-pair" + , _versionForks = tabulateHashMap $ const $ onAllChains ForkAtGenesis + , _versionUpgrades = onAllChains mempty + , _versionForkNumber = 1 + , _versionForkVoteCastingLength = 20 + , _versionSpvProofRootValidWindow = Bottom (minBound, Nothing) + , _versionInitialGasModel = onAllChains $ Bottom (minBound, post32GasModel) + , _versionGraphs = Bottom (minBound, pairChainGraph) + , _versionBlockDelay = BlockDelay 30_000_000 + , _versionWindow = WindowWidth 120 + , _versionHeaderBaseSizeBytes = 318 - 110 + , _versionBootstraps = [] + , _versionGenesis = VersionGenesis + { _genesisBlockTarget = onAllChains $ HashTarget (maxBound `div` 10_000) + , _genesisTime = onChains + -- FIXME: is the creation time for the pact headers correct? + [ (unsafeChainId 0, BlockCreationTime [timeMicrosQQ| 2025-01-01T00:00:00.000000 |]) + , (unsafeChainId 1, BlockCreationTime (Time (secondsToTimeSpan 0x684c5d2a))) + ] + , _genesisBlockPayload = onChains $ + -- Pact Payload Provider + [ (unsafeChainId 0, unsafeFromText "QzxVHFZ5go4PYd3QeAZhxP61hsVnICPw4BB9h-T3PDM") + -- EVM Payload Provider + , (unsafeChainId 1, unsafeFromText "Mpz2KloCngRUW3Q--WeNWOz_xSBGK_uVaFnqWVv4IwA") + ] + } + + -- still the *default* block gas limit is set, see + -- defaultChainwebConfiguration._configBlockGasLimit + , _versionMaxBlockGasLimit = Bottom (minBound, Nothing) + , _versionCheats = VersionCheats + { _disablePow = True + , _fakeFirstEpochStart = True + , _disablePact = False + } + , _versionDefaults = VersionDefaults + { _disablePeerValidation = True + , _disableMempoolSync = False + } + , _versionVerifierPluginNames = onAllChains $ Bottom + (minBound, Set.fromList $ map VerifierName ["hyperlane_v3_message", "allow"]) + , _versionQuirks = noQuirks + + -- FIXME make this safe for graph changes + , _versionPayloadProviderTypes = onChains + [ (unsafeChainId 0, PactProvider) + , (unsafeChainId 1, EvmProvider 1789) + ] + } + +evmDevnetSingleton :: ChainwebVersion +evmDevnetSingleton = withVersion evmDevnetSingleton $ ChainwebVersion + { _versionCode = ChainwebVersionCode 0x0001_000c + , _versionName = ChainwebVersionName "evm-development-singleton" + , _versionForks = tabulateHashMap $ const $ onAllChains ForkAtGenesis + , _versionUpgrades = onAllChains mempty + , _versionForkNumber = 1 + , _versionForkVoteCastingLength = 20 + , _versionSpvProofRootValidWindow = Bottom (minBound, Nothing) + , _versionInitialGasModel = onAllChains $ Bottom (minBound, post32GasModel) + , _versionGraphs = Bottom (minBound, singletonChainGraph) + , _versionBlockDelay = BlockDelay 30_000_000 + , _versionWindow = WindowWidth 120 + , _versionHeaderBaseSizeBytes = 318 - 110 + , _versionBootstraps = [] + , _versionGenesis = VersionGenesis + { _genesisBlockTarget = onAllChains $ HashTarget (maxBound `div` 10_000) + , _genesisTime = onChains + [ (unsafeChainId 0, BlockCreationTime (Time (secondsToTimeSpan 0x684c5d2a))) ] + , _genesisBlockPayload = onChains $ + -- EVM Payload Provider + [ (unsafeChainId 0, unsafeFromText "j58y6G5KXAqWPPl-mG3nHiKh9vhd_xCqybC6cXjLnS4") ] + } + + -- still the *default* block gas limit is set, see + -- defaultChainwebConfiguration._configBlockGasLimit + , _versionMaxBlockGasLimit = Bottom (minBound, Nothing) + , _versionCheats = VersionCheats + { _disablePow = True + , _fakeFirstEpochStart = True + , _disablePact = False + } + , _versionDefaults = VersionDefaults + { _disablePeerValidation = True + , _disableMempoolSync = False + } + , _versionVerifierPluginNames = onAllChains $ Bottom + (minBound, Set.fromList $ map VerifierName ["hyperlane_v3_message", "allow"]) + , _versionQuirks = noQuirks + + -- FIXME make this safe for graph changes + , _versionPayloadProviderTypes = onChains + [ (unsafeChainId 0, EvmProvider 1789) ] + } diff --git a/src/Chainweb/Version/EvmTestnet.hs b/src/Chainweb/Version/EvmTestnet.hs new file mode 100644 index 0000000000..6389a670c4 --- /dev/null +++ b/src/Chainweb/Version/EvmTestnet.hs @@ -0,0 +1,202 @@ +{-# language LambdaCase #-} +{-# language NumericUnderscores #-} +{-# language OverloadedStrings #-} +{-# language PatternSynonyms #-} +{-# language QuasiQuotes #-} +{-# language ViewPatterns #-} + +module Chainweb.Version.EvmTestnet +( evmTestnet +, pattern EvmTestnet +) where + +import qualified Data.Set as Set + +import Chainweb.BlockCreationTime +import Chainweb.ChainId +import Chainweb.Difficulty +import Chainweb.Pact.InitialGasModel +import Chainweb.Graph +import Chainweb.Time +import Chainweb.Utils +import Chainweb.Utils.Rule +import Chainweb.Version + +import Pact.Core.Names +import P2P.BootstrapNodes (evmTestnetBootstrapHosts) + +pattern EvmTestnet :: ChainwebVersion +pattern EvmTestnet <- ((== evmTestnet) -> True) where + EvmTestnet = evmTestnet + +-- How to compute the hashes: +-- +-- Mininal Payload Provider: +-- +-- @ +-- -- create dummy payload hashes +-- import Chainweb.PayloadProvider.Minimal.Payload +-- import Chainweb.Version.EvmTestnet +-- +-- mapM_ (\i -> T.putStrLn (sshow i <> " " <> encodeToText (view payloadHash $ genesisPayload EvmTestnet $ unsafeChainId i))) [25..97] +-- @ +-- +-- EVM Payload Provider: +-- +-- @ +-- $(cabal list-bin evm-genesis) evm-testnet +-- @ +-- +-- Pact Provider: +-- +-- TODO (use ea?) + +evmTestnet :: ChainwebVersion +evmTestnet = withVersion evmTestnet $ ChainwebVersion + { _versionCode = ChainwebVersionCode 0x0000_000a + , _versionName = ChainwebVersionName "evm-testnet" + , _versionForks = tabulateHashMap $ const $ onAllChains ForkAtGenesis + , _versionUpgrades = onAllChains mempty + , _versionForkNumber = 1 + , _versionForkVoteCastingLength = 20 + , _versionSpvProofRootValidWindow = Bottom (minBound, Nothing) + , _versionInitialGasModel = onAllChains $ Bottom (minBound, post32GasModel) + , _versionGraphs = Bottom (minBound, d4k4ChainGraph) + , _versionBlockDelay = BlockDelay 30_000_000 + , _versionWindow = WindowWidth 120 + , _versionHeaderBaseSizeBytes = 318 - 110 + , _versionBootstraps = domainAddr2PeerInfo evmTestnetBootstrapHosts + , _versionGenesis = VersionGenesis + { _genesisBlockTarget = onAllChains $ HashTarget (maxBound `div` 100_000) + , _genesisTime = onChains + -- FIXME: is the creation time for the pact headers correct? + $ [ (unsafeChainId i, BlockCreationTime [timeMicrosQQ| 2025-01-01T00:00:00.000000 |]) | i <- [0..19] ] + <> [ (unsafeChainId i, BlockCreationTime (Time (secondsToTimeSpan 0x684c5d2a))) | i <- [20..24] ] + <> [ (unsafeChainId i, BlockCreationTime [timeMicrosQQ| 2025-01-01T00:00:00.000000 |]) | i <- [25..97] ] + , _genesisBlockPayload = onChains + -- Pact Payload Provider + [ (unsafeChainId 0, unsafeFromText "QzxVHFZ5go4PYd3QeAZhxP61hsVnICPw4BB9h-T3PDM") + , (unsafeChainId 1, unsafeFromText "66JSEmDIl6AqWTKN29LprukaeUmK0OOd4RufVO8e6-4") + , (unsafeChainId 2, unsafeFromText "66JSEmDIl6AqWTKN29LprukaeUmK0OOd4RufVO8e6-4") + , (unsafeChainId 3, unsafeFromText "66JSEmDIl6AqWTKN29LprukaeUmK0OOd4RufVO8e6-4") + , (unsafeChainId 4, unsafeFromText "66JSEmDIl6AqWTKN29LprukaeUmK0OOd4RufVO8e6-4") + , (unsafeChainId 5, unsafeFromText "66JSEmDIl6AqWTKN29LprukaeUmK0OOd4RufVO8e6-4") + , (unsafeChainId 6, unsafeFromText "66JSEmDIl6AqWTKN29LprukaeUmK0OOd4RufVO8e6-4") + , (unsafeChainId 7, unsafeFromText "66JSEmDIl6AqWTKN29LprukaeUmK0OOd4RufVO8e6-4") + , (unsafeChainId 8, unsafeFromText "66JSEmDIl6AqWTKN29LprukaeUmK0OOd4RufVO8e6-4") + , (unsafeChainId 9, unsafeFromText "66JSEmDIl6AqWTKN29LprukaeUmK0OOd4RufVO8e6-4") + , (unsafeChainId 10, unsafeFromText "66JSEmDIl6AqWTKN29LprukaeUmK0OOd4RufVO8e6-4") + , (unsafeChainId 11, unsafeFromText "66JSEmDIl6AqWTKN29LprukaeUmK0OOd4RufVO8e6-4") + , (unsafeChainId 12, unsafeFromText "66JSEmDIl6AqWTKN29LprukaeUmK0OOd4RufVO8e6-4") + , (unsafeChainId 13, unsafeFromText "66JSEmDIl6AqWTKN29LprukaeUmK0OOd4RufVO8e6-4") + , (unsafeChainId 14, unsafeFromText "66JSEmDIl6AqWTKN29LprukaeUmK0OOd4RufVO8e6-4") + , (unsafeChainId 15, unsafeFromText "66JSEmDIl6AqWTKN29LprukaeUmK0OOd4RufVO8e6-4") + , (unsafeChainId 16, unsafeFromText "66JSEmDIl6AqWTKN29LprukaeUmK0OOd4RufVO8e6-4") + , (unsafeChainId 17, unsafeFromText "66JSEmDIl6AqWTKN29LprukaeUmK0OOd4RufVO8e6-4") + , (unsafeChainId 18, unsafeFromText "66JSEmDIl6AqWTKN29LprukaeUmK0OOd4RufVO8e6-4") + , (unsafeChainId 19, unsafeFromText "66JSEmDIl6AqWTKN29LprukaeUmK0OOd4RufVO8e6-4") + -- EVM Payload Provider + , (unsafeChainId 20, unsafeFromText "WaNoJ17itOufUCumv0lj6OXC9PUFxITPlgHNc9wfPjk") + , (unsafeChainId 21, unsafeFromText "OLCBUaUhSJPIgzrZOUVLWRF2fcHR-GF3mLXrIyp-BL4") + , (unsafeChainId 22, unsafeFromText "uO7Z-HX0miQj9byBZmsGHRl1uzyp_pxcz3RWZrJH-Xw") + , (unsafeChainId 23, unsafeFromText "QwDXwhfUmv-H0ZY_V_GHxqaMc2m3gp0VBquH66SUZxg") + , (unsafeChainId 24, unsafeFromText "HMkFs_GR7Zrrgk56obxtVnR8B7UQwCffTvZ58RLtFgQ") + -- Minimal Payload Provider + , (unsafeChainId 25, unsafeFromText "Gt116uJVwjUEM0f07u_x8-SUFHgGpoH1xf3sfPoe0ZY") + , (unsafeChainId 26, unsafeFromText "NLRP0OiqRldiZclvoKBGhv9m5wO0TrhNKaZZslZuZvw") + , (unsafeChainId 27, unsafeFromText "xAOBFMKZ_lSHNVhHW-GhbhiWh6sX48S2KPyyPMjAnZM") + , (unsafeChainId 28, unsafeFromText "eav79QetdNuKo1HDW27Aeqbxr8oAt6Fh2U6ZtSfVyYU") + , (unsafeChainId 29, unsafeFromText "jlcxQ4wXUrApJDUQRS8KxuSyoG7ZFEwLV4-92wmqLOQ") + , (unsafeChainId 30, unsafeFromText "odUxYpZ8ZeW0WuQcibJH3isuI045MuEEeQqLrkivWEk") + , (unsafeChainId 31, unsafeFromText "poJ65aDiZYYthbhrgUI2jJS_8vK1CTHRE2C6dLbjTXA") + , (unsafeChainId 32, unsafeFromText "SC3ol1uFOHAewfQrMQczKrvhE8Dw1Bp9fBzNi9l_zTw") + , (unsafeChainId 33, unsafeFromText "p38GsNdY-T8ULYN1OTpYyO1E7WOGwzE2g92aIPereUw") + , (unsafeChainId 34, unsafeFromText "1V0SzqA9fHDOMnfvXvSd57H0r-iycjjLu3CKkRLcjRk") + , (unsafeChainId 35, unsafeFromText "SeiRMENBv5XqR7wXUYSR2orjGHSUrtawx5gLrDCfZYA") + , (unsafeChainId 36, unsafeFromText "JpsiIjm8aZEbyrcsMqLDneT0BNoJAJunk4BYqDO_1Y0") + , (unsafeChainId 37, unsafeFromText "0yx4OFT3sbLS_wrqpULgPpgzzxmMRwM6VTmkasitTlA") + , (unsafeChainId 38, unsafeFromText "Z3LE9JHGpSYuR3SvoYWPae7zB9-X05vFLjwD4GnXX_A") + , (unsafeChainId 39, unsafeFromText "9ZHBlxeYPWjhvMySgVx3ThEyooYx724zjORClgmq8Lk") + , (unsafeChainId 40, unsafeFromText "H3VBsNGh-SQE-0d_qlYSHnS2obzUeo6Zi1XDDvhndYo") + , (unsafeChainId 41, unsafeFromText "N6hVHz6vo0frpS3eyqvtMeZg1eFbAMJ1CS315M-JpWw") + , (unsafeChainId 42, unsafeFromText "9mo8CRwvTLLJ4cSQtErBfOIxzwpale-AwnbXPWQd184") + , (unsafeChainId 43, unsafeFromText "SotTkMw2Eq5UbOObv5kyaUlMqHp6-PUSKDeLHWYCr2s") + , (unsafeChainId 44, unsafeFromText "1IB27CAQ6MpXFV-OiyDVIxbXh91BK2Bl6PYiAwvyg-E") + , (unsafeChainId 45, unsafeFromText "ou9ns1_Q72IsaXoVjCErGGGmzsI07IIx6Vo14gU0Fl8") + , (unsafeChainId 46, unsafeFromText "dZsEBdKKdeLkTS35IV54npY01mB9HOWO3TvoXE0xoWg") + , (unsafeChainId 47, unsafeFromText "oLbpBWhnhCdKHy_q009-06PYug12KMtA5u9mv82_I8s") + , (unsafeChainId 48, unsafeFromText "coBTWu6iFvyDX_3W2dSnuwK9WheRa9_40kh564myiXw") + , (unsafeChainId 49, unsafeFromText "fiOvn4JEAf7NXGAP3YkXhygalCnKCwzhe2dC1VO4YiU") + , (unsafeChainId 50, unsafeFromText "UL6_gjNoxuryRd3xBj3OU00A6IjvHtdnggucOISDgc4") + , (unsafeChainId 51, unsafeFromText "Wtu06D5r5DcNSZ8ZxxPv3Jvq4dtYW1PnHJtrxmdVSzw") + , (unsafeChainId 52, unsafeFromText "yrSDpQnAtnw-WYVrXMd-zAt2ZCOBNz7mACG-UjX5Tl0") + , (unsafeChainId 53, unsafeFromText "c743P-dTKKA6PpKCJ6ZC9im7bo1BpJWViZ6xjZJokkw") + , (unsafeChainId 54, unsafeFromText "qlj-G-PO_TtM5mp2C6UI6GgVWR2H1um2v6VOMrXjX4M") + , (unsafeChainId 55, unsafeFromText "XO6ZWLmRlyiGygt2pdDZpxZfwHrmkLsBM99rJSxa31M") + , (unsafeChainId 56, unsafeFromText "jiXkFn_Nv73-X8d3xUtsY25lNN2g35sjSsu43X1pOEM") + , (unsafeChainId 57, unsafeFromText "Dr15tRuU6JSXOARB46_r1DGb9e2WX4a61BoiJ9Uq5p0") + , (unsafeChainId 58, unsafeFromText "KYlhzAW01sBwnO2dXl9_0BuRNV64nJJCSSo6JdDNMZA") + , (unsafeChainId 59, unsafeFromText "ywo1yl72s89SQibkkKuRm4tmBnp8guONArOLa03lETU") + , (unsafeChainId 60, unsafeFromText "t4u3_IuTXANdi2NrM2prmWCOFSc3AkrwHYziL1LSsEU") + , (unsafeChainId 61, unsafeFromText "Ucp32OmDetbZPozGHES6F7HKqbAnIfynOsfCzUo3lDI") + , (unsafeChainId 62, unsafeFromText "VEsZDVjM1lJkfJUWTXEyC7wH27vgDoviFD2Rt22vJ1I") + , (unsafeChainId 63, unsafeFromText "NDsftZSHa8N1yDdkgQJQ1rk1J3vRFFxFzCSrd8SzEUo") + , (unsafeChainId 64, unsafeFromText "80yIgBalnINZyprtYhZVCgOgMbB2DoW5Xq42FJf7nKk") + , (unsafeChainId 65, unsafeFromText "BMi5YZ0GpYTemGe6x_FtXEI5JTO9rinekaNnhEV87Jc") + , (unsafeChainId 66, unsafeFromText "uAIl8FGVbOPzitFHovTPJtPHaCQzYA8ZOaE6PxBx3Ng") + , (unsafeChainId 67, unsafeFromText "tmzmkzngbTHNfywBySBDE-OLXwhjgn2gNhqK86uFRXk") + , (unsafeChainId 68, unsafeFromText "MNkeZut1raJk7-Vh6Yf2HR-Lhf7x97ZYqtZvM-czHmA") + , (unsafeChainId 69, unsafeFromText "BMa_Ucv2c0Q9TU9wE8HZaX5hFv919yqh57s_ijfb0aA") + , (unsafeChainId 70, unsafeFromText "YZlG4QzDr285OQMCs5k9ZS6SNYSNjq2gr9RnJ1DmyBw") + , (unsafeChainId 71, unsafeFromText "ZDwNBLBZSTRertPlENXC6CUj6StykJLucUnN_DydnLc") + , (unsafeChainId 72, unsafeFromText "BtxzFZrXiRYOMouRmU7eA9pohvahn_GdKPREhcuGCY4") + , (unsafeChainId 73, unsafeFromText "cGIf74TXx8V_XrUUr2B9MU8adtQeQc1hpk6XOey1GOU") + , (unsafeChainId 74, unsafeFromText "j3hvD0Yjztjc_trqX4OMHPOqEWTd04GKvPfmt4r92D8") + , (unsafeChainId 75, unsafeFromText "eSIZD24zvKNw-2OJtWJujayy3AKU2h11RhRWZUC6MtM") + , (unsafeChainId 76, unsafeFromText "P3H3_4I6vJTQOszcrYreI6LOhSRVgVv7Hb0nFawzbsM") + , (unsafeChainId 77, unsafeFromText "CKomlT6tiEs6DCa2VNy3519TjAiwFNx8EkkI54JKY0I") + , (unsafeChainId 78, unsafeFromText "2NldG3su7R_RXpes25X09t8evnjNMuZoL8j3PcNMfXE") + , (unsafeChainId 79, unsafeFromText "fMlZOHs-mzu5u2DXAiCKzhZNOlCMROY2YXxHMCdiHyo") + , (unsafeChainId 80, unsafeFromText "mDocxA63bstQQ-vqzM02_avZmSjrPFFxcvcVa6ZCYMU") + , (unsafeChainId 81, unsafeFromText "hqkNDhLpy-9usTAyu77mvwoCD8YDlW9O66EFQ98ARsg") + , (unsafeChainId 82, unsafeFromText "jSGKQqn_KP4RbFsbTT_6VWFTj9WOqAqv-INoMyJntAw") + , (unsafeChainId 83, unsafeFromText "fvOd-k-4j_OFmAQo1M2Vy1T2O18UkpcjRYlSMVcjxXo") + , (unsafeChainId 84, unsafeFromText "s26jheDzrGXuWZ8mddMkIDU9UICfsRg9z-TQwDCRWos") + , (unsafeChainId 85, unsafeFromText "ZTR2dcyy-ZgOX5OVsKMV0t4Bkp4mf2ocvUs8KGZVw74") + , (unsafeChainId 86, unsafeFromText "AnmY1tCYiwIf35bZZXXdx3ZVOfmwsT0jvOlLA0s0NHY") + , (unsafeChainId 87, unsafeFromText "aBL54Dj7EkUqrrWykyQfFGa9vCf3nS34QogArm33188") + , (unsafeChainId 88, unsafeFromText "YGs9zbwtzR0FqoVwAITceumfKfCMilFYfSxkJU6pf70") + , (unsafeChainId 89, unsafeFromText "J1CdN2TlCux7xAoX8m7fdGyJHV_IeEgboyQMvI2ToO8") + , (unsafeChainId 90, unsafeFromText "_mphcuK5KOq2_-DQB9bqlM6C4f6eAnO7cCLSK--gLsE") + , (unsafeChainId 91, unsafeFromText "TvoF0OcZ86zj_C9nExaubCzXRgGTGMQ9wViM1Zm0f-A") + , (unsafeChainId 92, unsafeFromText "dAAvn6c3IkClNgEpjSTt-ZrPCG8YcqBsma_vvLnRji4") + , (unsafeChainId 93, unsafeFromText "RBJolQY0GKyqcGBUef18tAr51aRS52IQ8HJoJX6EPR8") + , (unsafeChainId 94, unsafeFromText "lPLkYdoQHw_auHSFnlcNL3fI_oI2b5jCCpaSXbw5rZ4") + , (unsafeChainId 95, unsafeFromText "M4Webe0zta7bJ_53pHTIjU5d25TLG6FISfiLw1eFFgg") + , (unsafeChainId 96, unsafeFromText "jiQb8cx7bl48fvqA6QeLXh_YXP2Bzg8gSroKGfceqUk") + , (unsafeChainId 97, unsafeFromText "ZE5xfgDK6KW4q8o98qCWZ4NJL74NiMG1hu3DUZrHatI") + ] + } + + -- still the *default* block gas limit is set, see + -- defaultChainwebConfiguration._configBlockGasLimit + , _versionMaxBlockGasLimit = Bottom (minBound, Nothing) + , _versionCheats = VersionCheats + { _disablePow = True + , _fakeFirstEpochStart = True + , _disablePact = False + } + , _versionDefaults = VersionDefaults + { _disablePeerValidation = True + , _disableMempoolSync = False + } + , _versionVerifierPluginNames = onAllChains $ Bottom + (minBound, Set.fromList $ map VerifierName ["hyperlane_v3_message", "allow"]) + , _versionQuirks = noQuirks + + -- FIXME make this safe for graph changes + , _versionPayloadProviderTypes = onChains + $ [ (unsafeChainId i, PactProvider) | i <- [0..19] ] + <> [ (unsafeChainId i, EvmProvider (5920 - 20 + int i)) | i <- [20..24] ] + <> [ (unsafeChainId i, MinimalProvider) | i <- [25..97] ] + } diff --git a/src/Chainweb/Version/Guards.hs b/src/Chainweb/Version/Guards.hs index cd1ef7af8a..b64ebe638a 100644 --- a/src/Chainweb/Version/Guards.hs +++ b/src/Chainweb/Version/Guards.hs @@ -55,13 +55,13 @@ module Chainweb.Version.Guards , migratePlatformShare , pact5 , pact44NewTrans - , pact4ParserVersion , maxBlockGasLimit , minimumBlockHeaderHistory , activeInitialGasModel , validPPKSchemes - , isWebAuthnPrefixLegal , validKeyFormats + , isWebAuthnPrefixLegal + , pact4ParserVersion , pact5Serialiser -- ** BlockHeader Validation Guards @@ -69,6 +69,7 @@ module Chainweb.Version.Guards , oldTargetGuard , skipFeatureFlagValidationGuard , oldDaGuard + , hashedAdjacentRecord ) where import Chainweb.BlockHeight @@ -77,33 +78,32 @@ import Chainweb.Pact4.Transaction qualified as Pact4 import Chainweb.Utils.Rule import Chainweb.ForkState import Chainweb.Version -import Chainweb.Pact5.InitialGasModel +import Chainweb.Pact.InitialGasModel import Control.Lens import Data.Word (Word64) import Numeric.Natural -import Pact.Core.Builtin qualified as Pact5 -import Pact.Core.Info qualified as Pact5 -import Pact.Core.Serialise qualified as Pact5 +import Pact.Core.Builtin qualified as Pact +import Pact.Core.Info qualified as Pact +import Pact.Core.Serialise qualified as Pact import Pact.Types.KeySet (PublicKeyText, ed25519HexFormat, webAuthnFormat) import Pact.Types.Scheme (PPKScheme(ED25519, WebAuthn)) --- Gets the height which the fork is associated with. --- This may not be the first height at which the associated guard is `True` --- necessarily; check the guard to see how it uses the fork's height. -getForkHeight :: Fork -> ChainwebVersion -> ChainId -> ForkHeight -getForkHeight fork v cid = v ^?! versionForks . at fork . _Just . atChain cid +getForkHeight :: HasVersion => Fork -> ChainId -> ForkHeight +getForkHeight fork cid = implicitVersion ^?! versionForks . at fork . _Just . atChain cid -- Check Fork by height checkFork - :: (ForkHeight -> ForkHeight -> Bool) - -> Fork -> ChainwebVersion -> ChainId -> BlockHeight -> Bool -checkFork p f v cid h = p (ForkAtBlockHeight h) (getForkHeight f v cid) + :: HasVersion + => (ForkHeight -> ForkHeight -> Bool) + -> Fork -> ChainId -> BlockHeight -> Bool +checkFork p f cid h = p (ForkAtBlockHeight h) (getForkHeight f cid) -- CheckFork by forkNumber checkFork' - :: (ForkHeight -> ForkHeight -> Bool) - -> Fork -> ChainwebVersion -> ChainId -> ForkNumber -> Bool -checkFork' p f v cid fn = p (ForkAtForkNumber fn) (getForkHeight f v cid) + :: HasVersion + => (ForkHeight -> ForkHeight -> Bool) + -> Fork -> ChainId -> ForkNumber -> Bool +checkFork' p f cid fn = p (ForkAtForkNumber fn) (getForkHeight f cid) after :: ForkHeight -> ForkHeight -> Bool @@ -162,8 +162,8 @@ atNotGenesis fh fh' = fh == fh' -- is usually more important than throughput. -- slowEpochGuard - :: ChainwebVersion - -> ChainId + :: HasVersion + => ChainId -> BlockHeight -- ^ BlockHeight of parent Header -> Bool @@ -176,7 +176,7 @@ slowEpochGuard = checkFork before SlowEpoch -- blocks. The target computation won't compensate for that, since the effects -- are marginal. -- -oldTargetGuard :: ChainwebVersion -> ChainId -> BlockHeight -> Bool +oldTargetGuard :: HasVersion => ChainId -> BlockHeight -> Bool oldTargetGuard = checkFork before OldTargetGuard -- | Skip validation of feature flags. @@ -186,20 +186,20 @@ oldTargetGuard = checkFork before OldTargetGuard -- live chains, enforcing the following condition must be ignored for the -- historical blocks for which both the Nonce and Flags could be anything. -- -skipFeatureFlagValidationGuard :: ChainwebVersion -> ChainId -> BlockHeight -> Bool +skipFeatureFlagValidationGuard :: HasVersion => ChainId -> BlockHeight -> Bool skipFeatureFlagValidationGuard = checkFork before SkipFeatureFlagValidation -oldDaGuard :: ChainwebVersion -> ChainId -> BlockHeight -> Bool +oldDaGuard :: HasVersion => ChainId -> BlockHeight -> Bool oldDaGuard = checkFork before OldDAGuard ----------------- -- Payload validation guards -vuln797Fix :: ChainwebVersion -> ChainId -> BlockHeight -> Bool +vuln797Fix :: HasVersion => ChainId -> BlockHeight -> Bool vuln797Fix = checkFork atOrAfter Vuln797Fix -- | Preserve Pact bugs pre-1.6 chainweb. -pactBackCompat_v16 :: ChainwebVersion -> ChainId -> BlockHeight -> Bool +pactBackCompat_v16 :: HasVersion => ChainId -> BlockHeight -> Bool pactBackCompat_v16 = checkFork before PactBackCompat_v16 -- | Early versions of chainweb used the creation time of the current header @@ -208,175 +208,195 @@ pactBackCompat_v16 = checkFork before PactBackCompat_v16 -- -- When this guard is enabled timing validation is skipped. -- -skipTxTimingValidation :: ChainwebVersion -> ChainId -> BlockHeight -> Bool +skipTxTimingValidation :: HasVersion => ChainId -> BlockHeight -> Bool skipTxTimingValidation = checkFork before SkipTxTimingValidation -- | Checks height after which module name fix in effect. -- -enableModuleNameFix :: ChainwebVersion -> ChainId -> BlockHeight -> Bool +enableModuleNameFix :: HasVersion => ChainId -> BlockHeight -> Bool enableModuleNameFix = checkFork atOrAfter ModuleNameFix -- | Related, later fix (Pact #801). -- -enableModuleNameFix2 :: ChainwebVersion -> ChainId -> BlockHeight -> Bool +enableModuleNameFix2 :: HasVersion => ChainId -> BlockHeight -> Bool enableModuleNameFix2 = checkFork atOrAfter ModuleNameFix2 -- | Turn on pact events in command output. -enablePactEvents :: ChainwebVersion -> ChainId -> BlockHeight -> Bool +enablePactEvents :: HasVersion => ChainId -> BlockHeight -> Bool enablePactEvents = checkFork atOrAfter PactEvents -- | Bridge support: ETH and event SPV. -enableSPVBridge :: ChainwebVersion -> ChainId -> BlockHeight -> Bool +enableSPVBridge :: HasVersion => ChainId -> BlockHeight -> Bool enableSPVBridge = checkFork atOrAfter SPVBridge -- | Should Pact check that keysets have a legal format? -enforceKeysetFormats :: ChainwebVersion -> ChainId -> BlockHeight -> Bool +enforceKeysetFormats :: HasVersion => ChainId -> BlockHeight -> Bool enforceKeysetFormats = checkFork atOrAfter EnforceKeysetFormats --- | Should Pact check that the `hash` included with a `Command` is correct? -doCheckTxHash :: ChainwebVersion -> ChainId -> BlockHeight -> Bool +doCheckTxHash :: HasVersion => ChainId -> BlockHeight -> Bool doCheckTxHash = checkFork atOrAfter CheckTxHash -- | Fork for musl trans funs -pact44NewTrans :: ChainwebVersion -> ChainId -> BlockHeight -> Bool +pact44NewTrans :: HasVersion => ChainId -> BlockHeight -> Bool pact44NewTrans = checkFork atOrAfter Pact44NewTrans -- | Pact 4.0 features -pact4Coin3 :: ChainwebVersion -> ChainId -> BlockHeight -> Bool +pact4Coin3 :: HasVersion => ChainId -> BlockHeight -> Bool pact4Coin3 = checkFork after Pact4Coin3 -- | Pact 4.2 features -pact42 :: ChainwebVersion -> ChainId -> BlockHeight -> Bool +pact42 :: HasVersion => ChainId -> BlockHeight -> Bool pact42 = checkFork atOrAfter Pact42 -- | Pact charges gas for the size of transitive module dependencies -chainweb213Pact :: ChainwebVersion -> ChainId -> BlockHeight -> Bool +chainweb213Pact :: HasVersion => ChainId -> BlockHeight -> Bool chainweb213Pact = checkFork atOrAfter Chainweb213Pact -- | Pact 4.3 features -chainweb214Pact :: ChainwebVersion -> ChainId -> BlockHeight -> Bool +chainweb214Pact :: HasVersion => ChainId -> BlockHeight -> Bool chainweb214Pact = checkFork after Chainweb214Pact -- | Pact 4.3.1 features -chainweb215Pact :: ChainwebVersion -> ChainId -> BlockHeight -> Bool +chainweb215Pact :: HasVersion => ChainId -> BlockHeight -> Bool chainweb215Pact = checkFork after Chainweb215Pact -- | Pact 4.4 features, including new expression parser -chainweb216Pact :: ChainwebVersion -> ChainId -> BlockHeight -> Bool +chainweb216Pact :: HasVersion => ChainId -> BlockHeight -> Bool chainweb216Pact = checkFork after Chainweb216Pact -- | Pact 4.5 features, and considering all table names lowercase -chainweb217Pact :: ChainwebVersion -> ChainId -> BlockHeight -> Bool +chainweb217Pact :: HasVersion => ChainId -> BlockHeight -> Bool chainweb217Pact = checkFork after Chainweb217Pact -- | Pact 4.6 features -chainweb218Pact :: ChainwebVersion -> ChainId -> BlockHeight -> Bool +chainweb218Pact :: HasVersion => ChainId -> BlockHeight -> Bool chainweb218Pact = checkFork atOrAfter Chainweb218Pact -- | Pact 4.7 features + new SPV errors without callstacks -chainweb219Pact :: ChainwebVersion -> ChainId -> BlockHeight -> Bool +chainweb219Pact :: HasVersion => ChainId -> BlockHeight -> Bool chainweb219Pact = checkFork atOrAfter Chainweb219Pact -- | Pact 4.8 features -chainweb220Pact :: ChainwebVersion -> ChainId -> BlockHeight -> Bool +chainweb220Pact :: HasVersion => ChainId -> BlockHeight -> Bool chainweb220Pact = checkFork atOrAfter Chainweb220Pact -- Pact 4.9 features + new spv base64 errors that don't depend on legacy library -- versions -chainweb221Pact :: ChainwebVersion -> ChainId -> BlockHeight -> Bool +chainweb221Pact :: HasVersion => ChainId -> BlockHeight -> Bool chainweb221Pact = checkFork atOrAfter Chainweb221Pact -- | Pact 4.10 features, webauthn keys and signatures -chainweb222Pact :: ChainwebVersion -> ChainId -> BlockHeight -> Bool +chainweb222Pact :: HasVersion => ChainId -> BlockHeight -> Bool chainweb222Pact = checkFork atOrAfter Chainweb222Pact -- | Pact 4.11 features, verifier plugins -chainweb223Pact :: ChainwebVersion -> ChainId -> BlockHeight -> Bool +chainweb223Pact :: HasVersion => ChainId -> BlockHeight -> Bool chainweb223Pact = checkFork atOrAfter Chainweb223Pact -- | Pact 4.12 features, optimized buy/redeem gas transactions reduce gas cost -- for all transactions -chainweb224Pact :: ChainwebVersion -> ChainId -> BlockHeight -> Bool +chainweb224Pact :: HasVersion => ChainId -> BlockHeight -> Bool chainweb224Pact = checkFork atOrAfter Chainweb224Pact -- | Update Hyperlane verifier plugin to provide a "merkle tree ISM" -chainweb225Pact :: ChainwebVersion -> ChainId -> BlockHeight -> Bool +chainweb225Pact :: HasVersion => ChainId -> BlockHeight -> Bool chainweb225Pact = checkFork atOrAfter Chainweb225Pact -- | Pact 5, an entirely new Pact compiler and interpreter, and comes with some -- big changes to PactService -pact5 :: ChainwebVersion -> ChainId -> BlockHeight -> Bool +pact5 :: HasVersion => ChainId -> BlockHeight -> Bool pact5 = checkFork atOrAfter Pact5Fork -- | Pact 5.1, including a new more succinct serializer for modules -chainweb228Pact :: ChainwebVersion -> ChainId -> BlockHeight -> Bool +chainweb228Pact :: HasVersion => ChainId -> BlockHeight -> Bool chainweb228Pact = checkFork atOrAfter Chainweb228Pact -- | Pact 5.2 and 5.3, including a re-entrancy check for module references -- Also, a fix for duplicates in `keys` -chainweb230Pact :: ChainwebVersion -> ChainId -> BlockHeight -> Bool +chainweb230Pact :: HasVersion => ChainId -> BlockHeight -> Bool chainweb230Pact = checkFork atOrAfter Chainweb230Pact -- | Pact 5.4, SPV proof root expiry -chainweb231Pact :: ChainwebVersion -> ChainId -> BlockHeight -> Bool +chainweb231Pact :: HasVersion => ChainId -> BlockHeight -> Bool chainweb231Pact = checkFork atOrAfter Chainweb231Pact -- | Fork numbering and voting, continuation proof size gassed -chainweb31 :: ChainwebVersion -> ChainId -> BlockHeight -> Bool +chainweb31 :: HasVersion => ChainId -> BlockHeight -> Bool chainweb31 = checkFork atOrAfter Chainweb31 -- | Pact 5.4.1 -chainweb32 :: ChainwebVersion -> ChainId -> ForkNumber -> Bool +chainweb32 :: HasVersion => ChainId -> ForkNumber -> Bool chainweb32 = checkFork' atOrAfter Chainweb32 -migratePlatformShare :: ChainwebVersion -> ChainId -> BlockHeight -> Bool -migratePlatformShare = checkFork atNotGenesis MigratePlatformShare - -pact5Serialiser :: ChainwebVersion -> ChainId -> BlockHeight -> Pact5.PactSerialise Pact5.CoreBuiltin Pact5.LineInfo -pact5Serialiser v cid bh - | chainweb228Pact v cid bh = Pact5.serialisePact_lineinfo_pact51 - | otherwise = Pact5.serialisePact_lineinfo_pact50 - -pact4ParserVersion :: ChainwebVersion -> ChainId -> BlockHeight -> Pact4.PactParserVersion -pact4ParserVersion v cid bh - | chainweb213Pact v cid bh = Pact4.PactParserChainweb213 +pact4ParserVersion :: HasVersion => ChainId -> BlockHeight -> Pact4.PactParserVersion +pact4ParserVersion cid bh + | chainweb213Pact cid bh = Pact4.PactParserChainweb213 | otherwise = Pact4.PactParserGenesis -maxBlockGasLimit :: ChainwebVersion -> ForkNumber -> BlockHeight -> Maybe Natural -maxBlockGasLimit v fn bh = snd $ ruleZipperHere $ snd - $ ruleSeek (\h _ -> searchKey >= h) (_versionMaxBlockGasLimit v) - where - searchKey = ForkAtBlockHeight bh `max` ForkAtForkNumber fn - +migratePlatformShare :: HasVersion => ChainId -> BlockHeight -> Bool +migratePlatformShare = checkFork atNotGenesis MigratePlatformShare -minimumBlockHeaderHistory :: ChainwebVersion -> ForkNumber -> BlockHeight -> Maybe Word64 -minimumBlockHeaderHistory v fn bh = snd $ ruleZipperHere $ snd - $ ruleSeek (\h _ -> searchKey >= h) (_versionSpvProofRootValidWindow v) - where - searchKey = ForkAtBlockHeight bh `max` ForkAtForkNumber fn +pact5Serialiser + :: HasVersion + => ChainId + -> BlockHeight + -> Pact.PactSerialise Pact.CoreBuiltin Pact.LineInfo +pact5Serialiser cid bh + | chainweb228Pact cid bh = Pact.serialisePact_lineinfo_pact51 + | otherwise = Pact.serialisePact_lineinfo_pact50 + +maxBlockGasLimit + :: HasVersion + => ForkNumber + -> BlockHeight + -> Maybe Natural +maxBlockGasLimit fn bh = snd $ ruleZipperHere $ snd + $ ruleSeek (\h _ -> searchKey >= h) + (_versionMaxBlockGasLimit implicitVersion) + where + searchKey = ForkAtBlockHeight bh `max` ForkAtForkNumber fn + +minimumBlockHeaderHistory + :: HasVersion + => ForkNumber + -> BlockHeight + -> Maybe Word64 +minimumBlockHeaderHistory fn bh = snd $ ruleZipperHere $ snd + $ ruleSeek (\h _ -> searchKey >= h) + (_versionSpvProofRootValidWindow implicitVersion) + where + searchKey = ForkAtBlockHeight bh `max` ForkAtForkNumber fn + +activeInitialGasModel + :: HasVersion + => ChainId + -> ForkNumber + -> BlockHeight + -> InitialGasModel +activeInitialGasModel cid fn bh = snd $ ruleZipperHere $ snd + $ ruleSeek (\h _ -> searchKey >= h) + (implicitVersion ^?! versionInitialGasModel . atChain cid) + where + searchKey = ForkAtBlockHeight bh `max` ForkAtForkNumber fn -activeInitialGasModel :: ChainwebVersion -> ChainId -> ForkNumber -> BlockHeight -> InitialGasModel -activeInitialGasModel v cid fn bh = snd $ ruleZipperHere $ snd - $ ruleSeek (\h _ -> searchKey >= h) $ v ^?! versionInitialGasModel . atChain cid - where - searchKey = ForkAtBlockHeight bh `max` ForkAtForkNumber fn +hashedAdjacentRecord :: HasVersion => ChainId -> BlockHeight -> Bool +hashedAdjacentRecord = checkFork atOrAfter HashedAdjacentRecord -- | Different versions of Chainweb allow different PPKSchemes. -- -validPPKSchemes :: ChainwebVersion -> ChainId -> BlockHeight -> [PPKScheme] -validPPKSchemes v cid bh = - if chainweb221Pact v cid bh +validPPKSchemes :: HasVersion => ChainId -> BlockHeight -> [PPKScheme] +validPPKSchemes cid bh = + if chainweb221Pact cid bh then [ED25519, WebAuthn] else [ED25519] -isWebAuthnPrefixLegal :: ChainwebVersion -> ChainId -> BlockHeight -> Pact4.IsWebAuthnPrefixLegal -isWebAuthnPrefixLegal v cid bh = - if chainweb222Pact v cid bh - then Pact4.WebAuthnPrefixLegal - else Pact4.WebAuthnPrefixIllegal - -validKeyFormats :: ChainwebVersion -> ChainId -> BlockHeight -> [PublicKeyText -> Bool] -validKeyFormats v cid bh = - if chainweb222Pact v cid bh +validKeyFormats :: HasVersion => ChainId -> BlockHeight -> [PublicKeyText -> Bool] +validKeyFormats cid bh = + if chainweb222Pact cid bh then [ed25519HexFormat, webAuthnFormat] else [ed25519HexFormat] + +isWebAuthnPrefixLegal :: HasVersion => ChainId -> BlockHeight -> Pact4.IsWebAuthnPrefixLegal +isWebAuthnPrefixLegal cid bh + | chainweb222Pact cid bh = Pact4.WebAuthnPrefixLegal + | otherwise = Pact4.WebAuthnPrefixIllegal diff --git a/src/Chainweb/Version/Mainnet.hs b/src/Chainweb/Version/Mainnet.hs index acdcdbc7d6..55b3c3159d 100644 --- a/src/Chainweb/Version/Mainnet.hs +++ b/src/Chainweb/Version/Mainnet.hs @@ -16,27 +16,15 @@ import Chainweb.BlockHeight import Chainweb.ChainId import Chainweb.Difficulty import Chainweb.Graph -import Chainweb.Pact5.InitialGasModel +import Chainweb.Pact.InitialGasModel import Chainweb.Time import Chainweb.Utils import Chainweb.Utils.Rule import Chainweb.Version import P2P.BootstrapNodes -import Pact.Types.Runtime (Gas(..)) -import Pact.Types.Verifier - -import qualified Chainweb.BlockHeader.Genesis.Mainnet0Payload as MN0 -import qualified Chainweb.BlockHeader.Genesis.Mainnet1Payload as MN1 -import qualified Chainweb.BlockHeader.Genesis.Mainnet2Payload as MN2 -import qualified Chainweb.BlockHeader.Genesis.Mainnet3Payload as MN3 -import qualified Chainweb.BlockHeader.Genesis.Mainnet4Payload as MN4 -import qualified Chainweb.BlockHeader.Genesis.Mainnet5Payload as MN5 -import qualified Chainweb.BlockHeader.Genesis.Mainnet6Payload as MN6 -import qualified Chainweb.BlockHeader.Genesis.Mainnet7Payload as MN7 -import qualified Chainweb.BlockHeader.Genesis.Mainnet8Payload as MN8 -import qualified Chainweb.BlockHeader.Genesis.Mainnet9Payload as MN9 -import qualified Chainweb.BlockHeader.Genesis.Mainnet10to19Payload as MNKAD +import Pact.Core.Gas(Gas(..)) +import Pact.Core.Names import qualified Chainweb.Pact.Transactions.CoinV3Transactions as CoinV3 import qualified Chainweb.Pact.Transactions.CoinV4Transactions as CoinV4 import qualified Chainweb.Pact.Transactions.CoinV5Transactions as CoinV5 @@ -95,11 +83,11 @@ pattern Mainnet01 <- ((== mainnet) -> True) where Mainnet01 = mainnet mainnet :: ChainwebVersion -mainnet = ChainwebVersion +mainnet = withVersion mainnet $ ChainwebVersion { _versionCode = ChainwebVersionCode 0x00000005 , _versionName = ChainwebVersionName "mainnet01" , _versionForks = tabulateHashMap $ \case - SlowEpoch -> AllChains (ForkAtBlockHeight $ BlockHeight 80_000) + SlowEpoch -> onAllChains (ForkAtBlockHeight $ BlockHeight 80_000) Vuln797Fix -> onChains $ [ (unsafeChainId 0, ForkAtBlockHeight $ BlockHeight 121_452) -- 2019-12-10T21:00:00.0 , (unsafeChainId 1, ForkAtBlockHeight $ BlockHeight 121_452) @@ -124,41 +112,41 @@ mainnet = ChainwebVersion , (unsafeChainId 8, ForkAtBlockHeight $ BlockHeight 140_808) , (unsafeChainId 9, ForkAtBlockHeight $ BlockHeight 140_808) ] <> [(unsafeChainId i, ForkAtGenesis) | i <- [10..19]] - PactBackCompat_v16 -> AllChains (ForkAtBlockHeight $ BlockHeight 328_000) - ModuleNameFix -> AllChains (ForkAtBlockHeight $ BlockHeight 448_501) - SkipTxTimingValidation -> AllChains (ForkAtBlockHeight $ BlockHeight 449_940) - OldTargetGuard -> AllChains (ForkAtBlockHeight $ BlockHeight 452_820) -- ~ 2020-04-04T00:00:00Z - SkipFeatureFlagValidation -> AllChains (ForkAtBlockHeight $ BlockHeight 530_500) -- ~ 2020-05-01T00:00:xxZ - ModuleNameFix2 -> AllChains (ForkAtBlockHeight $ BlockHeight 752_214) - OldDAGuard -> AllChains (ForkAtBlockHeight $ BlockHeight 771_414) -- ~ 2020-07-23 16:00:00 - PactEvents -> AllChains (ForkAtBlockHeight $ BlockHeight 1_138_000) - SPVBridge -> AllChains (ForkAtBlockHeight $ BlockHeight 1_275_000) - Pact4Coin3 -> AllChains (ForkAtBlockHeight $ BlockHeight 1_722_500) -- 2021-06-19T03:34:05+00:00 - EnforceKeysetFormats -> AllChains (ForkAtBlockHeight $ BlockHeight 2_162_000) -- 2022-01-17T17:51:12 - Pact42 -> AllChains (ForkAtBlockHeight $ BlockHeight 2_334_500) -- 2022-01-17T17:51:12+00:00 - CheckTxHash -> AllChains (ForkAtBlockHeight $ BlockHeight 2_349_800) -- 2022-01-23T02:53:38 - Chainweb213Pact -> AllChains (ForkAtBlockHeight $ BlockHeight 2_447_315) -- 2022-02-26T00:00:00+00:00 - Chainweb214Pact -> AllChains (ForkAtBlockHeight $ BlockHeight 2_605_663) -- 2022-04-22T00:00:00+00:00 - Chainweb215Pact -> AllChains (ForkAtBlockHeight $ BlockHeight 2_766_630) -- 2022-06-17T00:00:00+00:00 - Pact44NewTrans -> AllChains (ForkAtBlockHeight $ BlockHeight 2_939_323) -- Todo: add date - Chainweb216Pact -> AllChains (ForkAtBlockHeight $ BlockHeight 2_988_324) -- 2022-09-02T00:00:00+00:00 - Chainweb217Pact -> AllChains (ForkAtBlockHeight $ BlockHeight 3_250_348) -- 2022-12-02T00:00:00+00:00 - Chainweb218Pact -> AllChains (ForkAtBlockHeight $ BlockHeight 3_512_363) -- 2023-03-03 00:00:00+00:00 - Chainweb219Pact -> AllChains (ForkAtBlockHeight $ BlockHeight 3_774_423) -- 2023-06-02 00:00:00+00:00 - Chainweb220Pact -> AllChains (ForkAtBlockHeight $ BlockHeight 4_056_499) -- 2023-09-08 00:00:00+00:00 - Chainweb221Pact -> AllChains (ForkAtBlockHeight $ BlockHeight 4_177_889) -- 2023-10-20 00:00:00+00:00 - Chainweb222Pact -> AllChains (ForkAtBlockHeight $ BlockHeight 4_335_753) -- 2023-12-14 00:00:00+00:00 - Chainweb223Pact -> AllChains (ForkAtBlockHeight $ BlockHeight 4_577_530) -- 2024-03-07 00:00:00+00:00 - Chainweb224Pact -> AllChains (ForkAtBlockHeight $ BlockHeight 4_819_246) -- 2024-05-30 00:00:00+00:00 - Chainweb225Pact -> AllChains (ForkAtBlockHeight $ BlockHeight 5_060_924) -- 2024-08-22 00:00:00+00:00 - Pact5Fork -> AllChains (ForkAtBlockHeight $ BlockHeight 5_555_698) -- 2025-02-10 00:00:00+00:00 - Chainweb228Pact -> AllChains (ForkAtBlockHeight $ BlockHeight 5_659_280) -- 2025-03-18 00:00:00+00:00 - Chainweb230Pact -> AllChains (ForkAtBlockHeight $ BlockHeight 6_027_616) -- 2025-07-24 00:00:00+00:00 - Chainweb231Pact -> AllChains (ForkAtBlockHeight $ BlockHeight 6_269_344) -- 2025-10-16 00:00:00+00:00 - MigratePlatformShare -> AllChains (ForkAtBlockHeight $ BlockHeight 6_335_858) -- 2025-11-07 04:00:00+00:00 - Chainweb31 -> AllChains (ForkAtBlockHeight $ BlockHeight 6_510_742) -- 2026-01-08 00:00:00+00:00 - Chainweb32-> AllChains (ForkAtForkNumber 1) - + PactBackCompat_v16 -> onAllChains (ForkAtBlockHeight $ BlockHeight 328_000) + ModuleNameFix -> onAllChains (ForkAtBlockHeight $ BlockHeight 448_501) + SkipTxTimingValidation -> onAllChains (ForkAtBlockHeight $ BlockHeight 449_940) + OldTargetGuard -> onAllChains (ForkAtBlockHeight $ BlockHeight 452_820) -- ~ 2020-04-04T00:00:00Z + SkipFeatureFlagValidation -> onAllChains (ForkAtBlockHeight $ BlockHeight 530_500) -- ~ 2020-05-01T00:00:xxZ + ModuleNameFix2 -> onAllChains (ForkAtBlockHeight $ BlockHeight 752_214) + OldDAGuard -> onAllChains (ForkAtBlockHeight $ BlockHeight 771_414) -- ~ 2020-07-23 16:00:00 + PactEvents -> onAllChains (ForkAtBlockHeight $ BlockHeight 1_138_000) + SPVBridge -> onAllChains (ForkAtBlockHeight $ BlockHeight 1_275_000) + Pact4Coin3 -> onAllChains (ForkAtBlockHeight $ BlockHeight 1_722_500) -- 2021-06-19T03:34:05+00:00 + EnforceKeysetFormats -> onAllChains (ForkAtBlockHeight $ BlockHeight 2_162_000) -- 2022-01-17T17:51:12 + Pact42 -> onAllChains (ForkAtBlockHeight $ BlockHeight 2_334_500) -- 2022-01-17T17:51:12+00:00 + CheckTxHash -> onAllChains (ForkAtBlockHeight $ BlockHeight 2_349_800) -- 2022-01-23T02:53:38 + Chainweb213Pact -> onAllChains (ForkAtBlockHeight $ BlockHeight 2_447_315) -- 2022-02-26T00:00:00+00:00 + Chainweb214Pact -> onAllChains (ForkAtBlockHeight $ BlockHeight 2_605_663) -- 2022-04-22T00:00:00+00:00 + Chainweb215Pact -> onAllChains (ForkAtBlockHeight $ BlockHeight 2_766_630) -- 2022-06-17T00:00:00+00:00 + Pact44NewTrans -> onAllChains (ForkAtBlockHeight $ BlockHeight 2_939_323) -- Todo: add date + Chainweb216Pact -> onAllChains (ForkAtBlockHeight $ BlockHeight 2_988_324) -- 2022-09-02T00:00:00+00:00 + Chainweb217Pact -> onAllChains (ForkAtBlockHeight $ BlockHeight 3_250_348) -- 2022-12-02T00:00:00+00:00 + Chainweb218Pact -> onAllChains (ForkAtBlockHeight $ BlockHeight 3_512_363) -- 2023-03-03 00:00:00+00:00 + Chainweb219Pact -> onAllChains (ForkAtBlockHeight $ BlockHeight 3_774_423) -- 2023-06-02 00:00:00+00:00 + Chainweb220Pact -> onAllChains (ForkAtBlockHeight $ BlockHeight 4_056_499) -- 2023-09-08 00:00:00+00:00 + Chainweb221Pact -> onAllChains (ForkAtBlockHeight $ BlockHeight 4_177_889) -- 2023-10-20 00:00:00+00:00 + Chainweb222Pact -> onAllChains (ForkAtBlockHeight $ BlockHeight 4_335_753) -- 2023-12-14 00:00:00+00:00 + Chainweb223Pact -> onAllChains (ForkAtBlockHeight $ BlockHeight 4_577_530) -- 2024-03-07 00:00:00+00:00 + Chainweb224Pact -> onAllChains (ForkAtBlockHeight $ BlockHeight 4_819_246) -- 2024-05-30 00:00:00+00:00 + Chainweb225Pact -> onAllChains (ForkAtBlockHeight $ BlockHeight 5_060_924) -- 2024-08-22 00:00:00+00:00 + Pact5Fork -> onAllChains (ForkAtBlockHeight $ BlockHeight 5_555_698) -- 2025-02-10 00:00:00+00:00 + Chainweb228Pact -> onAllChains (ForkAtBlockHeight $ BlockHeight 5_659_280) -- 2025-03-18 00:00:00+00:00 + Chainweb230Pact -> onAllChains (ForkAtBlockHeight $ BlockHeight 6_027_616) -- 2025-07-24 00:00:00+00:00 + Chainweb231Pact -> onAllChains (ForkAtBlockHeight $ BlockHeight 6_269_344) -- 2025-10-16 00:00:00+00:00 + Chainweb31 -> onAllChains (ForkAtBlockHeight $ BlockHeight 6_510_742) -- 2026-01-08 00:00:00+00:00 + Chainweb32 -> onAllChains (ForkAtForkNumber 1) + MigratePlatformShare -> onAllChains (ForkAtBlockHeight $ BlockHeight 6_335_858) -- 2025-11-07 04:00:00+00:00 + HashedAdjacentRecord -> onAllChains ForkNever , _versionGraphs = (to20ChainsMainnet, twentyChainGraph) `Above` Bottom (minBound, petersenChainGraph) @@ -168,7 +156,7 @@ mainnet = ChainwebVersion , _versionMaxBlockGasLimit = (succByHeight $ mainnet ^?! versionForks . at Chainweb216Pact . _Just . atChain (unsafeChainId 0), Just 180_000) `Above` Bottom (minBound, Nothing) - , _versionInitialGasModel = AllChains $ + , _versionInitialGasModel = onAllChains $ (mainnet ^?! versionForks . at Chainweb32 . _Just . atChain (unsafeChainId 0), post32GasModel) `Above` (succByHeight $ mainnet ^?! versionForks . at Chainweb31 . _Just . atChain (unsafeChainId 0), post31GasModel) `Above` Bottom (minBound, pre31GasModel) @@ -179,29 +167,36 @@ mainnet = ChainwebVersion Bottom (minBound, Nothing) , _versionBootstraps = domainAddr2PeerInfo mainnetBootstrapHosts , _versionGenesis = VersionGenesis - { _genesisBlockTarget = OnChains $ HM.fromList $ concat + { _genesisBlockTarget = ChainMap $ HM.fromList $ concat [ [(unsafeChainId i, maxTarget) | i <- [0..9]] , [(unsafeChainId i, mainnet20InitialHashTarget) | i <- [10..19]] ] - , _genesisTime = AllChains $ BlockCreationTime [timeMicrosQQ| 2019-10-30T00:01:00.0 |] - , _genesisBlockPayload = OnChains $ HM.fromList $ concat - [ - [ (unsafeChainId 0, MN0.payloadBlock) - , (unsafeChainId 1, MN1.payloadBlock) - , (unsafeChainId 2, MN2.payloadBlock) - , (unsafeChainId 3, MN3.payloadBlock) - , (unsafeChainId 4, MN4.payloadBlock) - , (unsafeChainId 5, MN5.payloadBlock) - , (unsafeChainId 6, MN6.payloadBlock) - , (unsafeChainId 7, MN7.payloadBlock) - , (unsafeChainId 8, MN8.payloadBlock) - , (unsafeChainId 9, MN9.payloadBlock) - ] - , [(unsafeChainId i, MNKAD.payloadBlock) | i <- [10..19]] + , _genesisTime = onAllChains $ BlockCreationTime [timeMicrosQQ| 2019-10-30T00:01:00.0 |] + , _genesisBlockPayload = onChains + [ ( unsafeChainId 0, unsafeFromText "k1H3DsInAPvJ0W_zPxnrpkeSNdPUT0S9U8bqDLG739o") + , ( unsafeChainId 1, unsafeFromText "kClp_Tw7keCLXMfaCyjH-gToAGmLvRQqiNRmhWUCbxs") + , ( unsafeChainId 2, unsafeFromText "4DVp1dkSLYkFD0zbFF7e5Ba0ezKmnZhEVzlc5ZqqAT0") + , ( unsafeChainId 3, unsafeFromText "fCHKOS9SF9G3Gy5iGZnOmQxjGYf32yM8PklrcBD_dmQ") + , ( unsafeChainId 4, unsafeFromText "cTZ_29TkjXDlG_GlW8iB-va3mofpt_UjthLcOoqtlaQ") + , ( unsafeChainId 5, unsafeFromText "MS_wu92H4GVPCziB6g8rOAc3x2uyegXH4Yl_0TfpI7U") + , ( unsafeChainId 6, unsafeFromText "DVs3k9omI_WHMOJ8tUZ1Bt9Q1DdNmqC3V51iZDGmWwM") + , ( unsafeChainId 7, unsafeFromText "Faa4TQZGFkFumLfHnMIJBAu_PSmGY4F-YraLVFrxr7Y") + , ( unsafeChainId 8, unsafeFromText "YWgbJ4K5VET4WnG3H0Y0HPgzZ_qSnTgqxyB1kpMLJTQ") + , ( unsafeChainId 9, unsafeFromText "w_6Spsw-jdCi9hBTlM6v0C1P7XoglU_AqNG9rcOwAZ0") + , ( unsafeChainId 10, unsafeFromText "i-MN4AoxsaPds4M_MzwNSUygAkGnPZoCDvahfckowt4") + , ( unsafeChainId 11, unsafeFromText "i-MN4AoxsaPds4M_MzwNSUygAkGnPZoCDvahfckowt4") + , ( unsafeChainId 12, unsafeFromText "i-MN4AoxsaPds4M_MzwNSUygAkGnPZoCDvahfckowt4") + , ( unsafeChainId 13, unsafeFromText "i-MN4AoxsaPds4M_MzwNSUygAkGnPZoCDvahfckowt4") + , ( unsafeChainId 14, unsafeFromText "i-MN4AoxsaPds4M_MzwNSUygAkGnPZoCDvahfckowt4") + , ( unsafeChainId 15, unsafeFromText "i-MN4AoxsaPds4M_MzwNSUygAkGnPZoCDvahfckowt4") + , ( unsafeChainId 16, unsafeFromText "i-MN4AoxsaPds4M_MzwNSUygAkGnPZoCDvahfckowt4") + , ( unsafeChainId 17, unsafeFromText "i-MN4AoxsaPds4M_MzwNSUygAkGnPZoCDvahfckowt4") + , ( unsafeChainId 18, unsafeFromText "i-MN4AoxsaPds4M_MzwNSUygAkGnPZoCDvahfckowt4") + , ( unsafeChainId 19, unsafeFromText "i-MN4AoxsaPds4M_MzwNSUygAkGnPZoCDvahfckowt4") ] } , _versionUpgrades = chainZip HM.union - (indexByForkHeights mainnet + (indexByForkHeights [ (CoinV2, onChains [ (unsafeChainId 0, pact4Upgrade MN0.transactions) , (unsafeChainId 1, pact4Upgrade MN1.transactions) @@ -214,10 +209,10 @@ mainnet = ChainwebVersion , (unsafeChainId 8, pact4Upgrade MN8.transactions) , (unsafeChainId 9, pact4Upgrade MN9.transactions) ]) - , (Pact4Coin3, AllChains $ Pact4Upgrade CoinV3.transactions True) - , (Chainweb214Pact, AllChains $ Pact4Upgrade CoinV4.transactions True) - , (Chainweb215Pact, AllChains $ Pact4Upgrade CoinV5.transactions True) - , (Chainweb223Pact, AllChains $ pact4Upgrade CoinV6.transactions) + , (Pact4Coin3, onAllChains $ Pact4Upgrade CoinV3.transactions True) + , (Chainweb214Pact, onAllChains $ Pact4Upgrade CoinV4.transactions True) + , (Chainweb215Pact, onAllChains $ Pact4Upgrade CoinV5.transactions True) + , (Chainweb223Pact, onAllChains $ pact4Upgrade CoinV6.transactions) ]) (onChains [(unsafeChainId 0, HM.singleton to20ChainsMainnet (pact4Upgrade MNKAD.transactions))]) , _versionCheats = VersionCheats @@ -229,7 +224,7 @@ mainnet = ChainwebVersion { _disablePeerValidation = False , _disableMempoolSync = False } - , _versionVerifierPluginNames = AllChains $ + , _versionVerifierPluginNames = onAllChains $ (ForkAtBlockHeight $ BlockHeight 4_577_530, Set.fromList [VerifierName "hyperlane_v3_message"]) `Above` Bottom (minBound, mempty) , _versionQuirks = VersionQuirks @@ -250,6 +245,7 @@ mainnet = ChainwebVersion , (unsafeChainId 19,HM.fromList [((BlockHeight 4594050, TxBlockIdx 0), Gas 69_092)]) ] } + , _versionPayloadProviderTypes = onAllChains PactProvider , _versionForkNumber = 1 -- | A epoch is 120 * 120 block heights, which, on mainnet, is expected to be 5 -- days. diff --git a/src/Chainweb/Version/RecapDevelopment.hs b/src/Chainweb/Version/RecapDevelopment.hs index 42e059526d..f13661f15f 100644 --- a/src/Chainweb/Version/RecapDevelopment.hs +++ b/src/Chainweb/Version/RecapDevelopment.hs @@ -14,7 +14,7 @@ import Control.Lens import Chainweb.BlockCreationTime import Chainweb.BlockHeight import Chainweb.ChainId -import Chainweb.Pact5.InitialGasModel +import Chainweb.Pact.InitialGasModel import Chainweb.Difficulty import Chainweb.Graph import Chainweb.Time @@ -22,11 +22,10 @@ import Chainweb.Utils import Chainweb.Utils.Rule import Chainweb.Version -import Pact.Types.Verifier - -import qualified Chainweb.BlockHeader.Genesis.RecapDevelopment0Payload as RDN0 -import qualified Chainweb.BlockHeader.Genesis.RecapDevelopment1to9Payload as RDNN -import qualified Chainweb.BlockHeader.Genesis.RecapDevelopment10to19Payload as RDNKAD +import Pact.Core.Names +-- import qualified Chainweb.BlockHeader.Genesis.RecapDevelopment0Payload as RDN0 +-- import qualified Chainweb.BlockHeader.Genesis.RecapDevelopment1to9Payload as RDNN +-- import qualified Chainweb.BlockHeader.Genesis.RecapDevelopment10to19Payload as RDNKAD import qualified Chainweb.Pact.Transactions.RecapDevelopmentTransactions as RecapDevnet import qualified Chainweb.Pact.Transactions.CoinV3Transactions as CoinV3 import qualified Chainweb.Pact.Transactions.CoinV4Transactions as CoinV4 @@ -41,55 +40,55 @@ pattern RecapDevelopment <- ((== recapDevnet) -> True) where RecapDevelopment = recapDevnet recapDevnet :: ChainwebVersion -recapDevnet = ChainwebVersion +recapDevnet = withVersion recapDevnet ChainwebVersion { _versionCode = ChainwebVersionCode 0x0000_0001 , _versionName = ChainwebVersionName "recap-development" , _versionForks = tabulateHashMap $ \case - SlowEpoch -> AllChains $ ForkAtBlockHeight $ BlockHeight 0 - Vuln797Fix -> AllChains $ ForkAtBlockHeight $ BlockHeight 0 - CoinV2 -> onChains $ [(unsafeChainId 0, ForkAtBlockHeight $ BlockHeight 3)] <> [(unsafeChainId i, ForkAtBlockHeight $ BlockHeight 4) | i <- [1..19]] - PactBackCompat_v16 -> AllChains $ ForkAtBlockHeight $ BlockHeight 0 - SkipTxTimingValidation -> AllChains $ ForkAtBlockHeight $ BlockHeight 2 - OldTargetGuard -> AllChains $ ForkAtBlockHeight $ BlockHeight 0 - SkipFeatureFlagValidation -> AllChains $ ForkAtBlockHeight $ BlockHeight 0 - ModuleNameFix -> AllChains $ ForkAtBlockHeight $ BlockHeight 2 - ModuleNameFix2 -> AllChains $ ForkAtBlockHeight $ BlockHeight 2 - OldDAGuard -> AllChains $ ForkAtBlockHeight $ BlockHeight 13 - PactEvents -> AllChains $ ForkAtBlockHeight $ BlockHeight 40 - SPVBridge -> AllChains $ ForkAtBlockHeight $ BlockHeight 50 - Pact4Coin3 -> AllChains $ ForkAtBlockHeight $ BlockHeight 80 - EnforceKeysetFormats -> AllChains $ ForkAtBlockHeight $ BlockHeight 100 - Pact42 -> AllChains $ ForkAtBlockHeight $ BlockHeight 90 - CheckTxHash -> AllChains $ ForkAtBlockHeight $ BlockHeight 110 - Chainweb213Pact -> AllChains $ ForkAtBlockHeight $ BlockHeight 95 - Chainweb214Pact -> AllChains $ ForkAtBlockHeight $ BlockHeight 115 - Chainweb215Pact -> AllChains $ ForkAtBlockHeight $ BlockHeight 165 - Pact44NewTrans -> AllChains $ ForkAtBlockHeight $ BlockHeight 0 - Chainweb216Pact -> AllChains $ ForkAtBlockHeight $ BlockHeight 215 - Chainweb217Pact -> AllChains $ ForkAtBlockHeight $ BlockHeight 470 - Chainweb218Pact -> AllChains $ ForkAtBlockHeight $ BlockHeight 500 - Chainweb219Pact -> AllChains $ ForkAtBlockHeight $ BlockHeight 550 - Chainweb220Pact -> AllChains $ ForkAtBlockHeight $ BlockHeight 560 - Chainweb221Pact -> AllChains $ ForkAtBlockHeight $ BlockHeight 580 - Chainweb222Pact -> AllChains $ ForkAtBlockHeight $ BlockHeight 590 - Chainweb223Pact -> AllChains $ ForkAtBlockHeight $ BlockHeight 600 - Chainweb224Pact -> AllChains $ ForkAtBlockHeight $ BlockHeight 610 - Chainweb225Pact -> AllChains $ ForkAtBlockHeight $ BlockHeight 620 - Pact5Fork -> AllChains $ ForkAtBlockHeight $ BlockHeight 640 - Chainweb228Pact -> AllChains $ ForkAtBlockHeight $ BlockHeight 650 - Chainweb230Pact -> AllChains $ ForkAtBlockHeight $ BlockHeight 680 - Chainweb231Pact -> AllChains $ ForkAtBlockHeight $ BlockHeight 690 - MigratePlatformShare -> AllChains $ ForkAtBlockHeight $ BlockHeight 700 - Chainweb31 -> AllChains $ ForkAtBlockHeight $ BlockHeight 710 - Chainweb32 -> AllChains $ ForkAtGenesis - - , _versionUpgrades = foldr (chainZip HM.union) (AllChains mempty) - [ indexByForkHeights recapDevnet + SlowEpoch -> onAllChains ForkAtGenesis + Vuln797Fix -> onAllChains ForkAtGenesis + CoinV2 -> onAllChains ForkAtGenesis + PactBackCompat_v16 -> onAllChains ForkAtGenesis + SkipTxTimingValidation -> onAllChains ForkAtGenesis + OldTargetGuard -> onAllChains ForkAtGenesis + SkipFeatureFlagValidation -> onAllChains ForkAtGenesis + ModuleNameFix -> onAllChains ForkAtGenesis + ModuleNameFix2 -> onAllChains ForkAtGenesis + OldDAGuard -> onAllChains ForkAtGenesis + PactEvents -> onAllChains ForkAtGenesis + SPVBridge -> onAllChains ForkAtGenesis + Pact4Coin3 -> onAllChains ForkAtGenesis + EnforceKeysetFormats -> onAllChains ForkAtGenesis + Pact42 -> onAllChains ForkAtGenesis + CheckTxHash -> onAllChains ForkAtGenesis + Chainweb213Pact -> onAllChains ForkAtGenesis + Chainweb214Pact -> onAllChains ForkAtGenesis + Chainweb215Pact -> onAllChains ForkAtGenesis + Pact44NewTrans -> onAllChains ForkAtGenesis + Chainweb216Pact -> onAllChains ForkAtGenesis + Chainweb217Pact -> onAllChains ForkAtGenesis + Chainweb218Pact -> onAllChains ForkAtGenesis + Chainweb219Pact -> onAllChains ForkAtGenesis + Chainweb220Pact -> onAllChains ForkAtGenesis + Chainweb221Pact -> onAllChains ForkAtGenesis + Chainweb222Pact -> onAllChains ForkAtGenesis + Chainweb223Pact -> onAllChains ForkAtGenesis + Chainweb224Pact -> onAllChains ForkAtGenesis + Chainweb225Pact -> onAllChains ForkAtGenesis + Pact5Fork -> onAllChains ForkAtGenesis + Chainweb228Pact -> onAllChains $ ForkAtBlockHeight $ BlockHeight 10 + Chainweb230Pact -> onAllChains $ ForkAtBlockHeight $ BlockHeight 30 + Chainweb231Pact -> onAllChains $ ForkAtBlockHeight $ BlockHeight 35 + HashedAdjacentRecord -> onAllChains $ ForkAtBlockHeight $ BlockHeight 40 + Chainweb31 -> onAllChains $ ForkAtBlockHeight $ BlockHeight 710 + Chainweb32 -> onAllChains ForkAtGenesis + MigratePlatformShare -> onAllChains $ ForkAtBlockHeight $ BlockHeight 700 + , _versionUpgrades = foldr (chainZip HM.union) (onAllChains mempty) + [ indexByForkHeights [ (CoinV2, onChains [(unsafeChainId i, pact4Upgrade RecapDevnet.transactions) | i <- [0..9]]) - , (Pact4Coin3, AllChains (Pact4Upgrade CoinV3.transactions True)) - , (Chainweb214Pact, AllChains (Pact4Upgrade CoinV4.transactions True)) - , (Chainweb215Pact, AllChains (Pact4Upgrade CoinV5.transactions True)) + , (Pact4Coin3, onAllChains (Pact4Upgrade CoinV3.transactions True)) + , (Chainweb214Pact, onAllChains (Pact4Upgrade CoinV4.transactions True)) + , (Chainweb215Pact, onAllChains (Pact4Upgrade CoinV5.transactions True)) ] , onChains [(unsafeChainId 0, HM.singleton to20ChainsHeight (pact4Upgrade MNKAD.transactions))] ] @@ -107,16 +106,33 @@ recapDevnet = ChainwebVersion [ [(unsafeChainId i, HashTarget $ maxBound `div` 100_000) | i <- [0..9]] , [(unsafeChainId i, HashTarget 0x0000088f99632cadf39b0db7655be62cb7dbc84ebbd9a90e5b5756d3e7d9196c) | i <- [10..19]] ] - , _genesisTime = AllChains $ BlockCreationTime [timeMicrosQQ| 2019-07-17T18:28:37.613832 |] - , _genesisBlockPayload = onChains $ concat - [ [(unsafeChainId 0, RDN0.payloadBlock)] - , [(unsafeChainId i, RDNN.payloadBlock) | i <- [1..9]] - , [(unsafeChainId i, RDNKAD.payloadBlock) | i <- [10..19]] + , _genesisTime = onAllChains $ BlockCreationTime [timeMicrosQQ| 2019-07-17T18:28:37.613832 |] + , _genesisBlockPayload = onChains + [ (unsafeChainId 0, unsafeFromText "5TWTF5R6Vc85vWHqcklTY91ljkV6mJ1wYfDJShooTCw") + , (unsafeChainId 1, unsafeFromText "yZ6Syxl34TTrGGKxVHInV0S29BH8v-C8VZTbJr2eK2k") + , (unsafeChainId 2, unsafeFromText "yZ6Syxl34TTrGGKxVHInV0S29BH8v-C8VZTbJr2eK2k") + , (unsafeChainId 3, unsafeFromText "yZ6Syxl34TTrGGKxVHInV0S29BH8v-C8VZTbJr2eK2k") + , (unsafeChainId 4, unsafeFromText "yZ6Syxl34TTrGGKxVHInV0S29BH8v-C8VZTbJr2eK2k") + , (unsafeChainId 5, unsafeFromText "yZ6Syxl34TTrGGKxVHInV0S29BH8v-C8VZTbJr2eK2k") + , (unsafeChainId 6, unsafeFromText "yZ6Syxl34TTrGGKxVHInV0S29BH8v-C8VZTbJr2eK2k") + , (unsafeChainId 7, unsafeFromText "yZ6Syxl34TTrGGKxVHInV0S29BH8v-C8VZTbJr2eK2k") + , (unsafeChainId 8, unsafeFromText "yZ6Syxl34TTrGGKxVHInV0S29BH8v-C8VZTbJr2eK2k") + , (unsafeChainId 9, unsafeFromText "yZ6Syxl34TTrGGKxVHInV0S29BH8v-C8VZTbJr2eK2k") + , (unsafeChainId 10, unsafeFromText "OXFBWONFKY7fTY4MH3GaOOELd_cPCMn9GpIOPBYMsvM") + , (unsafeChainId 11, unsafeFromText "OXFBWONFKY7fTY4MH3GaOOELd_cPCMn9GpIOPBYMsvM") + , (unsafeChainId 12, unsafeFromText "OXFBWONFKY7fTY4MH3GaOOELd_cPCMn9GpIOPBYMsvM") + , (unsafeChainId 13, unsafeFromText "OXFBWONFKY7fTY4MH3GaOOELd_cPCMn9GpIOPBYMsvM") + , (unsafeChainId 14, unsafeFromText "OXFBWONFKY7fTY4MH3GaOOELd_cPCMn9GpIOPBYMsvM") + , (unsafeChainId 15, unsafeFromText "OXFBWONFKY7fTY4MH3GaOOELd_cPCMn9GpIOPBYMsvM") + , (unsafeChainId 16, unsafeFromText "OXFBWONFKY7fTY4MH3GaOOELd_cPCMn9GpIOPBYMsvM") + , (unsafeChainId 17, unsafeFromText "OXFBWONFKY7fTY4MH3GaOOELd_cPCMn9GpIOPBYMsvM") + , (unsafeChainId 18, unsafeFromText "OXFBWONFKY7fTY4MH3GaOOELd_cPCMn9GpIOPBYMsvM") + , (unsafeChainId 19, unsafeFromText "OXFBWONFKY7fTY4MH3GaOOELd_cPCMn9GpIOPBYMsvM") ] } , _versionMaxBlockGasLimit = Bottom (minBound, Just 180_000) - , _versionInitialGasModel = AllChains $ + , _versionInitialGasModel = onAllChains $ (ForkNever, post32GasModel) `Above` (succByHeight $ recapDevnet ^?! versionForks . at Chainweb231Pact . _Just . atChain (unsafeChainId 0), post31GasModel) `Above` Bottom (minBound, pre31GasModel) @@ -131,10 +147,11 @@ recapDevnet = ChainwebVersion { _disablePeerValidation = True , _disableMempoolSync = False } - , _versionVerifierPluginNames = AllChains $ + , _versionVerifierPluginNames = onAllChains $ (ForkAtBlockHeight $ BlockHeight 600, Set.fromList $ map VerifierName ["hyperlane_v3_message", "allow", "signed_list"]) `Above` Bottom (minBound, mempty) , _versionQuirks = noQuirks + , _versionPayloadProviderTypes = onAllChains PactProvider , _versionForkNumber = 0 , _versionForkVoteCastingLength = 120 * 119 -- 5 days } diff --git a/src/Chainweb/Version/Registry.hs b/src/Chainweb/Version/Registry.hs index a873219b3d..e7e95870bc 100644 --- a/src/Chainweb/Version/Registry.hs +++ b/src/Chainweb/Version/Registry.hs @@ -19,14 +19,9 @@ -- because it works badly with tests. -- module Chainweb.Version.Registry - ( registerVersion - , unregisterVersion - , lookupVersionByCode - , lookupVersionByName - , fabricateVersionWithName + ( validateVersion , knownVersions , findKnownVersion - , versionMap ) where import Control.DeepSeq @@ -34,18 +29,15 @@ import Control.Exception import Control.Lens import Control.Monad import Data.Foldable -import Data.HashMap.Strict (HashMap) -import qualified Data.HashMap.Strict as HM import qualified Data.HashSet as HS -import Data.IORef -import Data.Maybe import qualified Data.Text as T -import System.IO.Unsafe import GHC.Stack import Chainweb.Version import Chainweb.Version.Development +import Chainweb.Version.EvmDevelopment +import Chainweb.Version.EvmTestnet import Chainweb.Version.RecapDevelopment import Chainweb.Version.Mainnet import Chainweb.Version.Testnet04 @@ -53,32 +45,6 @@ import Chainweb.Version.Testnet06 import Chainweb.Utils.Rule -- temporarily left off because it doesn't validate -{-# NOINLINE versionMap #-} -versionMap :: IORef (HashMap ChainwebVersionCode ChainwebVersion) -versionMap = unsafePerformIO $ do - traverse_ validateVersion knownVersions - newIORef $ HM.fromList [(_versionCode v, v) | v <- [mainnet, testnet06]] - --- | Register a version into our registry by code, ensuring it contains no --- errors and there are no others registered with that code. -registerVersion :: HasCallStack => ChainwebVersion -> IO () -registerVersion v = do - validateVersion v - atomicModifyIORef' versionMap $ \m -> - case HM.lookup (_versionCode v) m of - Just v' - | v /= v' -> error "registerVersion: conflicting version registered already" - | otherwise -> (m, ()) - Nothing -> - (HM.insert (_versionCode v) v m, ()) - --- | Unregister a version from the registry. This is ONLY for testing versions. -unregisterVersion :: HasCallStack => ChainwebVersion -> IO () -unregisterVersion v = do - if elem (_versionCode v) (_versionCode <$> [mainnet, testnet06]) - then error "You cannot unregister mainnet or testnet06 versions" - else atomicModifyIORef' versionMap $ \m -> (HM.delete (_versionCode v) m, ()) - validateNoHeightAfterChainweb31 :: ChainwebVersion -> ForkHeight -> Either String () validateNoHeightAfterChainweb31 v fh = case (fork31Height, fh) of @@ -111,8 +77,7 @@ validateVersion v = do evaluate (rnf v) let hasAllChains :: ChainMap a -> Bool - hasAllChains (AllChains _) = True - hasAllChains (OnChains m) = HS.fromMap (void m) == chainIds v + hasAllChains (ChainMap m) = HS.fromMap (void m) == withVersion v chainIds errors = concat [ [ "validateVersion: version does not have heights for all forks" | not (HS.fromMap (void $ _versionForks v) == HS.fromList [minBound :: Fork .. maxBound :: Fork]) ] @@ -141,69 +106,29 @@ validateVersion v = do unless (null errors) $ error $ unlines $ ["errors encountered validating version", show v] <> errors where - -- TODO: this is an annoying type sig, can we use NoMonoLocalBinds and disable the warning - -- about matching on GADTs? - isUpgradeEmpty :: PactUpgrade -> Bool isUpgradeEmpty Pact4Upgrade{_pact4UpgradeTransactions = upg} = null upg isUpgradeEmpty Pact5Upgrade{_pact5UpgradeTransactions = upg} = null upg --- | Look up a version in the registry by code. -lookupVersionByCode :: HasCallStack => ChainwebVersionCode -> ChainwebVersion -lookupVersionByCode code - -- these two cases exist to ensure that the mainnet and testnet versions - -- cannot be accidentally replaced and are the most performant to look up. - -- registering them is still allowed, as long as they are not conflicting. - | code == _versionCode mainnet = mainnet - | code == _versionCode testnet04 = testnet04 - | otherwise = - -- Setting the version code here allows us to delay doing the lookup in - -- the case that we don't actually need the version, just the code. - lookupVersion & versionCode .~ code - where - - lookupVersion :: HasCallStack => ChainwebVersion - lookupVersion = unsafeDupablePerformIO $ do - m <- readIORef versionMap - return $ fromMaybe (error notRegistered) $ - HM.lookup code m - - notRegistered - | code == _versionCode recapDevnet = "recapDevnet version used but not registered, remember to do so after it's configured. " <> perhaps - | code == _versionCode devnet = "devnet version used but not registered, remember to do so after it's configured. " <> perhaps - | otherwise = "version not registered with code " <> show code <> ", have you seen Chainweb.Test.TestVersions.testVersions?" - - perhaps = "Perhaps you are attempting to run a different devnet version than a previous run, and you need to delete your db directory before restarting devnet with the new version?" - --- TODO: ideally all uses of this are deprecated. currently in use in --- ObjectEncoded block header decoder and CutHashes decoder. -lookupVersionByName :: HasCallStack => ChainwebVersionName -> ChainwebVersion -lookupVersionByName name - | name == _versionName mainnet = mainnet - | name == _versionName testnet04 = testnet04 - | name == _versionName testnet06 = testnet06 - | otherwise = lookupVersion & versionName .~ name - where - lookupVersion = unsafeDupablePerformIO $ do - m <- readIORef versionMap - return $ fromMaybe (error notRegistered) $ - listToMaybe [ v | v <- HM.elems m, _versionName v == name ] - notRegistered - | name == _versionName recapDevnet = "recapDevnet version used but not registered, remember to do so after it's configured" - | name == _versionName devnet = "devnet version used but not registered, remember to do so after it's configured" - | otherwise = "version not registered with name " <> show name <> ", have you seen Chainweb.Test.TestVersions.testVersions?" - -fabricateVersionWithName :: HasCallStack => ChainwebVersionName -> ChainwebVersion -fabricateVersionWithName name = - error "attempted to access field of fabricated version." & versionName .~ name - -- | Versions known to us by name. knownVersions :: [ChainwebVersion] -knownVersions = [mainnet, testnet04, testnet06, recapDevnet, devnet] +knownVersions = + [ mainnet + , testnet04 + , testnet06 + , evmTestnet + , devnet + , evmDevnet + , recapDevnet + -- , evmDevnetSingleton + -- , evmDevnetPair + ] -- | Look up a known version by name, usually with `m` instantiated to some -- configuration parser monad. findKnownVersion :: MonadFail m => ChainwebVersionName -> m ChainwebVersion findKnownVersion vn = case find (\v -> _versionName v == vn) knownVersions of - Nothing -> fail $ T.unpack (getChainwebVersionName vn) <> " is not a known version: try development, mainnet01, or testnet04/06 " + Nothing -> fail $ + T.unpack (getChainwebVersionName vn) <> " is not a known version. perhaps you meant one of these:\n" + <> show (getChainwebVersionName . _versionName <$> knownVersions) Just v -> return v diff --git a/src/Chainweb/Version/Testnet04.hs b/src/Chainweb/Version/Testnet04.hs index 514b80c57c..4abb5dc83e 100644 --- a/src/Chainweb/Version/Testnet04.hs +++ b/src/Chainweb/Version/Testnet04.hs @@ -4,6 +4,7 @@ {-# language PatternSynonyms #-} {-# language QuasiQuotes #-} {-# language ViewPatterns #-} +{-# language ImportQualifiedPost #-} -- Note: Testnet04 is deprecated @@ -18,33 +19,30 @@ import Chainweb.BlockHeight import Chainweb.ChainId import Chainweb.Difficulty import Chainweb.Graph -import Chainweb.Pact5.InitialGasModel +import Chainweb.Pact.InitialGasModel +import Chainweb.Pact.Transactions.CoinV3Transactions qualified as CoinV3 +import Chainweb.Pact.Transactions.CoinV4Transactions qualified as CoinV4 +import Chainweb.Pact.Transactions.CoinV5Transactions qualified as CoinV5 +import Chainweb.Pact.Transactions.CoinV6Transactions qualified as CoinV6 +import Chainweb.Pact.Transactions.Mainnet0Transactions qualified as MN0 +import Chainweb.Pact.Transactions.Mainnet1Transactions qualified as MN1 +import Chainweb.Pact.Transactions.Mainnet2Transactions qualified as MN2 +import Chainweb.Pact.Transactions.Mainnet3Transactions qualified as MN3 +import Chainweb.Pact.Transactions.Mainnet4Transactions qualified as MN4 +import Chainweb.Pact.Transactions.Mainnet5Transactions qualified as MN5 +import Chainweb.Pact.Transactions.Mainnet6Transactions qualified as MN6 +import Chainweb.Pact.Transactions.Mainnet7Transactions qualified as MN7 +import Chainweb.Pact.Transactions.Mainnet8Transactions qualified as MN8 +import Chainweb.Pact.Transactions.Mainnet9Transactions qualified as MN9 +import Chainweb.Pact.Transactions.MainnetKADTransactions qualified as MNKAD import Chainweb.Time import Chainweb.Utils import Chainweb.Utils.Rule import Chainweb.Version import P2P.BootstrapNodes -import Pact.Types.Runtime (Gas(..)) -import Pact.Types.Verifier - -import qualified Chainweb.Pact.Transactions.CoinV3Transactions as CoinV3 -import qualified Chainweb.Pact.Transactions.CoinV4Transactions as CoinV4 -import qualified Chainweb.Pact.Transactions.CoinV5Transactions as CoinV5 -import qualified Chainweb.Pact.Transactions.CoinV6Transactions as CoinV6 -import qualified Chainweb.Pact.Transactions.Mainnet0Transactions as MN0 -import qualified Chainweb.Pact.Transactions.Mainnet1Transactions as MN1 -import qualified Chainweb.Pact.Transactions.Mainnet2Transactions as MN2 -import qualified Chainweb.Pact.Transactions.Mainnet3Transactions as MN3 -import qualified Chainweb.Pact.Transactions.Mainnet4Transactions as MN4 -import qualified Chainweb.Pact.Transactions.Mainnet5Transactions as MN5 -import qualified Chainweb.Pact.Transactions.Mainnet6Transactions as MN6 -import qualified Chainweb.Pact.Transactions.Mainnet7Transactions as MN7 -import qualified Chainweb.Pact.Transactions.Mainnet8Transactions as MN8 -import qualified Chainweb.Pact.Transactions.Mainnet9Transactions as MN9 -import qualified Chainweb.Pact.Transactions.MainnetKADTransactions as MNKAD -import qualified Chainweb.BlockHeader.Genesis.Testnet040Payload as PN0 -import qualified Chainweb.BlockHeader.Genesis.Testnet041to19Payload as PNN +import Pact.Core.Gas (Gas(..)) +import Pact.Core.Names -- | Initial hash target for testnet04 20-chain transition. Based on the following -- header from recap devnet running with 5 GPUs hash power. Using this target unchanged @@ -96,51 +94,51 @@ pattern Testnet04 <- ((== testnet04) -> True) where Testnet04 = testnet04 testnet04 :: ChainwebVersion -testnet04 = ChainwebVersion +testnet04 = withVersion testnet04 $ ChainwebVersion { _versionCode = ChainwebVersionCode 0x00000007 , _versionName = ChainwebVersionName "testnet04" , _versionForks = tabulateHashMap $ \case - SlowEpoch -> AllChains ForkAtGenesis - Vuln797Fix -> AllChains ForkAtGenesis + SlowEpoch -> onAllChains ForkAtGenesis + Vuln797Fix -> onAllChains ForkAtGenesis CoinV2 -> onChains $ concat [ [(unsafeChainId i, ForkAtBlockHeight $ BlockHeight 1) | i <- [0..9]] , [(unsafeChainId i, ForkAtBlockHeight $ BlockHeight 337_000) | i <- [10..19]] ] - PactBackCompat_v16 -> AllChains $ ForkAtBlockHeight $ BlockHeight 0 - ModuleNameFix -> AllChains $ ForkAtBlockHeight $ BlockHeight 2 - SkipTxTimingValidation -> AllChains $ ForkAtBlockHeight $ BlockHeight 1 - OldTargetGuard -> AllChains $ ForkAtBlockHeight $ BlockHeight 0 - SkipFeatureFlagValidation -> AllChains $ ForkAtBlockHeight $ BlockHeight 0 - ModuleNameFix2 -> AllChains $ ForkAtBlockHeight $ BlockHeight 289_966 -- ~ 2020-07-13 - OldDAGuard -> AllChains $ ForkAtBlockHeight $ BlockHeight 318_204 -- ~ 2020-07-23 16:00:00 - PactEvents -> AllChains $ ForkAtBlockHeight $ BlockHeight 660_000 - SPVBridge -> AllChains $ ForkAtBlockHeight $ BlockHeight 820_000 -- 2021-01-14T17:12:02 - Pact4Coin3 -> AllChains $ ForkAtBlockHeight $ BlockHeight 1_261_000 -- 2021-06-17T15:54:14 - EnforceKeysetFormats -> AllChains $ ForkAtBlockHeight $ BlockHeight 1_701_000 -- 2021-11-18T17:54:36 - Pact42 -> AllChains $ ForkAtBlockHeight $ BlockHeight 1_862_000 -- 2021-06-19T03:34:05 - CheckTxHash -> AllChains $ ForkAtBlockHeight $ BlockHeight 1_889_000 -- 2022-01-24T04:19:24 - Chainweb213Pact -> AllChains $ ForkAtBlockHeight $ BlockHeight 1_974_556 -- 2022-02-25 00:00:00 - Chainweb214Pact -> AllChains $ ForkAtBlockHeight $ BlockHeight 2_134_331 -- 2022-04-21T12:00:00Z - Chainweb215Pact -> AllChains $ ForkAtBlockHeight $ BlockHeight 2_295_437 -- 2022-06-16T12:00:00+00:00 - Pact44NewTrans -> AllChains $ ForkAtBlockHeight $ BlockHeight 2_500_369 -- Todo: add date - Chainweb216Pact -> AllChains $ ForkAtBlockHeight $ BlockHeight 2_516_739 -- 2022-09-01 12:00:00+00:00 - Chainweb217Pact -> AllChains $ ForkAtBlockHeight $ BlockHeight 2_777_367 -- 2022-12-01 12:00:00+00:00 - Chainweb218Pact -> AllChains $ ForkAtBlockHeight $ BlockHeight 3_038_343 -- 2023-03-02 12:00:00+00:00 - Chainweb219Pact -> AllChains $ ForkAtBlockHeight $ BlockHeight 3_299_753 -- 2023-06-01 12:00:00+00:00 - Chainweb220Pact -> AllChains $ ForkAtBlockHeight $ BlockHeight 3_580_964 -- 2023-09-08 12:00:00+00:00 - Chainweb221Pact -> AllChains $ ForkAtBlockHeight $ BlockHeight 3_702_250 -- 2023-10-19 12:00:00+00:00 - Chainweb222Pact -> AllChains $ ForkAtBlockHeight $ BlockHeight 3_859_808 -- 2023-12-13 12:00:00+00:00 - Chainweb223Pact -> AllChains $ ForkAtBlockHeight $ BlockHeight 4_100_681 -- 2024-03-06 12:00:00+00:00 - Chainweb224Pact -> AllChains $ ForkAtBlockHeight $ BlockHeight 4_333_587 -- 2024-05-29 12:00:00+00:00 - Chainweb225Pact -> AllChains $ ForkAtBlockHeight $ BlockHeight 4_575_072 -- 2024-08-21 12:00:00+00:00 - Pact5Fork -> AllChains $ ForkAtBlockHeight $ BlockHeight 5_058_738 -- 2025-02-05 12:00:00+00:00 - Chainweb228Pact -> AllChains $ ForkAtBlockHeight $ BlockHeight 5_155_146 -- 2025-03-11 00:00:00+00:00 - Chainweb230Pact -> AllChains $ ForkAtBlockHeight $ BlockHeight 5_542_190 -- 2025-07-23 12:00:00+00:00 - Chainweb231Pact -> AllChains $ ForkAtBlockHeight $ BlockHeight 5_783_985 -- 2025-10-15 12:00:00+00:00 - Chainweb31 -> AllChains ForkNever - Chainweb32 -> AllChains ForkNever - MigratePlatformShare -> AllChains ForkNever - + PactBackCompat_v16 -> onAllChains $ ForkAtBlockHeight $ BlockHeight 0 + ModuleNameFix -> onAllChains $ ForkAtBlockHeight $ BlockHeight 2 + SkipTxTimingValidation -> onAllChains $ ForkAtBlockHeight $ BlockHeight 1 + OldTargetGuard -> onAllChains $ ForkAtBlockHeight $ BlockHeight 0 + SkipFeatureFlagValidation -> onAllChains $ ForkAtBlockHeight $ BlockHeight 0 + ModuleNameFix2 -> onAllChains $ ForkAtBlockHeight $ BlockHeight 289_966 -- ~ 2020-07-13 + OldDAGuard -> onAllChains $ ForkAtBlockHeight $ BlockHeight 318_204 -- ~ 2020-07-23 16:00:00 + PactEvents -> onAllChains $ ForkAtBlockHeight $ BlockHeight 660_000 + SPVBridge -> onAllChains $ ForkAtBlockHeight $ BlockHeight 820_000 -- 2021-01-14T17:12:02 + Pact4Coin3 -> onAllChains $ ForkAtBlockHeight $ BlockHeight 1_261_000 -- 2021-06-17T15:54:14 + EnforceKeysetFormats -> onAllChains $ ForkAtBlockHeight $ BlockHeight 1_701_000 -- 2021-11-18T17:54:36 + Pact42 -> onAllChains $ ForkAtBlockHeight $ BlockHeight 1_862_000 -- 2021-06-19T03:34:05 + CheckTxHash -> onAllChains $ ForkAtBlockHeight $ BlockHeight 1_889_000 -- 2022-01-24T04:19:24 + Chainweb213Pact -> onAllChains $ ForkAtBlockHeight $ BlockHeight 1_974_556 -- 2022-02-25 00:00:00 + Chainweb214Pact -> onAllChains $ ForkAtBlockHeight $ BlockHeight 2_134_331 -- 2022-04-21T12:00:00Z + Chainweb215Pact -> onAllChains $ ForkAtBlockHeight $ BlockHeight 2_295_437 -- 2022-06-16T12:00:00+00:00 + Pact44NewTrans -> onAllChains $ ForkAtBlockHeight $ BlockHeight 2_500_369 -- Todo: add date + Chainweb216Pact -> onAllChains $ ForkAtBlockHeight $ BlockHeight 2_516_739 -- 2022-09-01 12:00:00+00:00 + Chainweb217Pact -> onAllChains $ ForkAtBlockHeight $ BlockHeight 2_777_367 -- 2022-12-01 12:00:00+00:00 + Chainweb218Pact -> onAllChains $ ForkAtBlockHeight $ BlockHeight 3_038_343 -- 2023-03-02 12:00:00+00:00 + Chainweb219Pact -> onAllChains $ ForkAtBlockHeight $ BlockHeight 3_299_753 -- 2023-06-01 12:00:00+00:00 + Chainweb220Pact -> onAllChains $ ForkAtBlockHeight $ BlockHeight 3_580_964 -- 2023-09-08 12:00:00+00:00 + Chainweb221Pact -> onAllChains $ ForkAtBlockHeight $ BlockHeight 3_702_250 -- 2023-10-19 12:00:00+00:00 + Chainweb222Pact -> onAllChains $ ForkAtBlockHeight $ BlockHeight 3_859_808 -- 2023-12-13 12:00:00+00:00 + Chainweb223Pact -> onAllChains $ ForkAtBlockHeight $ BlockHeight 4_100_681 -- 2024-03-06 12:00:00+00:00 + Chainweb224Pact -> onAllChains $ ForkAtBlockHeight $ BlockHeight 4_333_587 -- 2024-05-29 12:00:00+00:00 + Chainweb225Pact -> onAllChains $ ForkAtBlockHeight $ BlockHeight 4_575_072 -- 2024-08-21 12:00:00+00:00 + Pact5Fork -> onAllChains $ ForkAtBlockHeight $ BlockHeight 5_058_738 -- 2025-02-05 12:00:00+00:00 + Chainweb228Pact -> onAllChains $ ForkAtBlockHeight $ BlockHeight 5_155_146 -- 2025-03-11 00:00:00+00:00 + HashedAdjacentRecord -> onAllChains ForkNever + Chainweb230Pact -> onAllChains $ ForkAtBlockHeight $ BlockHeight 5_542_190 -- 2025-07-23 12:00:00+00:00 + Chainweb231Pact -> onAllChains $ ForkAtBlockHeight $ BlockHeight 5_783_985 -- 2025-10-15 12:00:00+00:00 + Chainweb31 -> onAllChains ForkNever + Chainweb32 -> onAllChains ForkNever + MigratePlatformShare -> onAllChains ForkNever , _versionGraphs = (to20ChainsTestnet, twentyChainGraph) `Above` Bottom (minBound, petersenChainGraph) @@ -150,7 +148,7 @@ testnet04 = ChainwebVersion , _versionMaxBlockGasLimit = (succByHeight $ testnet04 ^?! versionForks . at Chainweb216Pact . _Just . atChain (unsafeChainId 0) , Just 180_000) `Above` Bottom (minBound, Nothing) - , _versionInitialGasModel = AllChains $ + , _versionInitialGasModel = onAllChains $ (ForkNever, post32GasModel) `Above` (succByHeight $ testnet04 ^?! versionForks . at Chainweb231Pact . _Just . atChain (unsafeChainId 0), post31GasModel) `Above` Bottom (minBound, pre31GasModel) @@ -159,19 +157,37 @@ testnet04 = ChainwebVersion Bottom (minBound, Nothing) , _versionBootstraps = domainAddr2PeerInfo testnet04BootstrapHosts , _versionGenesis = VersionGenesis - { _genesisBlockTarget = OnChains $ HM.fromList $ concat + { _genesisBlockTarget = ChainMap $ HM.fromList $ concat [ [(unsafeChainId i, maxTarget) | i <- [0..9]] , [(unsafeChainId i, testnet20InitialHashTarget) | i <- [10..19]] ] - , _genesisTime = AllChains $ BlockCreationTime [timeMicrosQQ| 2019-07-17T18:28:37.613832 |] - , _genesisBlockPayload = OnChains $ HM.fromList $ concat - [ [(unsafeChainId 0, PN0.payloadBlock)] - , [(unsafeChainId i, PNN.payloadBlock) | i <- [1..19]] + , _genesisTime = onAllChains $ BlockCreationTime [timeMicrosQQ| 2019-07-17T18:28:37.613832 |] + , _genesisBlockPayload = onChains + [ (unsafeChainId 0, unsafeFromText "nfYm3e_fk2ICws0Uowos6OMuqfFg5Nrl_zqXVx9v_ZQ") + , (unsafeChainId 1, unsafeFromText "HU-ZhdfsQCiTrfxjtbkr5MHmjoukOt6INqB2vuYiF3g") + , (unsafeChainId 2, unsafeFromText "HU-ZhdfsQCiTrfxjtbkr5MHmjoukOt6INqB2vuYiF3g") + , (unsafeChainId 3, unsafeFromText "HU-ZhdfsQCiTrfxjtbkr5MHmjoukOt6INqB2vuYiF3g") + , (unsafeChainId 4, unsafeFromText "HU-ZhdfsQCiTrfxjtbkr5MHmjoukOt6INqB2vuYiF3g") + , (unsafeChainId 5, unsafeFromText "HU-ZhdfsQCiTrfxjtbkr5MHmjoukOt6INqB2vuYiF3g") + , (unsafeChainId 6, unsafeFromText "HU-ZhdfsQCiTrfxjtbkr5MHmjoukOt6INqB2vuYiF3g") + , (unsafeChainId 7, unsafeFromText "HU-ZhdfsQCiTrfxjtbkr5MHmjoukOt6INqB2vuYiF3g") + , (unsafeChainId 8, unsafeFromText "HU-ZhdfsQCiTrfxjtbkr5MHmjoukOt6INqB2vuYiF3g") + , (unsafeChainId 9, unsafeFromText "HU-ZhdfsQCiTrfxjtbkr5MHmjoukOt6INqB2vuYiF3g") + , (unsafeChainId 10, unsafeFromText "HU-ZhdfsQCiTrfxjtbkr5MHmjoukOt6INqB2vuYiF3g") + , (unsafeChainId 11, unsafeFromText "HU-ZhdfsQCiTrfxjtbkr5MHmjoukOt6INqB2vuYiF3g") + , (unsafeChainId 12, unsafeFromText "HU-ZhdfsQCiTrfxjtbkr5MHmjoukOt6INqB2vuYiF3g") + , (unsafeChainId 13, unsafeFromText "HU-ZhdfsQCiTrfxjtbkr5MHmjoukOt6INqB2vuYiF3g") + , (unsafeChainId 14, unsafeFromText "HU-ZhdfsQCiTrfxjtbkr5MHmjoukOt6INqB2vuYiF3g") + , (unsafeChainId 15, unsafeFromText "HU-ZhdfsQCiTrfxjtbkr5MHmjoukOt6INqB2vuYiF3g") + , (unsafeChainId 16, unsafeFromText "HU-ZhdfsQCiTrfxjtbkr5MHmjoukOt6INqB2vuYiF3g") + , (unsafeChainId 17, unsafeFromText "HU-ZhdfsQCiTrfxjtbkr5MHmjoukOt6INqB2vuYiF3g") + , (unsafeChainId 18, unsafeFromText "HU-ZhdfsQCiTrfxjtbkr5MHmjoukOt6INqB2vuYiF3g") + , (unsafeChainId 19, unsafeFromText "HU-ZhdfsQCiTrfxjtbkr5MHmjoukOt6INqB2vuYiF3g") ] } , _versionUpgrades = chainZip HM.union - (indexByForkHeights testnet04 - [ (CoinV2, onChains $ + (indexByForkHeights + [ (CoinV2, onChains [ (unsafeChainId 0, pact4Upgrade MN0.transactions) , (unsafeChainId 1, pact4Upgrade MN1.transactions) , (unsafeChainId 2, pact4Upgrade MN2.transactions) @@ -183,10 +199,10 @@ testnet04 = ChainwebVersion , (unsafeChainId 8, pact4Upgrade MN8.transactions) , (unsafeChainId 9, pact4Upgrade MN9.transactions) ]) - , (Pact4Coin3, AllChains (Pact4Upgrade CoinV3.transactions True)) - , (Chainweb214Pact, AllChains (Pact4Upgrade CoinV4.transactions True)) - , (Chainweb215Pact, AllChains (Pact4Upgrade CoinV5.transactions True)) - , (Chainweb223Pact, AllChains (pact4Upgrade CoinV6.transactions)) + , (Pact4Coin3, onAllChains (Pact4Upgrade CoinV3.transactions True)) + , (Chainweb214Pact, onAllChains (Pact4Upgrade CoinV4.transactions True)) + , (Chainweb215Pact, onAllChains (Pact4Upgrade CoinV5.transactions True)) + , (Chainweb223Pact, onAllChains (pact4Upgrade CoinV6.transactions)) ]) (onChains [(unsafeChainId 0, HM.singleton to20ChainsTestnet (pact4Upgrade MNKAD.transactions))]) , _versionCheats = VersionCheats @@ -198,7 +214,10 @@ testnet04 = ChainwebVersion { _disablePeerValidation = False , _disableMempoolSync = False } - , _versionVerifierPluginNames = AllChains $ (ForkAtBlockHeight $ BlockHeight $ 4_100_681, Set.fromList [VerifierName "hyperlane_v3_message"]) `Above` + , _versionVerifierPluginNames = onAllChains $ + ( ForkAtBlockHeight $ BlockHeight 4_100_681 + , Set.fromList [VerifierName "hyperlane_v3_message"] + ) `Above` Bottom (minBound, mempty) , _versionQuirks = VersionQuirks { _quirkGasFees = onChains @@ -206,6 +225,7 @@ testnet04 = ChainwebVersion , (unsafeChainId 2, HM.fromList [((BlockHeight 4108311, TxBlockIdx 0), Gas 65_130)]) ] } + , _versionPayloadProviderTypes = onAllChains PactProvider , _versionForkNumber = 0 , _versionForkVoteCastingLength = 120 * 119 -- 5 days } diff --git a/src/Chainweb/Version/Testnet06.hs b/src/Chainweb/Version/Testnet06.hs index c5c42d2b00..81b962f211 100644 --- a/src/Chainweb/Version/Testnet06.hs +++ b/src/Chainweb/Version/Testnet06.hs @@ -16,14 +16,15 @@ import Chainweb.BlockHeight import Chainweb.ChainId import Chainweb.Difficulty import Chainweb.Graph -import Chainweb.Pact5.InitialGasModel +import Chainweb.Pact.InitialGasModel +import Chainweb.Pact.Payload (_payloadWithOutputsPayloadHash) import Chainweb.Time import Chainweb.Utils import Chainweb.Utils.Rule import Chainweb.Version import P2P.BootstrapNodes -import Pact.Types.Verifier +import Pact.Core.Names (VerifierName(..)) import qualified Chainweb.Pact.Transactions.OtherTransactions as CoinV2 import qualified Chainweb.Pact.Transactions.CoinV3Transactions as CoinV3 @@ -39,56 +40,57 @@ pattern Testnet06 <- ((== testnet06) -> True) where Testnet06 = testnet06 testnet06 :: ChainwebVersion -testnet06 = ChainwebVersion +testnet06 = withVersion testnet06 $ ChainwebVersion { _versionCode = ChainwebVersionCode 0x00000008 , _versionName = ChainwebVersionName "testnet06" , _versionForks = tabulateHashMap $ \case - SlowEpoch -> AllChains $ ForkAtBlockHeight $ BlockHeight 0 - Vuln797Fix -> AllChains $ ForkAtBlockHeight $ BlockHeight 0 - PactBackCompat_v16 -> AllChains $ ForkAtBlockHeight $ BlockHeight 0 - OldTargetGuard -> AllChains $ ForkAtBlockHeight $ BlockHeight 0 - SkipFeatureFlagValidation -> AllChains $ ForkAtBlockHeight $ BlockHeight 0 - SkipTxTimingValidation -> AllChains $ ForkAtBlockHeight $ BlockHeight 2 - ModuleNameFix -> AllChains $ ForkAtBlockHeight $ BlockHeight 2 - ModuleNameFix2 -> AllChains $ ForkAtBlockHeight $ BlockHeight 2 + SlowEpoch -> onAllChains $ ForkAtBlockHeight $ BlockHeight 0 + Vuln797Fix -> onAllChains $ ForkAtBlockHeight $ BlockHeight 0 + PactBackCompat_v16 -> onAllChains $ ForkAtBlockHeight $ BlockHeight 0 + OldTargetGuard -> onAllChains $ ForkAtBlockHeight $ BlockHeight 0 + SkipFeatureFlagValidation -> onAllChains $ ForkAtBlockHeight $ BlockHeight 0 + SkipTxTimingValidation -> onAllChains $ ForkAtBlockHeight $ BlockHeight 2 + ModuleNameFix -> onAllChains $ ForkAtBlockHeight $ BlockHeight 2 + ModuleNameFix2 -> onAllChains $ ForkAtBlockHeight $ BlockHeight 2 CoinV2 -> onChains $ [(unsafeChainId 0, ForkAtBlockHeight $ BlockHeight 3)] <> [(unsafeChainId i, ForkAtBlockHeight $ BlockHeight 4) | i <- [1..19]] - OldDAGuard -> AllChains $ ForkAtBlockHeight $ BlockHeight 13 - PactEvents -> AllChains $ ForkAtBlockHeight $ BlockHeight 40 - SPVBridge -> AllChains $ ForkAtBlockHeight $ BlockHeight 50 - Pact4Coin3 -> AllChains $ ForkAtBlockHeight $ BlockHeight 80 - Pact42 -> AllChains $ ForkAtBlockHeight $ BlockHeight 90 - EnforceKeysetFormats -> AllChains $ ForkAtBlockHeight $ BlockHeight 100 - CheckTxHash -> AllChains $ ForkAtBlockHeight $ BlockHeight 110 - Chainweb213Pact -> AllChains $ ForkAtBlockHeight $ BlockHeight 95 - Chainweb214Pact -> AllChains $ ForkAtBlockHeight $ BlockHeight 115 - Chainweb215Pact -> AllChains $ ForkAtBlockHeight $ BlockHeight 165 - Pact44NewTrans -> AllChains $ ForkAtBlockHeight $ BlockHeight 185 - Chainweb216Pact -> AllChains $ ForkAtBlockHeight $ BlockHeight 215 - Chainweb217Pact -> AllChains $ ForkAtBlockHeight $ BlockHeight 470 - Chainweb218Pact -> AllChains $ ForkAtBlockHeight $ BlockHeight 500 - Chainweb219Pact -> AllChains $ ForkAtBlockHeight $ BlockHeight 550 - Chainweb220Pact -> AllChains $ ForkAtBlockHeight $ BlockHeight 560 - Chainweb221Pact -> AllChains $ ForkAtBlockHeight $ BlockHeight 580 - Chainweb222Pact -> AllChains $ ForkAtBlockHeight $ BlockHeight 590 - Chainweb223Pact -> AllChains $ ForkAtBlockHeight $ BlockHeight 600 - Chainweb224Pact -> AllChains $ ForkAtBlockHeight $ BlockHeight 610 - Chainweb225Pact -> AllChains $ ForkAtBlockHeight $ BlockHeight 620 - Pact5Fork -> AllChains $ ForkAtBlockHeight $ BlockHeight 640 - Chainweb228Pact -> AllChains $ ForkAtBlockHeight $ BlockHeight 650 - Chainweb230Pact -> AllChains $ ForkAtBlockHeight $ BlockHeight 680 - Chainweb231Pact -> AllChains $ ForkAtBlockHeight $ BlockHeight 690 - Chainweb31 -> AllChains $ ForkAtBlockHeight $ BlockHeight 700 - Chainweb32-> AllChains (ForkAtForkNumber 1) - MigratePlatformShare -> AllChains $ ForkNever + OldDAGuard -> onAllChains $ ForkAtBlockHeight $ BlockHeight 13 + PactEvents -> onAllChains $ ForkAtBlockHeight $ BlockHeight 40 + SPVBridge -> onAllChains $ ForkAtBlockHeight $ BlockHeight 50 + Pact4Coin3 -> onAllChains $ ForkAtBlockHeight $ BlockHeight 80 + Pact42 -> onAllChains $ ForkAtBlockHeight $ BlockHeight 90 + EnforceKeysetFormats -> onAllChains $ ForkAtBlockHeight $ BlockHeight 100 + CheckTxHash -> onAllChains $ ForkAtBlockHeight $ BlockHeight 110 + Chainweb213Pact -> onAllChains $ ForkAtBlockHeight $ BlockHeight 95 + Chainweb214Pact -> onAllChains $ ForkAtBlockHeight $ BlockHeight 115 + Chainweb215Pact -> onAllChains $ ForkAtBlockHeight $ BlockHeight 165 + Pact44NewTrans -> onAllChains $ ForkAtBlockHeight $ BlockHeight 185 + Chainweb216Pact -> onAllChains $ ForkAtBlockHeight $ BlockHeight 215 + Chainweb217Pact -> onAllChains $ ForkAtBlockHeight $ BlockHeight 470 + Chainweb218Pact -> onAllChains $ ForkAtBlockHeight $ BlockHeight 500 + Chainweb219Pact -> onAllChains $ ForkAtBlockHeight $ BlockHeight 550 + Chainweb220Pact -> onAllChains $ ForkAtBlockHeight $ BlockHeight 560 + Chainweb221Pact -> onAllChains $ ForkAtBlockHeight $ BlockHeight 580 + Chainweb222Pact -> onAllChains $ ForkAtBlockHeight $ BlockHeight 590 + Chainweb223Pact -> onAllChains $ ForkAtBlockHeight $ BlockHeight 600 + Chainweb224Pact -> onAllChains $ ForkAtBlockHeight $ BlockHeight 610 + Chainweb225Pact -> onAllChains $ ForkAtBlockHeight $ BlockHeight 620 + Pact5Fork -> onAllChains $ ForkAtBlockHeight $ BlockHeight 640 + Chainweb228Pact -> onAllChains $ ForkAtBlockHeight $ BlockHeight 650 + Chainweb230Pact -> onAllChains $ ForkAtBlockHeight $ BlockHeight 680 + Chainweb231Pact -> onAllChains $ ForkAtBlockHeight $ BlockHeight 690 + Chainweb31 -> onAllChains $ ForkAtBlockHeight $ BlockHeight 700 + Chainweb32 -> onAllChains (ForkAtForkNumber 1) + MigratePlatformShare -> onAllChains ForkNever + HashedAdjacentRecord -> onAllChains ForkNever - , _versionUpgrades = foldr (chainZip HM.union) (AllChains mempty) - [ indexByForkHeights testnet06 - [ (CoinV2, AllChains (Pact4Upgrade CoinV2.transactions False)) - , (Pact4Coin3, AllChains (Pact4Upgrade CoinV3.transactions True)) - , (Chainweb214Pact, AllChains (Pact4Upgrade CoinV4.transactions True)) - , (Chainweb215Pact, AllChains (Pact4Upgrade CoinV5.transactions True)) - , (Chainweb223Pact, AllChains (Pact4Upgrade CoinV6.transactions False)) + , _versionUpgrades = foldr (chainZip HM.union) (onAllChains mempty) + [ indexByForkHeights + [ (CoinV2, onAllChains (Pact4Upgrade CoinV2.transactions False)) + , (Pact4Coin3, onAllChains (Pact4Upgrade CoinV3.transactions True)) + , (Chainweb214Pact, onAllChains (Pact4Upgrade CoinV4.transactions True)) + , (Chainweb215Pact, onAllChains (Pact4Upgrade CoinV5.transactions True)) + , (Chainweb223Pact, onAllChains (Pact4Upgrade CoinV6.transactions False)) ] ] @@ -101,13 +103,13 @@ testnet06 = ChainwebVersion { _genesisBlockTarget = onChains $ concat [ [(unsafeChainId i, HashTarget $ maxBound `div` 100_000) | i <- [0..19]] ] - , _genesisTime = AllChains $ BlockCreationTime [timeMicrosQQ| 2026-02-16T08:15:00.000000 |] + , _genesisTime = onAllChains $ BlockCreationTime [timeMicrosQQ| 2026-02-16T08:15:00.000000 |] , _genesisBlockPayload = onChains $ concat - [ [(unsafeChainId 0, TST0.payloadBlock)] - , [(unsafeChainId i, TSTN.payloadBlock) | i <- [1..19]] + [ [(unsafeChainId 0, _payloadWithOutputsPayloadHash TST0.payloadBlock)] + , [(unsafeChainId i, _payloadWithOutputsPayloadHash TSTN.payloadBlock) | i <- [1..19]] ] } - , _versionInitialGasModel = AllChains $ + , _versionInitialGasModel = onAllChains $ (testnet06 ^?! versionForks . at Chainweb32 . _Just . atChain (unsafeChainId 0), post32GasModel) `Above` Bottom (minBound, post31GasModel) , _versionMaxBlockGasLimit = Bottom (minBound, Just 180_000) @@ -121,10 +123,11 @@ testnet06 = ChainwebVersion { _disablePeerValidation = False , _disableMempoolSync = False } - , _versionVerifierPluginNames = AllChains $ + , _versionVerifierPluginNames = onAllChains $ (ForkAtBlockHeight $ BlockHeight 600, Set.fromList $ map VerifierName ["hyperlane_v3_message"]) `Above` Bottom (minBound, mempty) , _versionQuirks = noQuirks , _versionForkNumber = 1 , _versionForkVoteCastingLength = 120 * 119 -- 5 days + , _versionPayloadProviderTypes = onAllChains PactProvider } diff --git a/src/Chainweb/Version/Utils.hs b/src/Chainweb/Version/Utils.hs index 797003476d..8e00690de8 100644 --- a/src/Chainweb/Version/Utils.hs +++ b/src/Chainweb/Version/Utils.hs @@ -91,7 +91,7 @@ import Chainweb.Utils.Rule import Chainweb.Version import Chainweb.Version.Mainnet -import Pact.Types.Verifier +import Pact.Core.Names (VerifierName(..)) -- -------------------------------------------------------------------------- -- -- Utils @@ -126,14 +126,13 @@ atCutHeight h = snd . fromJuste . M.lookupLE h -- Post-condition: -- -- @ --- 0 == minimum $ M.keys $ chainGraphs v +-- 0 == minimum $ M.keys chainGraphs -- @ -- -chainGraphs :: HasChainwebVersion v => v -> M.Map BlockHeight ChainGraph -chainGraphs = \case - (_chainwebVersion -> v) - | _versionCode v == _versionCode mainnet -> mainnetGraphs - | otherwise -> M.fromDistinctDescList . toList . ruleElems $ _versionGraphs v +chainGraphs :: HasVersion => M.Map BlockHeight ChainGraph +chainGraphs + | _versionCode implicitVersion == _versionCode mainnet = mainnetGraphs + | otherwise = M.fromDistinctDescList . toList . ruleElems $ _versionGraphs implicitVersion where mainnetGraphs = M.fromDistinctDescList . toList . ruleElems $ _versionGraphs mainnet @@ -143,104 +142,91 @@ chainGraphs = \case -- Post-condition: -- -- @ --- 0 == minimum $ M.keys $ chainGraphs v +-- 0 == minimum $ M.keys chainGraphs -- @ -- chainGraphsAt - :: HasChainwebVersion v - => v - -> BlockHeight + :: HasVersion + => BlockHeight -> M.Map BlockHeight ChainGraph -chainGraphsAt v h = limitHeight h (chainGraphs v) +chainGraphsAt h = limitHeight h chainGraphs {-# INLINE chainGraphsAt #-} lastGraphChange - :: HasCallStack - => HasChainwebVersion v - => v - -> BlockHeight + :: (HasCallStack, HasVersion) + => BlockHeight -> BlockHeight -lastGraphChange v h = fst . fromJuste . M.lookupLE h $ chainGraphs v +lastGraphChange h = fst . fromJuste . M.lookupLE h $ chainGraphs {-# INLINE lastGraphChange #-} nextGraphChange - :: HasCallStack - => HasChainwebVersion v - => v + :: (HasCallStack, HasVersion) + => BlockHeight -> BlockHeight - -> BlockHeight -nextGraphChange v h = fst . fromJuste . M.lookupGT h $ chainGraphs v +nextGraphChange h = fst . fromJuste . M.lookupGT h $ chainGraphs {-# INLINE nextGraphChange #-} chainCountAt - :: HasCallStack - => HasChainwebVersion v - => v - -> BlockHeight + :: (HasCallStack, HasVersion) + => BlockHeight -> Natural -chainCountAt v h = order $ atHeight h $ chainGraphs v +chainCountAt h = order $ atHeight h $ chainGraphs {-# INLINE chainCountAt #-} degreeAt - :: HasCallStack - => HasChainwebVersion v - => v - -> BlockHeight + :: (HasCallStack, HasVersion) + => BlockHeight -> Natural -degreeAt v h = degree $ atHeight h $ chainGraphs v +degreeAt h = degree $ atHeight h $ chainGraphs {-# INLINE degreeAt #-} diameterAt - :: HasCallStack - => HasChainwebVersion v - => v - -> BlockHeight + :: (HasCallStack, HasVersion) + => BlockHeight -> Natural -diameterAt v h = diameter $ atHeight h $ chainGraphs v +diameterAt h = diameter $ atHeight h $ chainGraphs {-# INLINE diameterAt #-} chainIdsAt - :: HasCallStack - => HasChainwebVersion v - => v - -> BlockHeight + :: (HasCallStack, HasVersion) + => BlockHeight -> HS.HashSet ChainId -chainIdsAt v h = graphChainIds $ atHeight h $ chainGraphs v +chainIdsAt h = graphChainIds $ atHeight h $ chainGraphs {-# INLINE chainIdsAt #-} -- | Uniformily get a random ChainId at the top of the current chainweb -- -randomChainId :: HasChainwebVersion v => v -> IO ChainId -randomChainId v = randomChainIdAt v maxBound +randomChainId :: HasVersion => IO ChainId +randomChainId = randomChainIdAt maxBound {-# INLINE randomChainId #-} -- | Uniformily get a random ChainId at the given height of the chainweb -- -randomChainIdAt :: HasChainwebVersion v => v -> BlockHeight -> IO ChainId -randomChainIdAt v h = (!!) (toList cs) <$> randomRIO (0, length cs - 1) +randomChainIdAt :: HasVersion => BlockHeight -> IO ChainId +randomChainIdAt h = (!!) (toList cs) <$> randomRIO (0, length cs - 1) where - cs = chainIdsAt v h + cs = chainIdsAt h {-# INLINE randomChainIdAt #-} -- | Sometimes, in particular for testing and examples, some fixed chain id is -- needed, but it doesn't matter which one. This function provides some valid -- chain ids for the top of the current chainweb. -- -someChainId :: HasCallStack => HasChainwebVersion v => v -> ChainId -someChainId v = someChainIdAt v maxBound +someChainId :: HasVersion => ChainId +someChainId = someChainIdAt maxBound {-# INLINE someChainId #-} -- | Sometimes, in particular for testing and examples, some fixed chain id is -- needed, but it doesn't matter which one. This function provides some valid -- chain ids for the chainweb at the given height. -- -someChainIdAt :: HasCallStack => HasChainwebVersion v => v -> BlockHeight -> ChainId -someChainIdAt v h = minimum $ chainIdsAt v h +someChainIdAt :: HasVersion => BlockHeight -> ChainId +someChainIdAt h = minimum $ chainIdsAt h -- guaranteed to succeed because the empty graph isn't a valid chain graph. {-# INLINE someChainIdAt #-} -isGraphChange :: HasChainwebVersion v => v -> BlockHeight -> Bool -isGraphChange v h = M.member h (chainGraphs v) +isGraphChange :: HasVersion => BlockHeight -> Bool +isGraphChange h = M.member h chainGraphs {-# INLINE isGraphChange #-} -- -------------------------------------------------------------------------- -- @@ -251,41 +237,35 @@ isGraphChange v h = M.member h (chainGraphs v) -- Precondition: h > genesisHeight -- blockCountAt - :: HasCallStack - => HasChainwebVersion v + :: (HasCallStack, HasVersion) => HasChainId cid - => v - -> cid + => cid -> BlockHeight -> Natural -blockCountAt v cid h +blockCountAt cid h | h < gh = 0 | otherwise = 1 + int h - int gh where - gh = genesisBlockHeight (_chainwebVersion v) (_chainId cid) + gh = genesisBlockHeight (_chainId cid) -- | The block count accross all chains at a given block height -- globalBlockCountAt - :: HasCallStack - => HasChainwebVersion v - => v - -> BlockHeight + :: (HasCallStack, HasVersion) + => BlockHeight -> Natural -globalBlockCountAt v h = sum - $ fmap (\c -> blockCountAt v c h) +globalBlockCountAt h = sum + $ fmap (\c -> blockCountAt c h) $ toList - $ chainIdsAt v h + $ chainIdsAt h globalBlockDelayAt - :: HasCallStack - => HasChainwebVersion v - => v - -> BlockHeight + :: (HasCallStack, HasVersion) + => BlockHeight -> Double -globalBlockDelayAt v h = (int r / 1_000_000) / int (chainCountAt v h) +globalBlockDelayAt h = (int r / 1_000_000) / int (chainCountAt h) where - BlockDelay r = _versionBlockDelay (_chainwebVersion v) + BlockDelay r = _versionBlockDelay implicitVersion -- -------------------------------------------------------------------------- -- -- Cut Heights @@ -296,8 +276,8 @@ globalBlockDelayAt v h = (int r / 1_000_000) / int (chainCountAt v h) -- Note, that the result isn't accurate for block heights around a chain graph -- change. -- -avgCutHeightAt :: HasChainwebVersion v => v -> BlockHeight -> CutHeight -avgCutHeightAt v h = int $ int h * chainCountAt v h +avgCutHeightAt :: HasVersion => BlockHeight -> CutHeight +avgCutHeightAt h = int $ int h * chainCountAt h {-# INLINE avgCutHeightAt #-} -- | Cut height intervals for the chain graphs of a chainweb version @@ -305,54 +285,53 @@ avgCutHeightAt v h = int $ int h * chainCountAt v h -- Post-condition: -- -- @ --- 0 == minimum $ M.keys $ cutHeights v +-- 0 == minimum $ M.keys cutHeights -- @ -- chainGraphsByCutHeight - :: HasChainwebVersion v - => v - -> M.Map CutHeight ChainGraph + :: HasVersion + => M.Map CutHeight ChainGraph chainGraphsByCutHeight = M.fromList . fmap (\(h,g) -> (int h * int (order g), g)) . M.toAscList - . chainGraphs + $ chainGraphs {-# INLINE chainGraphsByCutHeight #-} -- | The chain graph at the given cut height -- -- Note, that the result isn't accurate during a chain graph change -- -chainGraphAtCutHeight :: HasChainwebVersion v => v -> CutHeight -> ChainGraph -chainGraphAtCutHeight v h = atCutHeight h $ chainGraphsByCutHeight v +chainGraphAtCutHeight :: HasVersion => CutHeight -> ChainGraph +chainGraphAtCutHeight h = atCutHeight h $ chainGraphsByCutHeight -- | The number of chains that exist at the given cut height -- -- Note, that the result isn't accurate during a chain graph change -- -chainCountAtCutHeight :: HasChainwebVersion v => v -> CutHeight -> Natural -chainCountAtCutHeight v = order . chainGraphAtCutHeight v +chainCountAtCutHeight :: HasVersion => CutHeight -> Natural +chainCountAtCutHeight = order . chainGraphAtCutHeight -- | The diameter of the chain graph at the given cut height -- -- Note, that the result isn't accurate during a chain graph change -- -diameterAtCutHeight :: HasChainwebVersion v => v -> CutHeight -> Natural -diameterAtCutHeight v = diameter . chainGraphAtCutHeight v +diameterAtCutHeight :: HasVersion => CutHeight -> Natural +diameterAtCutHeight = diameter . chainGraphAtCutHeight -- | The degree of the chain graph at the given cut height -- -- Note, that the result isn't accurate during a chain graph change -- -degreeAtCutHeight :: HasChainwebVersion v => v -> CutHeight -> Natural -degreeAtCutHeight v = degree . chainGraphAtCutHeight v +degreeAtCutHeight :: HasVersion => CutHeight -> Natural +degreeAtCutHeight = degree . chainGraphAtCutHeight -- | The average chain height at a given cut height. -- -- Note, that the result isn't accurate for block heights around a chain graph -- change. -- -avgBlockHeightAtCutHeight :: HasChainwebVersion v => v -> CutHeight -> Double -avgBlockHeightAtCutHeight v h = int h / int (chainCountAtCutHeight v h) +avgBlockHeightAtCutHeight :: HasVersion => CutHeight -> Double +avgBlockHeightAtCutHeight h = int h / int (chainCountAtCutHeight h) -- | The global number of blocks that exist at the given cut height. -- @@ -360,33 +339,27 @@ avgBlockHeightAtCutHeight v h = int h / int (chainCountAtCutHeight v h) -- change. -- blockCountAtCutHeight - :: HasCallStack - => HasChainwebVersion v - => v - -> CutHeight + :: (HasCallStack, HasVersion) + => CutHeight -> Natural -blockCountAtCutHeight v h - = globalBlockCountAt v (int k `div` int (order g)) + int (h - k) +blockCountAtCutHeight h + = globalBlockCountAt (int k `div` int (order g)) + int (h - k) where - (k, g) = fromJuste $ M.lookupLE h $ chainGraphsByCutHeight v + (k, g) = fromJuste $ M.lookupLE h $ chainGraphsByCutHeight lastGraphChangeByCutHeight - :: HasCallStack - => HasChainwebVersion v - => v + :: (HasCallStack, HasVersion) + => CutHeight -> CutHeight - -> CutHeight -lastGraphChangeByCutHeight v h - = fst $ fromJuste $ M.lookupLE h $ chainGraphsByCutHeight v +lastGraphChangeByCutHeight h + = fst $ fromJuste $ M.lookupLE h $ chainGraphsByCutHeight nextGraphChangeByCutHeight - :: HasCallStack - => HasChainwebVersion v - => v - -> CutHeight + :: (HasCallStack, HasVersion) + => CutHeight -> CutHeight -nextGraphChangeByCutHeight v h - = fst $ fromJuste $ M.lookupGT h $ chainGraphsByCutHeight v +nextGraphChangeByCutHeight h + = fst $ fromJuste $ M.lookupGT h $ chainGraphsByCutHeight -- -------------------------------------------------------------------------- -- -- Expected Block Count, Block Heights, and Cut Heights @@ -395,19 +368,17 @@ nextGraphChangeByCutHeight v h -- expected number of mined blocks during a test on a given chain. -- expectedBlockCountAfterSeconds - :: HasCallStack - => HasChainwebVersion v + :: (HasCallStack, HasVersion) => HasChainId cid - => v - -> cid + => cid -> Seconds -> Double -expectedBlockCountAfterSeconds v cid s = max 0 (1 + (int s / (int r / 1_000_000)) - int gh) +expectedBlockCountAfterSeconds cid s = max 0 (1 + (int s / (int r / 1_000_000)) - int gh) -- The `max 0` term is required for chains that were added during graph transitions -- and thus have `genesisHeight > 0` where - BlockDelay r = _versionBlockDelay (_chainwebVersion v) - gh = genesisBlockHeight (_chainwebVersion v) (_chainId cid) + BlockDelay r = _versionBlockDelay implicitVersion + gh = genesisBlockHeight (_chainId cid) -- | This function is useful for performance testing when calculating the -- expected number of mined blocks during a test accross all chains. @@ -417,50 +388,44 @@ expectedBlockCountAfterSeconds v cid s = max 0 (1 + (int s / (int r / 1_000_000) -- chainweb versions with fixed expected solve times and no difficulty adjustment. -- expectedGlobalBlockCountAfterSeconds - :: HasCallStack - => HasChainwebVersion v - => v - -> Seconds + :: (HasCallStack, HasVersion) + => Seconds -> Double -expectedGlobalBlockCountAfterSeconds v s = (* 0.4) +expectedGlobalBlockCountAfterSeconds s = (* 0.4) $ sum - $ fmap (\c -> expectedBlockCountAfterSeconds v c s) + $ fmap (\c -> expectedBlockCountAfterSeconds c s) $ toList - $ chainIdsAt v (round eh) + $ chainIdsAt (round eh) where - eh = expectedBlockHeightAfterSeconds v s + eh = expectedBlockHeightAfterSeconds s -- | The expected BlockHeight after the given number of seconds has passed. -- -- This function is useful for performance testing. -- expectedBlockHeightAfterSeconds - :: HasCallStack - => HasChainwebVersion v - => v - -> Seconds + :: (HasCallStack, HasVersion) + => Seconds -> Double -expectedBlockHeightAfterSeconds v s = int s / (int r / 1_000_000) +expectedBlockHeightAfterSeconds s = int s / (int r / 1_000_000) where - BlockDelay r = _versionBlockDelay (_chainwebVersion v) + BlockDelay r = _versionBlockDelay implicitVersion -- | The expected CutHeight after the given number of seconds has passed. -- -- This function is useful for performance testing. -- expectedCutHeightAfterSeconds - :: HasCallStack - => HasChainwebVersion v - => v - -> Seconds + :: (HasCallStack, HasVersion) + => Seconds -> Double -expectedCutHeightAfterSeconds v s = eh * int (chainCountAt v (round eh)) +expectedCutHeightAfterSeconds s = eh * int (chainCountAt (round eh)) where - eh = expectedBlockHeightAfterSeconds v s + eh = expectedBlockHeightAfterSeconds s -- | The verifier plugins enabled for a particular block. -verifiersAt :: ChainwebVersion -> ChainId -> ForkNumber -> BlockHeight -> Map VerifierName VerifierPlugin -verifiersAt v cid fn bh = +verifiersAt :: HasVersion => ChainId -> ForkNumber -> BlockHeight -> Map VerifierName VerifierPlugin +verifiersAt cid fn bh = M.restrictKeys allVerifierPlugins activeVerifierNames where activeVerifierNames @@ -468,7 +433,7 @@ verifiersAt v cid fn bh = $ ruleZipperHere $ snd $ ruleSeek (\h _ -> searchKey >= h) - $ _versionVerifierPluginNames v ^?! atChain cid + $ _versionVerifierPluginNames implicitVersion ^?! atChain cid searchKey = ForkAtBlockHeight bh `max` ForkAtForkNumber fn -- the mappings from names to verifier plugins is global. the list of verifier diff --git a/src/Chainweb/WebBlockHeaderDB.hs b/src/Chainweb/WebBlockHeaderDB.hs index 121a224338..89e7948d27 100644 --- a/src/Chainweb/WebBlockHeaderDB.hs +++ b/src/Chainweb/WebBlockHeaderDB.hs @@ -6,6 +6,7 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE OverloadedStrings #-} {-# OPTIONS_GHC -fno-warn-orphans #-} @@ -19,13 +20,14 @@ -- Collect the 'BlockHeaderDB's for all chains in a single data structure. -- module Chainweb.WebBlockHeaderDB -( WebBlockHeaderDb +( WebBlockHeaderDb(..) , mkWebBlockHeaderDb , initWebBlockHeaderDb , getWebBlockHeaderDb , webBlockHeaderDb , webEntries , lookupWebBlockHeaderDb +, lookupRankedWebBlockHeaderDb , lookupAdjacentParentHeader , lookupParentHeader , insertWebBlockHeaderDb @@ -47,7 +49,6 @@ import Control.Monad.Catch import Data.Foldable import Data.Functor.Of import qualified Data.HashMap.Strict as HM -import qualified Data.HashSet as HS import qualified Data.List as L import qualified Streaming.Prelude as S @@ -63,12 +64,15 @@ import Chainweb.BlockHeaderDB.Internal import Chainweb.ChainId import Chainweb.ChainValue import Chainweb.Graph +import Chainweb.Parent import Chainweb.TreeDB import Chainweb.Utils import Chainweb.Version import Chainweb.Storage.Table import Chainweb.Storage.Table.RocksDB +import Chainweb.Ranked(Ranked(..)) +import Chainweb.Utils.Serialization -- -------------------------------------------------------------------------- -- -- Web Chain Database @@ -84,111 +88,130 @@ import Chainweb.Storage.Table.RocksDB -- the dbs must be guarded see issue #123. -- data WebBlockHeaderDb = WebBlockHeaderDb - { _webBlockHeaderDb :: !(HM.HashMap ChainId BlockHeaderDb) - , _webChainwebVersion :: !ChainwebVersion + { _webBlockHeaderDb :: !(ChainMap BlockHeaderDb) + , _webCurrentPruneJob :: !(RocksDbTable () (BlockHeight, BlockHeight)) + , _webHighestPruned :: !(RocksDbTable () BlockHeight) } -instance HasChainGraph (WebBlockHeaderDb, BlockHeight) where - _chainGraph (v, h) = _chainGraph (_webChainwebVersion v, h) - {-# INLINE _chainGraph #-} - -instance HasChainwebVersion WebBlockHeaderDb where - _chainwebVersion = _webChainwebVersion - {-# INLINE _chainwebVersion #-} - -webBlockHeaderDb :: Getter WebBlockHeaderDb (HM.HashMap ChainId BlockHeaderDb) +webBlockHeaderDb :: Getter WebBlockHeaderDb (ChainMap BlockHeaderDb) webBlockHeaderDb = to _webBlockHeaderDb --- | Returns all blocks in all block header databases. --- -webEntries :: WebBlockHeaderDb -> (S.Stream (Of BlockHeader) IO () -> IO a) -> IO a -webEntries db f = go (view (webBlockHeaderDb . to HM.elems) db) mempty +-- | Returns all blocks in all block header databases, ordered ascending by +-- (block height, chain ID). +webEntries :: HasVersion => WebBlockHeaderDb -> Maybe MinRank -> Maybe MaxRank -> (S.Stream (Of BlockHeader) IO () -> IO a) -> IO a +webEntries db mir mar f = go (view (webBlockHeaderDb . to toList) db) mempty where - go [] s = f s - go (h:t) s = entries h Nothing Nothing Nothing Nothing $ \x -> - go t (() <$ S.mergeOn (view blockCreationTime) s x) - -- FIXME: should we include the rank in the order? + go [] s = f (mergeN (\bh -> (view blockHeight bh, view chainId bh)) s) + go (h:t) s = entries h Nothing Nothing mir mar $ \x -> + go t (void x : s) type instance Index WebBlockHeaderDb = ChainId type instance IxValue WebBlockHeaderDb = BlockHeaderDb instance IxedGet WebBlockHeaderDb where - ixg i = webBlockHeaderDb . ix i + ixg i = webBlockHeaderDb . ixg i {-# INLINE ixg #-} -instance (k ~ CasKeyType (ChainValue BlockHeader)) => ReadableTable WebBlockHeaderDb k (ChainValue BlockHeader) where +instance (HasVersion, k ~ CasKeyType (ChainValue BlockHeader)) => ReadableTable WebBlockHeaderDb k (ChainValue BlockHeader) where tableLookup db k = case preview (ixg (_chainId k)) db of Nothing -> return Nothing Just cdb -> sequence <$> traverse (tableLookup cdb) k {-# INLINE tableLookup #-} initWebBlockHeaderDb - :: RocksDb - -> ChainwebVersion + :: HasVersion + => RocksDb -> IO WebBlockHeaderDb -initWebBlockHeaderDb db v = WebBlockHeaderDb - <$!> itraverse (\cid _ -> initBlockHeaderDb (conf cid db)) (HS.toMap $ chainIds v) - <*> pure v +initWebBlockHeaderDb db = mkWebBlockHeaderDb db + <$!> tabulateChainsM (\cid -> initBlockHeaderDb (conf cid db)) where - conf cid = Configuration (genesisBlockHeader v cid) + conf cid = Configuration (genesisBlockHeader cid) -- | FIXME: this needs some consistency checks -- mkWebBlockHeaderDb - :: ChainwebVersion - -> HM.HashMap ChainId BlockHeaderDb + :: RocksDb + -> ChainMap BlockHeaderDb -> WebBlockHeaderDb -mkWebBlockHeaderDb v m = WebBlockHeaderDb m v +mkWebBlockHeaderDb db m = + WebBlockHeaderDb m pruneJobTable highestPrunedTable + where + pruneJobTable = newTable + db + (Chainweb.Storage.Table.RocksDB.Codec (\(l, u) -> runPutS $ encodeBlockHeight l >> encodeBlockHeight u) + (runGetS $ (,) <$> decodeBlockHeight <*> decodeBlockHeight)) + (Chainweb.Storage.Table.RocksDB.Codec (\_ -> mempty) (runGetS (pure ()))) + ["BlockHeader", "prune-job"] + + highestPrunedTable = newTable + db + (Chainweb.Storage.Table.RocksDB.Codec (runPutS . encodeBlockHeight) (runGetS decodeBlockHeight)) + (Chainweb.Storage.Table.RocksDB.Codec (\_ -> mempty) (runGetS (pure ()))) + ["BlockHeader", "highest-pruned"] getWebBlockHeaderDb - :: MonadThrow m + :: (MonadThrow m, HasVersion) => HasChainId p => WebBlockHeaderDb -> p -> m BlockHeaderDb getWebBlockHeaderDb db p = do checkWebChainId graph p - return $! _webBlockHeaderDb db HM.! _chainId p + return $! _webBlockHeaderDb db ^?! atChain (_chainId p) where - v = _chainwebVersion db - graph = chainGraphAt v maxBound + graph = chainGraphAt maxBound lookupWebBlockHeaderDb - :: WebBlockHeaderDb + :: HasVersion + => WebBlockHeaderDb -> ChainId -> BlockHash -> IO BlockHeader lookupWebBlockHeaderDb wdb c h = do - checkWebChainId (wdb, maxBound @BlockHeight) c + checkWebChainId (chainGraphAt $ maxBound @BlockHeight) c db <- getWebBlockHeaderDb wdb c lookupM db h +lookupRankedWebBlockHeaderDb + :: HasVersion + => WebBlockHeaderDb + -> ChainId + -> RankedBlockHash + -> IO BlockHeader +lookupRankedWebBlockHeaderDb wdb c rh = do + checkWebChainId (chainGraphAt $ maxBound @BlockHeight) c + db <- getWebBlockHeaderDb wdb c + lookupRankedM db (int $ _rankedHeight rh) (_ranked rh) + blockAdjacentParentHeaders - :: WebBlockHeaderDb + :: HasVersion + => WebBlockHeaderDb -> BlockHeader - -> IO (HM.HashMap ChainId BlockHeader) + -> IO (HM.HashMap ChainId (Parent BlockHeader)) blockAdjacentParentHeaders db h - = itraverse (lookupWebBlockHeaderDb db) + = itraverse (traverse . lookupWebBlockHeaderDb db) $ _getBlockHashRecord $ view blockAdjacentHashes h lookupAdjacentParentHeader - :: WebBlockHeaderDb + :: HasVersion + => WebBlockHeaderDb -> BlockHeader -> ChainId - -> IO BlockHeader + -> IO (Parent BlockHeader) lookupAdjacentParentHeader db h cid = do - checkWebChainId (db, view blockHeight h) h + checkWebChainId (chainGraphAt $ view blockHeight h) h let ph = h ^?! (blockAdjacentHashes . ix cid) - lookupWebBlockHeaderDb db cid ph + traverse (lookupWebBlockHeaderDb db cid) ph lookupParentHeader - :: WebBlockHeaderDb + :: HasVersion + => WebBlockHeaderDb -> BlockHeader - -> IO BlockHeader + -> IO (Parent BlockHeader) lookupParentHeader db h = do - checkWebChainId (db, view blockHeight h) h - lookupWebBlockHeaderDb db (_chainId h) (view blockParent h) + checkWebChainId (chainGraphAt $ view blockHeight h) h + traverse (lookupWebBlockHeaderDb db (_chainId h)) (view blockParent h) -- -------------------------------------------------------------------------- -- -- Insertion @@ -196,7 +219,8 @@ lookupParentHeader db h = do -- TODO create monotonic IsCas that doesn't support deletion insertWebBlockHeaderDbValidated - :: WebBlockHeaderDb + :: HasVersion + => WebBlockHeaderDb -> ValidatedHeader -> IO () insertWebBlockHeaderDbValidated wdb h = do @@ -204,7 +228,8 @@ insertWebBlockHeaderDbValidated wdb h = do insertBlockHeaderDb db h insertWebBlockHeaderDb - :: WebBlockHeaderDb + :: HasVersion + => WebBlockHeaderDb -> BlockHeader -> IO () insertWebBlockHeaderDb wdb h = do @@ -213,7 +238,8 @@ insertWebBlockHeaderDb wdb h = do insertWebBlockHeaderDbValidated wdb valHdr insertWebBlockHeaderDbManyValidated - :: WebBlockHeaderDb + :: HasVersion + => WebBlockHeaderDb -> ValidatedHeaders -> IO () insertWebBlockHeaderDbManyValidated wdb hdrs = do @@ -227,7 +253,8 @@ insertWebBlockHeaderDbManyValidated wdb hdrs = do unsafeInsertBlockHeaderDb db h insertWebBlockHeaderDbMany - :: Foldable f + :: HasVersion + => Foldable f => WebBlockHeaderDb -> f BlockHeader -> IO () @@ -250,7 +277,7 @@ insertWebBlockHeaderDbMany db es = do -- the graph of the parent headers. -- checkBlockHeaderGraph - :: MonadThrow m + :: (MonadThrow m, HasVersion) => BlockHeader -> m () checkBlockHeaderGraph b = void @@ -258,14 +285,15 @@ checkBlockHeaderGraph b = void where graph | isGenesisBlockHeader b = _chainGraph b - | otherwise = chainGraphAt (_chainwebVersion b) (view blockHeight b - 1) + | otherwise = chainGraphAt (view blockHeight b - 1) {-# INLINE checkBlockHeaderGraph #-} -- | Given a 'WebBlockHeaderDb' @db@, @checkBlockAdjacentParents h@ checks that -- all referenced adjacent parents block headers exist in @db@. -- checkBlockAdjacentParents - :: WebBlockHeaderDb + :: HasVersion + => WebBlockHeaderDb -> BlockHeader -> IO () checkBlockAdjacentParents db = void . blockAdjacentParentHeaders db diff --git a/src/Chainweb/WebPactExecutionService.hs b/src/Chainweb/WebPactExecutionService.hs deleted file mode 100644 index 0e689c1775..0000000000 --- a/src/Chainweb/WebPactExecutionService.hs +++ /dev/null @@ -1,255 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE ImplicitParams #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RankNTypes #-} - -module Chainweb.WebPactExecutionService - ( WebPactExecutionService(..) - , _webPactNewBlock - , _webPactValidateBlock - , _webPactSyncToBlock - , PactExecutionService(..) - , mkWebPactExecutionService - , mkPactExecutionService - , emptyPactExecutionService - , NewBlock(..) - , newBlockToPayloadWithOutputs - , newBlockParent - ) where - -import Control.Lens -import Control.Monad.Catch - -import qualified Data.HashMap.Strict as HM -import Data.Vector (Vector) - -import GHC.Stack - --- internal modules - -import Chainweb.BlockHash -import Chainweb.BlockHeader -import Chainweb.BlockHeight -import Chainweb.ChainId -import Chainweb.Mempool.Mempool (InsertError) -import Chainweb.Miner.Pact -import Chainweb.Pact.Service.BlockValidation -import Chainweb.Pact.Service.PactQueue -import Chainweb.Pact.Types -import Chainweb.Pact.Utils -import Chainweb.Payload -import qualified Chainweb.Pact4.Transaction as Pact4 -import Chainweb.Utils - -import qualified Pact.Core.Persistence as Pact5 -import Chainweb.Version -import Data.ByteString.Short (ShortByteString) -import qualified Pact.Core.Names as Pact5 -import qualified Pact.Core.Builtin as Pact5 -import qualified Pact.Core.Evaluate as Pact5 -import qualified Pact.Types.Command as Pact4 -import qualified Pact.Types.ChainMeta as Pact4 -import Data.Text (Text) -import Chainweb.BlockCreationTime (BlockCreationTime) - --- -------------------------------------------------------------------------- -- --- PactExecutionService - -data NewBlock - = NewBlockInProgress !(ForSomePactVersion BlockInProgress) - | NewBlockPayload !ParentHeader !PayloadWithOutputs - deriving Show - -newBlockToPayloadWithOutputs :: NewBlock -> PayloadWithOutputs -newBlockToPayloadWithOutputs (NewBlockInProgress bip) - = forAnyPactVersion finalizeBlock bip -newBlockToPayloadWithOutputs (NewBlockPayload _ pwo) - = pwo - -newBlockParent :: NewBlock -> (BlockHash, BlockHeight, BlockCreationTime) -newBlockParent (NewBlockInProgress (ForSomePactVersion _ bip)) = blockInProgressParent bip -newBlockParent (NewBlockPayload (ParentHeader ph) _) = - (view blockHash ph, view blockHeight ph, view blockCreationTime ph) - -instance HasChainwebVersion NewBlock where - _chainwebVersion (NewBlockInProgress (ForSomePactVersion _ bip)) = _chainwebVersion bip - _chainwebVersion (NewBlockPayload ph _) = _chainwebVersion ph - -instance HasChainId NewBlock where - _chainId (NewBlockInProgress (ForSomePactVersion _ bip)) = _chainId bip - _chainId (NewBlockPayload ph _) = _chainId ph - --- | Service API for interacting with a single or multi-chain ("Web") pact service. --- Thread-safe to be called from multiple threads. Backend is queue-backed on a per-chain --- basis. -data PactExecutionService = PactExecutionService - { _pactValidateBlock :: !( - BlockHeader -> - CheckablePayload -> - IO PayloadWithOutputs - ) - -- ^ Validate block payload data by running through pact service. - , _pactNewBlock :: !( - ChainId -> - Miner -> - NewBlockFill -> - ParentHeader -> - IO (Historical NewBlock) - ) - , _pactContinueBlock :: !( - forall pv. - ChainId -> - BlockInProgress pv -> - IO (Historical (BlockInProgress pv)) - ) - -- ^ Request a new block to be formed using mempool - , _pactLocal :: !( - Maybe LocalPreflightSimulation -> - Maybe LocalSignatureVerification -> - Maybe RewindDepth -> - Pact4.UnparsedTransaction -> - IO LocalResult) - -- ^ Directly execute a single transaction in "local" mode (all DB interactions rolled back). - -- Corresponds to `local` HTTP endpoint. - , _pactLookup :: !( - ChainId - -- for routing - -> Maybe ConfirmationDepth - -- confirmation depth - -> Vector ShortByteString - -- txs to lookup - -> IO (HM.HashMap ShortByteString (T2 BlockHeight BlockHash)) - ) - , _pactReadOnlyReplay :: !( - BlockHeader -> - Maybe BlockHeader -> - IO () - ) - -- ^ Lookup pact hashes as of a block header to detect duplicates - , _pactPreInsertCheck :: !( - ChainId - -> Vector (Pact4.Command (Pact4.PayloadWithText Pact4.PublicMeta Text)) - -> IO (Vector (Maybe InsertError))) - -- ^ Run speculative checks to find bad transactions (ie gas buy failures, etc) - , _pactBlockTxHistory :: !( - BlockHeader -> - Pact5.Domain Pact5.RowKey Pact5.RowData Pact5.CoreBuiltin Pact5.Info -> - IO (Historical BlockTxHistory) - ) - -- ^ Obtain all transaction history in block for specified table/domain. - , _pactHistoricalLookup :: !( - BlockHeader -> - Pact5.Domain Pact5.RowKey Pact5.RowData Pact5.CoreBuiltin Pact5.Info -> - Pact5.RowKey -> - IO (Historical (Maybe (Pact5.TxLog Pact5.RowData))) - ) - -- ^ Obtain latest entry at or before the given block for specified table/domain and row key. - , _pactSyncToBlock :: !( - BlockHeader -> - IO () - ) - } - --- | Newtype to indicate "routing"/multi-chain service. --- See 'mkWebPactExecutionService' for implementation. -newtype WebPactExecutionService = WebPactExecutionService - { _webPactExecutionService :: PactExecutionService - } - - -_webPactNewBlock - :: WebPactExecutionService - -> ChainId - -> Miner - -> NewBlockFill - -> ParentHeader - -> IO (Historical NewBlock) -_webPactNewBlock = _pactNewBlock . _webPactExecutionService -{-# INLINE _webPactNewBlock #-} - -_webPactContinueBlock - :: WebPactExecutionService - -> ChainId - -> BlockInProgress pv - -> IO (Historical (BlockInProgress pv)) -_webPactContinueBlock w cid bip = _pactContinueBlock (_webPactExecutionService w) cid bip -{-# INLINE _webPactContinueBlock #-} - -_webPactValidateBlock - :: WebPactExecutionService - -> BlockHeader - -> CheckablePayload - -> IO PayloadWithOutputs -_webPactValidateBlock = _pactValidateBlock . _webPactExecutionService -{-# INLINE _webPactValidateBlock #-} - -_webPactSyncToBlock - :: WebPactExecutionService - -> BlockHeader - -> IO () -_webPactSyncToBlock = _pactSyncToBlock . _webPactExecutionService -{-# INLINE _webPactSyncToBlock #-} - -mkWebPactExecutionService - :: HasCallStack - => HM.HashMap ChainId PactExecutionService - -> WebPactExecutionService -mkWebPactExecutionService hm = WebPactExecutionService $ PactExecutionService - { _pactValidateBlock = \h pd -> withChainService (_chainId h) $ \p -> _pactValidateBlock p h pd - , _pactNewBlock = \cid m fill parent -> withChainService cid $ \p -> _pactNewBlock p cid m fill parent - , _pactContinueBlock = \cid bip -> withChainService cid $ \p -> _pactContinueBlock p cid bip - , _pactLocal = \_pf _sv _rd _ct -> throwM $ userError "Chainweb.WebPactExecutionService.mkPactExecutionService: No web-level local execution supported" - , _pactLookup = \cid cd txs -> withChainService cid $ \p -> _pactLookup p cid cd txs - , _pactPreInsertCheck = \cid txs -> withChainService cid $ \p -> _pactPreInsertCheck p cid txs - , _pactBlockTxHistory = \h d -> withChainService (_chainId h) $ \p -> _pactBlockTxHistory p h d - , _pactHistoricalLookup = \h d k -> withChainService (_chainId h) $ \p -> _pactHistoricalLookup p h d k - , _pactSyncToBlock = \h -> withChainService (_chainId h) $ \p -> _pactSyncToBlock p h - , _pactReadOnlyReplay = \l u -> withChainService (_chainId l) $ \p -> _pactReadOnlyReplay p l u - } - where - withChainService cid act = maybe (err cid) act $ HM.lookup cid hm - err cid = throwM $ userError - $ "PactExecutionService: Invalid chain ID: " - ++ show cid - -mkPactExecutionService - :: PactQueue - -> PactExecutionService -mkPactExecutionService q = PactExecutionService - { _pactValidateBlock = \h pd -> do - validateBlock h pd q - , _pactNewBlock = \_ m fill parent -> do - fmap NewBlockInProgress <$> newBlock m fill parent q - , _pactContinueBlock = \_ bip -> do - continueBlock bip q - , _pactLocal = \pf sv rd ct -> - local pf sv rd ct q - , _pactLookup = \_ cd txs -> - lookupPactTxs cd txs q - , _pactPreInsertCheck = \_ txs -> - pactPreInsertCheck txs q - , _pactBlockTxHistory = \h d -> - pactBlockTxHistory h d q - , _pactHistoricalLookup = \h d k -> - pactHistoricalLookup h d k q - , _pactSyncToBlock = \h -> pactSyncToBlock h q - , _pactReadOnlyReplay = \l u -> pactReadOnlyReplay l u q - } - --- | A mock execution service for testing scenarios. Throws out anything it's --- given. --- -emptyPactExecutionService :: HasCallStack => PactExecutionService -emptyPactExecutionService = PactExecutionService - { _pactValidateBlock = \_ _ -> pure emptyPayload - , _pactNewBlock = \_ _ _ _ -> throwM (userError "emptyPactExecutionService: attempted `newBlock` call") - , _pactContinueBlock = \_ _ -> throwM (userError "emptyPactExecutionService: attempted `continueBlock` call") - , _pactLocal = \_ _ _ _ -> throwM (userError "emptyPactExecutionService: attempted `local` call") - , _pactLookup = \_ _ _ -> return $! HM.empty - , _pactPreInsertCheck = \_ txs -> return $ Nothing <$ txs - , _pactBlockTxHistory = \_ _ -> error "Chainweb.WebPactExecutionService.emptyPactExecutionService: pactBlockTxHistory unsupported" - , _pactHistoricalLookup = \_ _ _ -> error "Chainweb.WebPactExecutionService.emptyPactExecutionService: pactHistoryLookup unsupported" - , _pactSyncToBlock = \_ -> return () - , _pactReadOnlyReplay = \_ _ -> return () - } diff --git a/src/Data/PQueue.hs b/src/Data/PQueue.hs index fd0de8cd32..2fa41de513 100644 --- a/src/Data/PQueue.hs +++ b/src/Data/PQueue.hs @@ -18,10 +18,12 @@ module Data.PQueue , pQueueRemove , pQueueIsEmpty , pQueueSize +, pQueueToStream ) where import Control.Concurrent.STM import Control.Monad +import Control.Monad.IO.Class import Data.Ord import qualified Data.Map as M @@ -29,6 +31,9 @@ import qualified Data.Set as S import Numeric.Natural +import Streaming (Stream, Of) +import qualified Streaming.Prelude as S + -- -------------------------------------------------------------------------- -- -- PQueue @@ -88,3 +93,8 @@ pQueueRemove (PQueue mv sv _getPrio _getKey _) = atomically run writeTVar mv $! m' modifyTVar' sv (S.delete k) return a + +pQueueToStream :: PQueue a -> Stream (Of a) IO () +pQueueToStream pq = forever $ do + a <- liftIO (pQueueRemove pq) + S.yield a diff --git a/src/Network/X509/SelfSigned.hs b/src/Network/X509/SelfSigned.hs index c5359a7718..0c2bb5495b 100644 --- a/src/Network/X509/SelfSigned.hs +++ b/src/Network/X509/SelfSigned.hs @@ -720,7 +720,7 @@ certificateCache query = ValidationCache queryCallback (\_ _ _ -> return ()) <> " expected fingerprint: " <> T.unpack (fingerprintToText f) <> " but got fingerprint: " <> T.unpack (fingerprintToText fp) --- | Check whether a connection failed due to an certificate missmatch +-- | Check whether a connection failed due to an certificate mismatch -- isCertificateMismatchException :: HttpException -> Bool isCertificateMismatchException (HttpExceptionRequest _ (InternalException e)) = diff --git a/src/P2P/BootstrapNodes.hs b/src/P2P/BootstrapNodes.hs index 72747880a7..7bd48d7057 100644 --- a/src/P2P/BootstrapNodes.hs +++ b/src/P2P/BootstrapNodes.hs @@ -13,8 +13,8 @@ module P2P.BootstrapNodes ( mainnetBootstrapHosts , testnet04BootstrapHosts +, evmTestnetBootstrapHosts , testnet06BootstrapHosts -, ) where -- internal modules @@ -74,3 +74,7 @@ testnet06BootstrapHosts = map unsafeHostAddressFromText [ "testnet06-1.chainweb-community.org:443" , "testnet06-2.chainweb-community.org:443" ] + + +evmTestnetBootstrapHosts :: [HostAddress] +evmTestnetBootstrapHosts = [] \ No newline at end of file diff --git a/src/P2P/Node.hs b/src/P2P/Node.hs index 2afa3fb062..c3db2063c8 100644 --- a/src/P2P/Node.hs +++ b/src/P2P/Node.hs @@ -11,6 +11,7 @@ {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} -- | -- Module: P2P.Node @@ -40,11 +41,17 @@ module P2P.Node , withPeerDb -- * P2P Node +, P2pNodeParameters(..) +, P2pNode , p2pCreateNode , p2pStartNode +, p2pStartNodeInactive , p2pStopNode +, p2pRunNode , guardPeerDb , getNewPeerManager +, setActive +, setInactive -- * Logging and Monitoring @@ -93,7 +100,7 @@ import qualified Data.Map.Strict as M import Data.Maybe import qualified Data.Set as S import qualified Data.Text as T -import Data.Tuple +import qualified Data.Tuple as Tuple import GHC.Generics import GHC.Stack @@ -123,7 +130,6 @@ import Data.LogMessage import Network.X509.SelfSigned -import P2P.Node.Configuration import P2P.Node.PeerDB import P2P.Node.RestAPI.Client import P2P.Peer @@ -205,7 +211,6 @@ makeLenses ''P2pSessionInfo -- data P2pNode = P2pNode { _p2pNodeNetworkId :: !NetworkId - , _p2pNodeChainwebVersion :: !ChainwebVersion , _p2pNodePeerInfo :: !PeerInfo , _p2pNodePeerDb :: !PeerDb , _p2pNodeSessions :: !(TVar (M.Map PeerInfo (P2pSessionInfo, Async (Maybe Bool)))) @@ -220,11 +225,12 @@ data P2pNode = P2pNode , _p2pNodeDoPeerSync :: !Bool -- ^ Synchronize peers at start of each session. Note, that this is -- expensive. + , _p2pNodePrivate :: !Bool + -- ^ Whether this node is private + , _p2pNodeMaxSessionCount :: !Natural + , _p2pNodeSessionTimeout :: !Seconds } -instance HasChainwebVersion P2pNode where - _chainwebVersion = _p2pNodeChainwebVersion - showSessionId :: PeerInfo -> Async (Maybe Bool) -> T.Text showSessionId pinf ses = showInfo pinf <> ":" <> (T.drop 9 . sshow $ asyncThreadId ses) @@ -290,7 +296,7 @@ loggFun :: P2pNode -> LogFunction loggFun = _p2pNodeLogFunction nodeRandom :: R.Random a => P2pNode -> (R.StdGen -> (a, R.StdGen)) -> IO a -nodeRandom node r = atomicModifyIORef' (_p2pNodeRng node) $ swap . r +nodeRandom node r = atomicModifyIORef' (_p2pNodeRng node) $ Tuple.swap . r {-# INLINE nodeRandom #-} nodeRandomR :: R.Random a => P2pNode -> (a, a) -> IO a @@ -312,6 +318,13 @@ nodeGeometric :: HasCallStack => P2pNode -> Double -> IO Int nodeGeometric node = nodeRandom node . geometric {-# INLINE nodeGeometric #-} +-- | Set a node active, causing it to initiating new sessions. +-- +setActive :: P2pNode -> STM () +setActive node = writeTVar (_p2pNodeActive node) True + +-- | Set a node inactive. An inactive node does not initiate any new sessions. +-- setInactive :: P2pNode -> STM () setInactive node = writeTVar (_p2pNodeActive node) False @@ -368,12 +381,12 @@ displayPeerValidationFailure IsLocalPeerAddress -- or white listing. -- guardPeerDb - :: ChainwebVersion - -> NetworkId + :: HasVersion + => NetworkId -> PeerDb -> PeerInfo -> IO (Either PeerValidationFailure PeerInfo) -guardPeerDb v nid peerDb pinf = do +guardPeerDb nid peerDb pinf = do peers <- peerDbSnapshot peerDb if | isMe -> return $ Left $ IsLocalPeerAddress @@ -388,7 +401,7 @@ guardPeerDb v nid peerDb pinf = do else return $ Left $ NodeVersionNotAccepted nodeVersion where isReserved :: Bool - isReserved = not (v ^. versionDefaults . disablePeerValidation) && isReservedHostAddress (_peerAddr pinf) + isReserved = not (implicitVersion ^. versionDefaults . disablePeerValidation) && isReservedHostAddress (_peerAddr pinf) -- Currently we are using 'getNewPeerManager' which doesn't validate -- certificates. We could be more strict and check that the certificate @@ -396,7 +409,10 @@ guardPeerDb v nid peerDb pinf = do -- canConnect = do mgr <- getNewPeerManager - getNodeVersion mgr (_versionName v) (_peerAddr pinf) (Just $ networkIdToText nid <> "/peer") + getNodeVersion mgr + (_versionName implicitVersion) + (_peerAddr pinf) + (Just $ networkIdToText nid <> "/peer") -- Only compare the address because even for equal peer infos the peer -- ID may be 'Nothing' for one peer and 'Just' some value for the other. @@ -407,7 +423,8 @@ isKnown :: PeerSet -> PeerInfo -> Bool isKnown peers pinf = not . IXS.null $ IXS.getEQ (_peerAddr pinf) peers guardPeerDbOfNode - :: P2pNode + :: HasVersion + => P2pNode -> PeerInfo -> IO (Maybe PeerInfo) guardPeerDbOfNode node pinf = go >>= \case @@ -422,7 +439,6 @@ guardPeerDbOfNode node pinf = go >>= \case Right x -> return (Just x) where go = guardPeerDb - (_chainwebVersion node) (_p2pNodeNetworkId node) (_p2pNodePeerDb node) pinf @@ -437,7 +453,7 @@ peerClientEnv node = peerInfoClientEnv (_p2pNodeManager node) -- -- TODO: handle paging -- -syncFromPeer :: P2pNode -> PeerInfo -> IO Bool +syncFromPeer :: HasVersion => P2pNode -> PeerInfo -> IO Bool syncFromPeer node info = do prunePeerDb (_p2pNodeLogFunction node) peerDb runClientM sync env >>= \case @@ -469,7 +485,6 @@ syncFromPeer node info = do return True where env = peerClientEnv node info - v = _p2pNodeChainwebVersion node nid = _p2pNodeNetworkId node peerDb = _p2pNodePeerDb node @@ -478,9 +493,9 @@ syncFromPeer node info = do sync :: ClientM (Page (NextItem Int) PeerInfo) sync = do - !p <- peerGetClient v nid Nothing Nothing + !p <- peerGetClient nid Nothing Nothing liftIO $ logg node Debug $ "got " <> sshow (_pageLimit p) <> " peers " <> showInfo info - void $ peerPutClient v nid (_p2pNodePeerInfo node) + void $ peerPutClient nid (_p2pNodePeerInfo node) liftIO $ logg node Debug $ "put own peer info to " <> showInfo info return p @@ -508,16 +523,15 @@ syncFromPeer node info = do -- @O(_p2pConfigActivePeerCount conf)@ -- findNextPeer - :: P2pConfiguration - -> P2pNode + :: P2pNode -> IO PeerEntry -findNextPeer conf node = do +findNextPeer node = do candidates <- awaitCandidates -- random circular shift of a set let shift :: Int -> [a] -> [a] shift i = uncurry (++) - . swap + . Tuple.swap . splitAt i let shiftR :: [a] -> IO [a] @@ -530,7 +544,6 @@ findNextPeer conf node = do -- this ix expensive but lazy and only forced if p0 is empty let p2 = L.groupBy ((==) `on` _peerEntrySuccessiveFailures) p1 - -- Choose the category to pick from -- -- In 95% of all cases are peer is selected from the highest priority, if possible. @@ -577,7 +590,7 @@ findNextPeer conf node = do -- Retry if there are more active sessions than the maximum number -- of sessions -- - check (int sessionCount < _p2pConfigMaxSessionCount conf) + check (int sessionCount < _p2pNodeMaxSessionCount node) let addrs = S.fromList (_peerAddr <$> M.keys sessions) @@ -614,9 +627,9 @@ findNextPeer conf node = do -- | This can loop forever if there are no peers available for the respective -- network. -- -newSession :: P2pConfiguration -> P2pNode -> IO () -newSession conf node = do - newPeer <- findNextPeer conf node +newSession :: HasVersion => P2pNode -> IO () +newSession node = do + newPeer <- findNextPeer node let newPeerInfo = _peerEntryInfo newPeer logg node Debug $ "Selected new peer " <> encodeToText newPeerInfo <> ", " @@ -631,7 +644,7 @@ newSession conf node = do -- FIXME there are better ways to prevent the node from spinning -- if no suitable (non-failing node) is available. -- cf. GitHub issue #117 - newSession conf node + newSession node True -> do logg node Debug $ "Connected to new peer " <> showInfo newPeerInfo let env = peerClientEnv node newPeerInfo @@ -649,11 +662,11 @@ newSession conf node = do logg node Debug $ "Started peer session " <> showSessionId newPeerInfo newSes loggFun node Info $ JsonLog info where - TimeSpan timeoutMs = secondsToTimeSpan @Double (_p2pConfigSessionTimeout conf) + TimeSpan timeoutMs = secondsToTimeSpan @Double (_p2pNodeSessionTimeout node) peerDb = _p2pNodePeerDb node syncFromPeer_ pinfo - | _p2pConfigPrivate conf = return True + | _p2pNodePrivate node = return True | _p2pNodeDoPeerSync node = syncFromPeer node pinfo | otherwise = return True @@ -739,85 +752,117 @@ waitAnySession node = do -- | Start a 'PeerDb' for the given set of NetworkIds -- startPeerDb - :: ChainwebVersion - -> HS.HashSet NetworkId - -> P2pConfiguration + :: HasVersion + => HS.HashSet NetworkId + -> Bool + -- ^ Whether this node is private + -> [PeerInfo] + -- ^ Set of statically known peers. -> IO PeerDb -startPeerDb v nids conf = do - !peerDb <- newEmptyPeerDb v +startPeerDb nids isPrivate knownPeers = do + !peerDb <- newEmptyPeerDb forM_ nids $ \nid -> - peerDbInsertPeerInfoList_ True nid (_p2pConfigKnownPeers conf) peerDb - return $ if _p2pConfigPrivate conf + peerDbInsertPeerInfoList_ True nid knownPeers peerDb + return $ if isPrivate then makePeerDbPrivate peerDb else peerDb -- | Stop a 'PeerDb', possibly persisting the db to a file. -- -stopPeerDb :: P2pConfiguration -> PeerDb -> IO () -stopPeerDb _ _ = return () +stopPeerDb :: PeerDb -> IO () +stopPeerDb _ = return () {-# INLINE stopPeerDb #-} -- | Run a computation with a PeerDb -- withPeerDb - :: ChainwebVersion - -> HS.HashSet NetworkId - -> P2pConfiguration + :: HasVersion + => HS.HashSet NetworkId + -> Bool + -- ^ Whether this node is private + -> [PeerInfo] + -- ^ Set of statically known peers -> (PeerDb -> IO a) -> IO a -withPeerDb v nids conf = bracket (startPeerDb v nids conf) (stopPeerDb conf) +withPeerDb nids isPrivate knownPeers = + bracket (startPeerDb nids isPrivate knownPeers) stopPeerDb -- -------------------------------------------------------------------------- -- -- Create -p2pCreateNode - :: ChainwebVersion - -> NetworkId - -> Peer - -> LogFunction - -> PeerDb - -> HTTP.Manager - -> Bool - -> P2pSession - -> IO P2pNode -p2pCreateNode cv nid peer logfun db mgr doPeerSync session = do +data P2pNodeParameters = P2pNodeParameters + { _p2pNodeParamsNetworkId :: !NetworkId + , _p2pNodeParamsMyPeerInfo :: !PeerInfo + , _p2pNodeParamsLogFunction :: !LogFunction + , _p2pNodeParamsPeerDb :: !PeerDb + , _p2pNodeParamsManager :: !HTTP.Manager + , _p2pNodeParamsDoPeerSync :: !Bool + -- ^ whether to synchronize peers on session startup + , _p2pNodeParamsIsPrivate :: !Bool + -- ^ whether the node is private + , _p2pNodeParamsMaxSessionCount :: !Natural + -- ^ Maximum Session count + , _p2pNodeParamsSessionTimeout :: !Seconds + -- ^ Session timeout + , _p2pNodeParamsSession :: !P2pSession + } + +p2pCreateNode :: HasVersion => P2pNodeParameters -> IO P2pNode +p2pCreateNode params = do -- intialize P2P State sessionsVar <- newTVarIO mempty statsVar <- newTVarIO emptyP2pNodeStats rngVar <- newIORef =<< R.newStdGen - activeVar <- newTVarIO True - let !s = P2pNode - { _p2pNodeNetworkId = nid - , _p2pNodeChainwebVersion = cv - , _p2pNodePeerInfo = myInfo - , _p2pNodePeerDb = db - , _p2pNodeSessions = sessionsVar - , _p2pNodeManager = mgr - , _p2pNodeLogFunction = logfun - , _p2pNodeStats = statsVar - , _p2pNodeClientSession = session - , _p2pNodeRng = rngVar - , _p2pNodeActive = activeVar - , _p2pNodeDoPeerSync = doPeerSync - } - - logfun @T.Text Debug "created node" - return s + activeVar <- newTVarIO False + logfun Debug "created node" + return P2pNode + { _p2pNodeNetworkId = _p2pNodeParamsNetworkId params + , _p2pNodePeerInfo = _p2pNodeParamsMyPeerInfo params + , _p2pNodePeerDb = _p2pNodeParamsPeerDb params + , _p2pNodeSessions = sessionsVar + , _p2pNodeManager = _p2pNodeParamsManager params + , _p2pNodeLogFunction = _p2pNodeParamsLogFunction params + , _p2pNodeStats = statsVar + , _p2pNodeClientSession = _p2pNodeParamsSession params + , _p2pNodeRng = rngVar + , _p2pNodeActive = activeVar + , _p2pNodeDoPeerSync = _p2pNodeParamsDoPeerSync params + , _p2pNodePrivate = _p2pNodeParamsIsPrivate params + , _p2pNodeMaxSessionCount = _p2pNodeParamsMaxSessionCount params + , _p2pNodeSessionTimeout = _p2pNodeParamsSessionTimeout params + } where - myInfo = _peerInfo peer + logfun :: LogLevel -> T.Text -> IO () + logfun = _p2pNodeParamsLogFunction params -- -------------------------------------------------------------------------- -- -- Run P2P Node -p2pStartNode :: P2pConfiguration -> P2pNode -> IO () -p2pStartNode conf node = concurrently_ - (runForever (logg node) "P2P.Node.awaitSessions" $ awaitSessions node) - (runForever (logg node) "P2P.Node.newSessions" $ newSession conf node) - -p2pStopNode :: P2P.Node.P2pNode -> IO () +p2pStartNodeInactive :: HasVersion => P2pNode -> IO () +p2pStartNodeInactive node = do + atomically (setInactive node) + concurrently_ + (runForever (logg node) "P2P.Node.awaitSessions" $ awaitSessions node) + (runForever (logg node) "P2P.Node.newSessions" $ newSession node) + +p2pStartNode :: HasVersion => P2pNode -> IO () +p2pStartNode node = do + atomically (setActive node) + concurrently_ + (runForever (logg node) "P2P.Node.awaitSessions" $ awaitSessions node) + (runForever (logg node) "P2P.Node.newSessions" $ newSession node) + +p2pStopNode :: P2pNode -> IO () p2pStopNode node = do sessions <- atomically $ do setInactive node readTVar (_p2pNodeSessions node) mapM_ (uninterruptibleCancel . snd) sessions logg node Info "stopped node" + +-- | Activate and run a node. +-- +-- The node is stopped when an asynchronoous exception is raised in the thread. +-- +p2pRunNode :: HasVersion => P2pNode -> IO () +p2pRunNode n = finally (p2pStartNode n) (p2pStopNode n) diff --git a/src/P2P/Node/PeerDB.hs b/src/P2P/Node/PeerDB.hs index af10898117..5adee8a088 100644 --- a/src/P2P/Node/PeerDB.hs +++ b/src/P2P/Node/PeerDB.hs @@ -326,35 +326,31 @@ insertPeerEntryList l m = foldl' (flip addPeerEntry) m l data PeerDb = PeerDb { _peerDbIsPrivate :: !Bool - , _peerDbChainwebVersion :: !ChainwebVersion , _peerDbLocalPeer :: !(Maybe PeerInfo) , _peerDbLock :: !(MVar ()) , _peerDbPeerSet :: !(TVar PeerSet) } deriving (Eq, Generic) -instance HasChainwebVersion PeerDb where - _chainwebVersion = _peerDbChainwebVersion - peerDbSetLocalPeer :: PeerInfo -> PeerDb -> IO PeerDb peerDbSetLocalPeer pinfo db = do peerDbDelete_ db True {- force deletion of sticky peers -} pinfo return db { _peerDbLocalPeer = Just pinfo } peerDbSnapshot :: PeerDb -> IO PeerSet -peerDbSnapshot (PeerDb _ _ _ _ var) = readTVarIO var +peerDbSnapshot (PeerDb _ _ _ var) = readTVarIO var {-# INLINE peerDbSnapshot #-} peerDbSnapshotSTM :: PeerDb -> STM PeerSet -peerDbSnapshotSTM (PeerDb _ _ _ _ var) = readTVar var +peerDbSnapshotSTM (PeerDb _ _ _ var) = readTVar var {-# INLINE peerDbSnapshotSTM #-} peerDbSize :: PeerDb -> IO Natural -peerDbSize (PeerDb _ _ _ _ var) = int . size <$!> readTVarIO var +peerDbSize (PeerDb _ _ _ var) = int . size <$!> readTVarIO var {-# INLINE peerDbSize #-} peerDbSizeSTM :: PeerDb -> STM Natural -peerDbSizeSTM (PeerDb _ _ _ _ var) = int . size <$!> readTVar var +peerDbSizeSTM (PeerDb _ _ _ var) = int . size <$!> readTVar var {-# INLINE peerDbSizeSTM #-} -- | Adds new 'PeerInfo' values for a given chain id. @@ -364,8 +360,8 @@ peerDbSizeSTM (PeerDb _ _ _ _ var) = int . size <$!> readTVar var -- contention. -- peerDbInsert :: PeerDb -> NetworkId -> PeerInfo -> IO () -peerDbInsert (PeerDb True _ _ _ _) _ _ = return () -peerDbInsert (PeerDb _ _ _ lock var) nid i = do +peerDbInsert (PeerDb True _ _ _) _ _ = return () +peerDbInsert (PeerDb _ _ lock var) nid i = do now <- getCurrentTime mark <- randomPeerMark withMVar lock @@ -378,7 +374,7 @@ peerDbInsert (PeerDb _ _ _ lock var) nid i = do -- | Delete a peer, identified by its host address, from the peer database. -- peerDbDelete :: PeerDb -> PeerInfo -> IO () -peerDbDelete (PeerDb _ _ _ lock var) i = withMVar lock +peerDbDelete (PeerDb _ _ lock var) i = withMVar lock . const . atomically . modifyTVar' var @@ -391,7 +387,7 @@ peerDbDelete_ -- ^ whether to force deletion of sticky peers (e.g. bootstrap peers) -> PeerInfo -> IO () -peerDbDelete_ (PeerDb _ _ _ lock var) forceSticky i = withMVar lock +peerDbDelete_ (PeerDb _ _ lock var) forceSticky i = withMVar lock . const . atomically . modifyTVar' var @@ -404,7 +400,7 @@ peerDbDelete_ (PeerDb _ _ _ lock var) forceSticky i = withMVar lock -- 3. have had more than 5 failed connection attempts. -- prunePeerDb :: LogFunction -> PeerDb -> IO () -prunePeerDb lg (PeerDb _ _ _ lock var) = do +prunePeerDb lg (PeerDb _ _ lock var) = do now <- getCurrentTime withMVar lock $ \_ -> do deletes <- atomically $ do @@ -423,8 +419,8 @@ prunePeerDb lg (PeerDb _ _ _ lock var) = do <> sshow (_peerAddr . _peerEntryInfo <$> IxSet.toList deletes) peerDbInsertList :: [PeerEntry] -> PeerDb -> IO () -peerDbInsertList _ (PeerDb True _ _ _ _) = return () -peerDbInsertList peers (PeerDb _ _ _ lock var) = do +peerDbInsertList _ (PeerDb True _ _ _) = return () +peerDbInsertList peers (PeerDb _ _ lock var) = do withMVar lock . const . atomically @@ -432,7 +428,7 @@ peerDbInsertList peers (PeerDb _ _ _ lock var) = do $ insertPeerEntryList peers peerDbInsertPeerInfoList :: NetworkId -> [PeerInfo] -> PeerDb -> IO () -peerDbInsertPeerInfoList _ _ (PeerDb True _ _ _ _) = return () +peerDbInsertPeerInfoList _ _ (PeerDb True _ _ _) = return () peerDbInsertPeerInfoList nid ps db = do now <- getCurrentTime entries <- traverse (mkEntry now) ps @@ -444,7 +440,7 @@ peerDbInsertPeerInfoList nid ps db = do & set peerEntryLastSuccess (LastSuccess (Just now)) peerDbInsertPeerInfoList_ :: Bool -> NetworkId -> [PeerInfo] -> PeerDb -> IO () -peerDbInsertPeerInfoList_ _ _ _ (PeerDb True _ _ _ _) = return () +peerDbInsertPeerInfoList_ _ _ _ (PeerDb True _ _ _) = return () peerDbInsertPeerInfoList_ sticky nid peerInfos db = do newEntries <- forM peerInfos $ \info -> do mark <- randomPeerMark @@ -452,17 +448,17 @@ peerDbInsertPeerInfoList_ sticky nid peerInfos db = do peerDbInsertList newEntries db peerDbInsertSet :: S.Set PeerEntry -> PeerDb -> IO () -peerDbInsertSet _ (PeerDb True _ _ _ _) = return () +peerDbInsertSet _ (PeerDb True _ _ _) = return () peerDbInsertSet s db = peerDbInsertList (F.toList s) db -newEmptyPeerDb :: ChainwebVersion -> IO PeerDb -newEmptyPeerDb v = PeerDb False v Nothing <$> newMVar () <*> newTVarIO mempty +newEmptyPeerDb :: IO PeerDb +newEmptyPeerDb = PeerDb False Nothing <$> newMVar () <*> newTVarIO mempty makePeerDbPrivate :: PeerDb -> PeerDb -makePeerDbPrivate (PeerDb _ v localPeer lock var) = PeerDb True v localPeer lock var +makePeerDbPrivate (PeerDb _ localPeer lock var) = PeerDb True localPeer lock var updatePeerDb :: PeerDb -> HostAddress -> (PeerEntry -> PeerEntry) -> IO () -updatePeerDb (PeerDb _ _ _ lock var) a f +updatePeerDb (PeerDb _ _ lock var) a f = withMVar lock . const . atomically . modifyTVar' var $ \s -> case getOne $ getEQ a s of Nothing -> s @@ -503,9 +499,9 @@ data SomePeerDb = forall v n . (KnownChainwebVersionSymbol v, SingI n) => SomePeerDb (PeerDbT v n) -somePeerDbVal :: ChainwebVersion -> NetworkId -> PeerDb -> SomePeerDb -somePeerDbVal (FromSingChainwebVersion (SChainwebVersion :: Sing v)) n db = f n - where - f (FromSingNetworkId (SChainNetwork SChainId :: Sing n)) = SomePeerDb $ PeerDbT @v @n db - f (FromSingNetworkId (SMempoolNetwork SChainId :: Sing n)) = SomePeerDb $ PeerDbT @v @n db - f (FromSingNetworkId (SCutNetwork :: Sing n)) = SomePeerDb $ PeerDbT @v @n db +somePeerDbVal :: HasVersion => NetworkId -> PeerDb -> SomePeerDb +somePeerDbVal n db = case implicitVersion of + (FromSingChainwebVersion (SChainwebVersion :: Sing v)) -> case n of + (FromSingNetworkId (SChainNetwork SChainId :: Sing n)) -> SomePeerDb $ PeerDbT @v @n db + (FromSingNetworkId (SMempoolNetwork SChainId :: Sing n)) -> SomePeerDb $ PeerDbT @v @n db + (FromSingNetworkId (SCutNetwork :: Sing n)) -> SomePeerDb $ PeerDbT @v @n db diff --git a/src/P2P/Node/RestAPI/Client.hs b/src/P2P/Node/RestAPI/Client.hs index 937601cf43..fe754aeeda 100644 --- a/src/P2P/Node/RestAPI/Client.hs +++ b/src/P2P/Node/RestAPI/Client.hs @@ -35,28 +35,28 @@ import P2P.Peer -- GET Peer Client peerGetClient - :: ChainwebVersion - -> NetworkId + :: HasVersion + => NetworkId -> Maybe Limit -> Maybe (NextItem Int) -> ClientM (Page (NextItem Int) PeerInfo) -peerGetClient (FromSingChainwebVersion (SChainwebVersion :: Sing v)) = f - where - f (FromSingNetworkId (SChainNetwork SChainId :: Sing n)) = client $ peerGetApi @v @n - f (FromSingNetworkId (SMempoolNetwork SChainId :: Sing n)) = client $ peerGetApi @v @n - f (FromSingNetworkId (SCutNetwork :: Sing n)) = client $ peerGetApi @v @n +peerGetClient nid = + case implicitVersion of + FromSingChainwebVersion (SChainwebVersion :: Sing v) -> case nid of + FromSingNetworkId (SChainNetwork SChainId :: Sing n) -> client $ peerGetApi @v @n + FromSingNetworkId (SMempoolNetwork SChainId :: Sing n) -> client $ peerGetApi @v @n + FromSingNetworkId (SCutNetwork :: Sing n) -> client $ peerGetApi @v @n -- -------------------------------------------------------------------------- -- -- PUT Peer Client peerPutClient - :: ChainwebVersion - -> NetworkId + :: HasVersion + => NetworkId -> PeerInfo -> ClientM NoContent -peerPutClient (FromSingChainwebVersion (SChainwebVersion :: Sing v)) = f - where - f (FromSingNetworkId (SChainNetwork SChainId :: Sing n)) = client $ peerPutApi @v @n - f (FromSingNetworkId (SMempoolNetwork SChainId :: Sing n)) = client $ peerPutApi @v @n - f (FromSingNetworkId (SCutNetwork :: Sing n)) = client $ peerPutApi @v @n - +peerPutClient n = case implicitVersion of + FromSingChainwebVersion (SChainwebVersion :: Sing v) -> case n of + FromSingNetworkId (SChainNetwork SChainId :: Sing n) -> client $ peerPutApi @v @n + FromSingNetworkId (SMempoolNetwork SChainId :: Sing n) -> client $ peerPutApi @v @n + FromSingNetworkId (SCutNetwork :: Sing n) -> client $ peerPutApi @v @n diff --git a/src/P2P/Node/RestAPI/Server.hs b/src/P2P/Node/RestAPI/Server.hs index 7e37e79ca1..b809b29a52 100644 --- a/src/P2P/Node/RestAPI/Server.hs +++ b/src/P2P/Node/RestAPI/Server.hs @@ -106,12 +106,12 @@ peerGetHandler db nid limit next = do (limit <|> Just defaultPeerInfoLimit) peerPutHandler - :: PeerDb - -> ChainwebVersion + :: HasVersion + => PeerDb -> NetworkId -> PeerInfo -> Handler NoContent -peerPutHandler db v nid e = liftIO (guardPeerDb v nid db e) >>= \case +peerPutHandler db nid e = liftIO (guardPeerDb nid db e) >>= \case Left failure -> throwError $ setErrText ("Invalid hostaddress: " <> sshow failure) err400 Right _ -> NoContent <$ liftIO (peerDbInsert db nid e) @@ -121,29 +121,27 @@ peerPutHandler db v nid e = liftIO (guardPeerDb v nid db e) >>= \case p2pServer :: forall (v :: ChainwebVersionT) (n :: NetworkIdT) - . SingI n + . (SingI n, HasVersion) => KnownChainwebVersionSymbol v => PeerDbT v n -> Server (P2pApi v n) p2pServer (PeerDbT db) = case sing @_ @n of SCutNetwork -> peerGetHandler db CutNetwork - :<|> peerPutHandler db v CutNetwork + :<|> peerPutHandler db CutNetwork SChainNetwork cid -> peerGetHandler db (ChainNetwork $ FromSing cid) - :<|> peerPutHandler db v (ChainNetwork $ FromSing cid) + :<|> peerPutHandler db (ChainNetwork $ FromSing cid) SMempoolNetwork cid -> peerGetHandler db (MempoolNetwork $ FromSing cid) - :<|> peerPutHandler db v (MempoolNetwork $ FromSing cid) - where - v = _chainwebVersion db + :<|> peerPutHandler db (MempoolNetwork $ FromSing cid) -- -------------------------------------------------------------------------- -- -- Application for a single P2P Network chainP2pApp :: forall v n - . KnownChainwebVersionSymbol v + . (KnownChainwebVersionSymbol v, HasVersion) => SingI n => PeerDbT v n -> Application @@ -166,30 +164,30 @@ chainP2pApiLayout _ = case sing @_ @n of -- -------------------------------------------------------------------------- -- -- Multichain Server -someP2pServer :: SomePeerDb -> SomeServer +someP2pServer :: HasVersion => SomePeerDb -> SomeServer someP2pServer (SomePeerDb (db :: PeerDbT v n)) = case sing @_ @n of SCutNetwork -> SomeServer (Proxy @(P2pApi v n)) (p2pServer db) SChainNetwork SChainId -> SomeServer (Proxy @(P2pApi v n)) (p2pServer db) SMempoolNetwork SChainId -> SomeServer (Proxy @(P2pApi v n)) (p2pServer db) -someP2pServers :: ChainwebVersion -> [(NetworkId, PeerDb)] -> SomeServer -someP2pServers v = mconcat - . fmap (someP2pServer . uncurry (somePeerDbVal v)) +someP2pServers :: HasVersion => [(NetworkId, PeerDb)] -> SomeServer +someP2pServers = mconcat + . fmap (someP2pServer . uncurry somePeerDbVal) -- -------------------------------------------------------------------------- -- -- Run Server serveP2pOnPort - :: Port - -> ChainwebVersion + :: HasVersion + => Port -> [(NetworkId, PeerDb)] -> IO () -serveP2pOnPort p v = run (int p) . someServerApplication . someP2pServers v +serveP2pOnPort p = run (int p) . someServerApplication . someP2pServers serveP2pSocket - :: Settings + :: HasVersion + => Settings -> Socket - -> ChainwebVersion -> [(NetworkId, PeerDb)] -> IO () -serveP2pSocket s sock v = runSettingsSocket s sock . someServerApplication . someP2pServers v +serveP2pSocket s sock = runSettingsSocket s sock . someServerApplication . someP2pServers diff --git a/src/P2P/TaskQueue.hs b/src/P2P/TaskQueue.hs index d7ad02dae4..8ad561e3bf 100644 --- a/src/P2P/TaskQueue.hs +++ b/src/P2P/TaskQueue.hs @@ -73,6 +73,7 @@ import Data.LogMessage import Data.PQueue import P2P.Peer +import P2P.Utils -- -------------------------------------------------------------------------- -- -- Exceptions @@ -204,8 +205,10 @@ session_ limit q logFun env = E.mask $ \restore -> do return False | otherwise -> do logg task' Warn - $ "task finally failed: " <> sshow attempts - <> ", limit: " <> sshow limit + $ "task finally failed" + <> "; attempts: " <> sshow attempts + <> "; limit: " <> sshow limit + <> "; failure: " <> displayClientError e putResult (_taskResult task') $! Left $! _taskFailures task' logg task l m = logFun @T.Text l $ sshow (_taskId task) <> ": " <> m @@ -217,3 +220,4 @@ session_ limit q logFun env = E.mask $ \restore -> do True -> return True False -> isRight <$> awaitIVar var -- note that the var won't change it's value once it is filled + diff --git a/src/P2P/Utils.hs b/src/P2P/Utils.hs new file mode 100644 index 0000000000..abb3f67cb8 --- /dev/null +++ b/src/P2P/Utils.hs @@ -0,0 +1,79 @@ +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -Wno-orphans #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- | +-- Module: P2P.Utils +-- Copyright: Copyright © 2025 Kadena LLC. +-- License: MIT +-- Maintainer: Lars Kuhtz +-- Stability: experimental +-- +module P2P.Utils +( displayClientError +, renderClientError +, clientErrorValue +, requestValue +) where + +import Chainweb.Utils +import Control.Exception.Safe +import Data.Aeson +import Data.ByteString qualified as B +import Data.ByteString.Char8 qualified as B8 +import Data.Foldable (toList) +import Data.Text qualified as T +import Data.Text.Encoding qualified as T +import Network.HTTP.Types qualified as HTTP +import Network.HTTP.Types.URI (renderQuery) +import Servant.Client +import Servant.Client.Core + +displayClientError :: SomeException -> T.Text +displayClientError e = case fromException e of + Just (c :: ClientError) -> renderClientError c + Nothing -> T.pack (displayException e) + +renderClientError :: ClientError -> T.Text +renderClientError = encodeToText . clientErrorValue + +clientErrorValue :: ClientError -> Value +clientErrorValue (FailureResponse req resp) = object + [ "type" .= String "FailureResponse" + , "request" .= requestValue req + , "code" .= HTTP.statusCode (responseStatusCode resp) + , "message" .= B8.unpack (HTTP.statusMessage (responseStatusCode resp)) + ] +clientErrorValue (DecodeFailure msg resp) = object + [ "type" .= String "DecodeFailure" + , "message" .= msg + , "code" .= HTTP.statusCode (responseStatusCode resp) + , "message" .= B8.unpack (HTTP.statusMessage (responseStatusCode resp)) + ] +clientErrorValue (UnsupportedContentType mt resp) = object + [ "type" .= String "UnsupportedContentType" + , "mediaType" .= show mt + , "code" .= HTTP.statusCode (responseStatusCode resp) + , "message" .= B8.unpack (HTTP.statusMessage (responseStatusCode resp)) + ] +clientErrorValue (InvalidContentTypeHeader resp) = object + [ "type" .= String "InvalidContentTypeHeader" + , "code" .= HTTP.statusCode (responseStatusCode resp) + , "message" .= B8.unpack (HTTP.statusMessage (responseStatusCode resp)) + ] +clientErrorValue (ConnectionError e) = object + [ "type" .= String "ConnectionError" + , "exception" .= displayException e + ] + +requestValue :: RequestF () (BaseUrl, B.ByteString) -> Value +requestValue req = String + $ T.decodeUtf8 (requestMethod req) -- this is OK, since the method is ASCII and produced locally + <> " " <> (T.pack . showBaseUrl) base + <> T.decodeUtf8 path -- this is OK, since the path is created locally + <> T.decodeUtf8 (renderQuery True (toList $ requestQueryString req)) + where + (base, path) = requestPath req + diff --git a/test/blockhistory-migration/BlockHistoryMigrationTests.hs b/test/blockhistory-migration/BlockHistoryMigrationTests.hs new file mode 100644 index 0000000000..9ed22fd66e --- /dev/null +++ b/test/blockhistory-migration/BlockHistoryMigrationTests.hs @@ -0,0 +1,114 @@ +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} + +module Main +( main +) where + +import Chainweb.BlockHash +import Chainweb.BlockHeader +import Chainweb.BlockHeaderDB +import Chainweb.Pact.Backend.ChainwebPactDb +import Chainweb.Pact.Backend.ChainwebPactDb qualified as ChainwebPactDb +import Chainweb.Pact.Backend.PactState (qryStream) +import Chainweb.Pact.Backend.Types +import Chainweb.Pact.Backend.Utils +import Chainweb.PayloadProvider.Pact.BlockHistoryMigration (migrateBlockHistoryTable) +import Chainweb.Storage.Table.RocksDB +import Chainweb.Test.Pact.Utils +import Chainweb.TreeDB (lookupRankedM) +import Chainweb.Utils.Serialization +import Chainweb.Version +import Chainweb.Version.Mainnet +import Control.Lens +import Control.Monad.IO.Class +import Control.Monad.Trans.Resource +import Streaming.Prelude qualified as S +import System.Directory +import System.Environment (lookupEnv) +import System.FilePath +import System.IO.Temp +import Test.HUnit (assertFailure) + +cid :: ChainId +cid = unsafeChainId 1 + +prepareSQLite :: SQLiteEnv -> IO () +prepareSQLite sql = throwOnDbError $ do + exec_ sql + "CREATE TABLE IF NOT EXISTS BlockHistory \ + \(blockheight UNSIGNED BIGINT NOT NULL, \ + \ endingtxid UNSIGNED BIGINT NOT NULL, \ + \ hash BLOB NOT NULL, \ + \ CONSTRAINT blockHeightConstraint UNIQUE (blockheight), \ + \ CONSTRAINT hashConstraint UNIQUE (hash));" + + liftIO $ ChainwebPactDb.initSchema sql + +requireEnv :: String -> IO String +requireEnv name = + lookupEnv name >>= maybe (fail $ name ++ " not set") pure + +main :: IO () +main = withSystemTempDirectory "sql-db" $ \dbDir -> do + logger <- getTestLogger + + -- /Volumes/Extreme Pro/db-chainweb-node-mainnet/0/sqlite/pact-v1-chain-1.sqlite + dbpath <- requireEnv "SQLITE_CHAIN1_FILEPATH" + -- /Volumes/Extreme Pro/db-chainweb-node-mainnet/0/rocksDb + rocksdbPath <- requireEnv "ROCKSDB_DIRPATH" + + copyFile dbpath (dbDir "pact-v1-chain-1.sqlite") + + sql <- startSqliteDb cid logger dbDir False + + prepareSQLite sql + n <- nTableEntries sql "BlockHistory" + n2 <- nTableEntries sql "BlockHistory2" + + assert (n > 0) "BlockHistory Table is not empty" + assert (n2 == 0) "BlockHistory2 Table is empty" + + withRocksDb rocksdbPath modernDefaultOptions $ \rocksdb -> do + withVersion Mainnet01 $ runResourceT $ do + bhdb <- withBlockHeaderDb rocksdb cid + liftIO $ do + migrateBlockHistoryTable logger cid sql bhdb False + + let qstmt = "SELECT A.blockheight, A.endingtxid, \ + \ B.hash AS b_hash, B.payloadhash AS b_payload_hash, \ + \ A.hash AS a_hash \ + \ FROM BlockHistory AS A INNER JOIN BlockHistory2 AS B \ + \ ON A.blockheight = B.blockheight AND A.endingtxid = B.endingtxid \ + \ ORDER BY A.blockheight, A.endingtxid" + rty = [RInt, RInt, RBlob, RBlob, RBlob] + + _ <- qryStream sql qstmt [] rty $ \rs -> do + rs & flip S.mapM_ $ \case + [SInt a_bh, SInt a_etxid, SBlob b_hash, SBlob b_payload, SBlob a_hash] -> do + + assert (a_hash == b_hash) $ + "Hash mismatch at block " ++ show a_bh ++ " / txid " ++ show a_etxid + + let rowBlockHeight = fromIntegral a_bh + rowBlockHash <- runGetS decodeBlockHash a_hash + blockHeader <- lookupRankedM bhdb rowBlockHeight rowBlockHash + let bph = view blockPayloadHash blockHeader + enc = runPutS $ encodeBlockPayloadHash bph + + assert (b_payload == enc) $ + "Payload Hash mismatch at block " ++ show a_bh ++ " / txid " ++ show a_etxid + r -> error $ "unexpected row shape: " ++ show r + + n2' <- nTableEntries sql "BlockHistory2" + assert (n == n2') "BlockHistory2 has the same number of rows as BlockHistory" + + where + assert p msg = + if p then pure () else Test.HUnit.assertFailure msg + + nTableEntries sql tname = throwOnDbError $ qry_ sql ("SELECT count(*) from " <> tname) [RInt] >>= \case + [[SInt n]] -> pure n + _ -> error "unexpected row shape" diff --git a/test/lib/Chainweb/Test/Cut.hs b/test/lib/Chainweb/Test/Cut.hs index e9eda13049..ce0becbf1b 100644 --- a/test/lib/Chainweb/Test/Cut.hs +++ b/test/lib/Chainweb/Test/Cut.hs @@ -14,6 +14,7 @@ {-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -Wno-orphans #-} +{-# LANGUAGE PartialTypeSignatures #-} -- | -- Module: Chainweb.Test.Cut @@ -66,12 +67,15 @@ import Control.Lens hiding ((:>), (??)) import Control.Monad hiding (join) import Control.Monad.Catch import Control.Monad.IO.Class +import Control.Monad.State.Strict import qualified Data.ByteString.Char8 as B8 import qualified Data.ByteString.Short as BS import Data.Foldable import Data.Function import qualified Data.HashMap.Strict as HM +import qualified Data.HashSet as HS +import Data.Maybe (isNothing) import Data.Monoid import Data.Ord import qualified Data.Text as T @@ -96,13 +100,15 @@ import Chainweb.ChainValue import Chainweb.Cut import Chainweb.Cut.Create import Chainweb.Graph -import Chainweb.Payload +import Chainweb.Pact.Payload +import Chainweb.Parent import Chainweb.Test.TestVersions import Chainweb.Test.Utils.BlockHeader import Chainweb.Test.Utils -import Chainweb.Time (Micros(..), Time, TimeSpan) +import Chainweb.Time (Micros(..), Time, TimeSpan, epoch) import qualified Chainweb.Time as Time (second) import Chainweb.Utils +import Chainweb.Utils.Rule import Chainweb.Utils.Serialization import Chainweb.Version import Chainweb.Version.Utils @@ -112,6 +118,7 @@ import Chainweb.Storage.Table.RocksDB import Numeric.Additive import Numeric.AffineSpace +import Chainweb.Cut.CutHashes (cutToCutHashes) -- -------------------------------------------------------------------------- -- -- Utils @@ -129,15 +136,18 @@ type GenBlockTime = Cut -> ChainId -> Time Micros -- | Block time generation that offsets from previous chain block in cut. -- -offsetBlockTime :: TimeSpan Micros -> GenBlockTime +offsetBlockTime :: HasVersion => TimeSpan Micros -> GenBlockTime offsetBlockTime offset cut cid = add offset $ maximum $ fmap (_bct . view blockCreationTime) $ HM.insert cid (cut ^?! ixg cid) - $ cutAdjs cut cid + $ HM.intersection + (cut ^. cutMap) + (HS.toMap $ adjacentChainIds (chainGraphAt (cut ^?! ixg cid . blockHeight)) cid) arbitraryBlockTimeOffset - :: TimeSpan Micros + :: HasVersion + => TimeSpan Micros -> TimeSpan Micros -> T.Gen GenBlockTime arbitraryBlockTimeOffset lower upper = do @@ -146,25 +156,16 @@ arbitraryBlockTimeOffset lower upper = do -- | Solve Work. Doesn't check that the nonce and the time are valid. -- -solveWork :: HasCallStack => WorkHeader -> Nonce -> Time Micros -> SolvedWork -solveWork w n t = - case runGetS decodeBlockHeaderWithoutHash $ BS.fromShort $ _workHeaderBytes w of - Nothing -> error "Chainwb.Test.Cut.solveWork: Invalid work header bytes" - Just hdr -> SolvedWork - $ fromJuste - $ runGetS decodeBlockHeaderWithoutHash - $ runPutS - $ encodeBlockHeaderWithoutHash - -- After injecting the nonce and the creation time will have to do a - -- serialization roundtrip to update the Merkle hash. - -- - -- A "real" miner would inject the nonce and time without first - -- decoding the header and would hand over the header in serialized - -- form. - - $ set blockCreationTime (BlockCreationTime t) - $ set blockNonce n - $ hdr +solveWork :: (HasCallStack, HasVersion) => MiningWork -> Nonce -> Time Micros -> SolvedWork +solveWork work n t = s + { _solvedWorkCreationTime = BlockCreationTime t + , _solvedWorkNonce = n + } + where + s = fromJuste + $ runGetS decodeSolvedWork + $ BS.fromShort + $ _miningWorkBytes work -- -------------------------------------------------------------------------- -- -- Test Mining @@ -185,6 +186,7 @@ instance Exception MineFailure testMine :: forall cid . HasChainId cid + => HasVersion => WebBlockHeaderDb -> Nonce -> Time Micros @@ -199,6 +201,7 @@ testMine wdb n t payloadHash i c = testMine' wdb n (\_ _ -> t) payloadHash i c testMine' :: forall cid . HasChainId cid + => HasVersion => WebBlockHeaderDb -> Nonce -> GenBlockTime @@ -215,6 +218,7 @@ testMine' wdb n t payloadHash i c = testMineWithPayloadHash :: forall cid hdb . HasChainId cid + => HasVersion => ChainValueCasLookup hdb BlockHeader => hdb -> Nonce @@ -235,6 +239,7 @@ createNewCut :: HasCallStack => MonadCatch m => HasChainId cid + => HasVersion => (ChainValue BlockHash -> m BlockHeader) -> Nonce -> Time Micros @@ -244,11 +249,13 @@ createNewCut -> m (T2 BlockHeader Cut) createNewCut hdb n t pay i c = do extension <- fromMaybeM BadAdjacents $ getCutExtension c i - work <- newWorkHeaderPure hdb (_versionForkNumber $ _chainwebVersion c) (BlockCreationTime t) extension pay - (h, mc') <- extendCut c pay (solveWork work n t) - `catch` \(InvalidSolvedHeader _ msg) -> throwM $ InvalidHeader msg + wp <- WorkParents (_cutExtensionParent extension) + <$> getAdjacentParentHeaders hdb extension + work <- newMiningWorkPure hdb (_versionForkNumber implicitVersion) (BlockCreationTime t) extension pay + (solvedHeader, mc') <- extendCut (_versionForkNumber implicitVersion) c wp (solveWork work n t) + `catch` \(InvalidSolvedHeader msg) -> throwM $ InvalidHeader msg c' <- fromMaybeM BadAdjacents mc' - return $ T2 h c' + return $ T2 solvedHeader c' -- | Create a new cut where the new block has a creation time of one second -- after its parent. @@ -258,6 +265,7 @@ createNewCut1Second . HasCallStack => MonadCatch m => HasChainId cid + => HasVersion => (ChainValue BlockHash -> m BlockHeader) -> Nonce -> BlockPayloadHash @@ -270,23 +278,23 @@ createNewCut1Second db n p i c -- -------------------------------------------------------------------------- -- -- Arbitrary Cuts -arbitraryChainId :: HasChainwebVersion v => v -> T.Gen ChainId -arbitraryChainId = T.elements . toList . chainIds +arbitraryChainId :: HasVersion => T.Gen ChainId +arbitraryChainId = T.elements $ toList chainIds arbitraryCut :: HasCallStack - => ChainwebVersion - -> T.Gen Cut -arbitraryCut v = T.sized $ \s -> do + => HasVersion + => T.Gen Cut +arbitraryCut = T.sized $ \s -> do k <- T.chooseEnum (0,s) fst <$> foldlM (\x _ -> genCut x) (genesis, initDb) [0..(k-1)] where - genesis = genesisCut v + genesis = genesisCut initDb = foldl' (\d h -> HM.insert (view blockHash h) h d) mempty $ _cutMap genesis genCut :: (Cut, TestHeaderMap) -> T.Gen (Cut, TestHeaderMap) genCut (c, db) = do - cids <- T.shuffle (toList $ chainIds v) + cids <- T.shuffle (toList chainIds) S.each cids & S.mapMaybeM (mine db c) & S.map (\(T2 h x) -> (x, HM.insert (view blockHash h) h db)) @@ -297,7 +305,7 @@ arbitraryCut v = T.sized $ \s -> do mine db c cid = do n <- Nonce <$> T.arbitrary let pay = _payloadWithOutputsPayloadHash $ testPayload - $ B8.intercalate "," [ sshow v, sshow cid, "TEST PAYLOAD"] + $ B8.intercalate "," [ sshow implicitVersion, sshow cid, "TEST PAYLOAD"] case try (createNewCut1Second (testLookup db) n pay cid c) of Left e -> throw e Right (Left BadAdjacents) -> return Nothing @@ -311,6 +319,7 @@ arbitraryChainGraphChainId = T.elements . toList . graphChainIds -- arbitraryWebChainCut :: HasCallStack + => HasVersion => WebBlockHeaderDb -> Cut -- @genesisCut Test@ is always a valid cut @@ -321,6 +330,7 @@ arbitraryWebChainCut wdb i = arbitraryWebChainCut_ wdb i 0 -- arbitraryWebChainCut_ :: HasCallStack + => HasVersion => WebBlockHeaderDb -> Cut -- @genesisCut Test@ is always a valid cut @@ -335,7 +345,7 @@ arbitraryWebChainCut_ wdb initialCut seed = do cids <- T.pick $ T.shuffle $ toList - $ chainIds initialCut + $ chainIds S.each cids & S.mapMaybeM (mine c) & S.map (\(T2 _ c') -> c') @@ -350,16 +360,12 @@ arbitraryWebChainCut_ wdb initialCut seed = do Left BadAdjacents -> return Nothing Left e -> throw e where - v = _chainwebVersion wdb pay = _payloadWithOutputsPayloadHash $ testPayload - $ B8.intercalate "," [ sshow v, sshow cid, "TEST PAYLOAD"] + $ B8.intercalate "," [ sshow (_versionName implicitVersion), sshow cid, "TEST PAYLOAD"] -- -------------------------------------------------------------------------- -- -- Arbitrary Fork -testGenCut :: WebBlockHeaderDb -> Cut -testGenCut = genesisCut . _chainwebVersion - data TestFork = TestFork { _testForkBase :: !Cut , _testForkLeft :: !Cut @@ -367,7 +373,10 @@ data TestFork = TestFork } deriving (Show, Eq, Ord, Generic) -arbitraryJoin :: WebBlockHeaderDb -> T.PropertyM IO (Join Int) +arbitraryJoin + :: HasVersion + => WebBlockHeaderDb + -> T.PropertyM IO Join arbitraryJoin wdb = do TestFork _ cl cr <- arbitraryFork wdb liftIO $ join wdb (prioritizeHeavier cl cr) cl cr @@ -377,10 +386,11 @@ arbitraryJoin wdb = do -- TODO: provide option to fork of elsewhere -- arbitraryFork - :: WebBlockHeaderDb + :: HasVersion + => WebBlockHeaderDb -> T.PropertyM IO TestFork arbitraryFork wdb = do - base <- arbitraryWebChainCut wdb (testGenCut wdb) + base <- arbitraryWebChainCut wdb genesisCut TestFork base <$> arbitraryWebChainCut_ wdb base 11 <*> arbitraryWebChainCut_ wdb base 23 @@ -408,15 +418,17 @@ arbitraryFork wdb = do -- Join prop_joinIdempotent - :: WebBlockHeaderDb + :: HasVersion + => WebBlockHeaderDb -> T.PropertyM IO Bool prop_joinIdempotent wdb = do - c <- arbitraryWebChainCut wdb (testGenCut wdb) + c <- arbitraryWebChainCut wdb genesisCut T.run $ (==) c <$> joinIntoHeavier wdb c c -- FIXME! prop_joinCommutative - :: WebBlockHeaderDb + :: HasVersion + => WebBlockHeaderDb -> T.PropertyM IO Bool prop_joinCommutative wdb = do TestFork _ cl cr <- arbitraryFork wdb @@ -427,7 +439,8 @@ prop_joinCommutative wdb = do -- Fails for heuristic joins -- prop_joinAssociative - :: WebBlockHeaderDb + :: HasVersion + => WebBlockHeaderDb -> T.PropertyM IO Bool prop_joinAssociative wdb = do TestFork _ c0 c1 <- arbitraryFork wdb @@ -449,25 +462,27 @@ prop_joinAssociative wdb = do <*> (m c0 c10 >>= \x -> m x c11) prop_joinIdentity - :: WebBlockHeaderDb + :: HasVersion + => WebBlockHeaderDb -> T.PropertyM IO Bool prop_joinIdentity wdb = do - c <- arbitraryWebChainCut wdb gen - T.run $ (==) c <$> joinIntoHeavier wdb gen c + c <- arbitraryWebChainCut wdb genesisCut + T.run $ (==) c <$> joinIntoHeavier wdb genesisCut c where - gen = testGenCut wdb -- Meet prop_meetIdempotent - :: WebBlockHeaderDb + :: HasVersion + => WebBlockHeaderDb -> T.PropertyM IO Bool prop_meetIdempotent wdb = do - c <- arbitraryWebChainCut wdb (testGenCut wdb) + c <- arbitraryWebChainCut wdb genesisCut T.run $ (==) c <$> meet wdb c c prop_meetCommutative - :: WebBlockHeaderDb + :: HasVersion + => WebBlockHeaderDb -> T.PropertyM IO Bool prop_meetCommutative wdb = do TestFork _ cl cr <- arbitraryFork wdb @@ -476,7 +491,8 @@ prop_meetCommutative wdb = do <*> meet wdb cr cl prop_meetAssociative - :: WebBlockHeaderDb + :: HasVersion + => WebBlockHeaderDb -> T.PropertyM IO Bool prop_meetAssociative wdb = do TestFork _ c0 c1 <- arbitraryFork wdb @@ -492,18 +508,19 @@ prop_meetAssociative wdb = do -- | this a corollary of 'prop_joinIdentity' and 'prop_meetJoinAbsorption' -- prop_meetZeroAbsorption - :: WebBlockHeaderDb + :: HasVersion + => WebBlockHeaderDb -> T.PropertyM IO Bool prop_meetZeroAbsorption wdb = do - c <- arbitraryWebChainCut wdb gen + c <- arbitraryWebChainCut wdb genesisCut T.run $ do - c' <- meet wdb gen c + c' <- meet wdb genesisCut c return (c == c') where - gen = testGenCut wdb prop_joinMeetAbsorption - :: WebBlockHeaderDb + :: HasVersion + => WebBlockHeaderDb -> T.PropertyM IO Bool prop_joinMeetAbsorption wdb = do TestFork _ c0 c1 <- arbitraryFork wdb @@ -512,7 +529,8 @@ prop_joinMeetAbsorption wdb = do return (c0' == c0) prop_meetJoinAbsorption - :: WebBlockHeaderDb + :: HasVersion + => WebBlockHeaderDb -> T.PropertyM IO Bool prop_meetJoinAbsorption wdb = do TestFork _ c0 c1 <- arbitraryFork wdb @@ -520,33 +538,169 @@ prop_meetJoinAbsorption wdb = do c0' <- meet wdb c0 =<< joinIntoHeavier wdb c0 c1 return (c0' == c0) -properties_lattice :: RocksDb -> ChainwebVersion -> [(String, T.Property)] -properties_lattice db v = - [ ("joinIdemPotent", ioTest db v prop_joinIdempotent) - , ("joinCommutative", ioTest db v prop_joinCommutative) - , ("joinAssociative", ioTest db v prop_joinAssociative) -- Fails - , ("joinIdentity", ioTest db v prop_joinIdentity) +properties_lattice + :: HasVersion + => RocksDb -> [(String, T.Property)] +properties_lattice db = + [ ("joinIdemPotent", ioTest db prop_joinIdempotent) + , ("joinCommutative", ioTest db prop_joinCommutative) + , ("joinAssociative", ioTest db prop_joinAssociative) -- Fails + , ("joinIdentity", ioTest db prop_joinIdentity) + + , ("meetIdemPotent", ioTest db prop_meetIdempotent) + , ("meetCommutative", ioTest db prop_meetCommutative) + , ("meetAssociative", ioTest db prop_meetAssociative) + , ("meetZeroAbsorption", ioTest db prop_meetZeroAbsorption) -- Fails + + , ("joinMeetAbsorption", ioTest db prop_joinMeetAbsorption) + , ("meetJoinAbsorption", ioTest db prop_meetJoinAbsorption) -- Fails + ] - , ("meetIdemPotent", ioTest db v prop_meetIdempotent) - , ("meetCommutative", ioTest db v prop_meetCommutative) - , ("meetAssociative", ioTest db v prop_meetAssociative) - , ("meetZeroAbsorption", ioTest db v prop_meetZeroAbsorption) -- Fails +prop_joinNoMixedTransitionalCuts :: RocksDb -> T.Property +prop_joinNoMixedTransitionalCuts baseDb = + T.monadicIO $ withVersion v $ case implicitVersion ^. versionGraphs of + (transitionHeight, transitionGraph) `Above` Bottom (_, startGraph) -> do + db' <- liftIO $ testRocksDb "Chainweb.Test.Cut" baseDb + wdb <- liftIO (initWebBlockHeaderDb db') + let startCut = genesisCut + let startCids = graphChainIds startGraph + -- to start, mine until we are one block behind the transition on + -- all chains. + preTransitionCut <- flip execStateT startCut $ + replicateM_ (int $ transitionHeight - 1) $ do + forM_ startCids $ \cid -> do + c <- get + c' <- lift $ mine wdb 0 cid c + put c' + -- then, pick a chain on which each cut will differ, and mine all + -- others into the transition. + differingChain <- T.pick $ T.oneof (return <$> toList startCids) + meetCut <- flip execStateT preTransitionCut $ + forM_ (differingChain `HS.delete` startCids) $ \cid -> do + c <- get + c' <- lift $ mine wdb 0 cid c + put c' + -- then make two cuts on top of meetCut which differ on one chain, + -- at the transition height. + oneTransitionedCut <- mine wdb 0 differingChain meetCut + otherTransitionedCut <- mine wdb 0 differingChain meetCut + -- now that both cuts are transitioned, we can mine each on one + -- extra chain. the most important case here is that the differing + -- chain is an adjacent to this chain pre-transition and not + -- post-transition. + minedChain <- T.pick + $ T.oneof + (return <$> toList + (adjacentChainIds startGraph differingChain `HS.difference` adjacentChainIds transitionGraph differingChain) + ) + oneDangerousCut <- mine wdb 0 minedChain oneTransitionedCut + let otherDangerousCut = unsafeMkCut ((otherTransitionedCut ^. cutMap) & at minedChain .~ Just (oneDangerousCut ^?! ixg minedChain)) + m <- liftIO $ joinIntoHeavier wdb + oneDangerousCut otherDangerousCut + T.assert (not $ cutMixedTransition $ cutToCutHashes Nothing m) + _ -> error "timedConsensusVersion graphs have changed" + where + v = timedConsensusVersion 0 petersenChainGraph twentyChainGraph + mine :: HasVersion => WebBlockHeaderDb -> Int -> ChainId -> Cut -> T.PropertyM IO Cut + mine wdb seed cid c = do + n' <- T.pick $ Nonce . int . (* seed) <$> T.arbitrary + delay <- pickBlind $ arbitraryBlockTimeOffset Time.second (plus Time.second Time.second) + Right (T2 _bh c') <- liftIO (testMine' wdb n' delay pay cid c) + return c' + where + pay = _payloadWithOutputsPayloadHash $ testPayload + $ B8.intercalate "," [ sshow (_versionName implicitVersion), sshow cid, "TEST PAYLOAD"] - , ("joinMeetAbsorption", ioTest db v prop_joinMeetAbsorption) - , ("meetJoinAbsorption", ioTest db v prop_meetJoinAbsorption) -- Fails - ] -properties_lattice_passing :: RocksDb -> ChainwebVersion -> [(String, T.Property)] -properties_lattice_passing db v = - [ ("joinIdemPotent", ioTest db v prop_joinIdempotent) - , ("joinCommutative", ioTest db v prop_joinCommutative) - , ("joinIdentity", ioTest db v prop_joinIdentity) +prop_extendNoMixedTransitionalCuts + :: RocksDb + -> T.Property +prop_extendNoMixedTransitionalCuts baseDb = + T.monadicIO $ withVersion v $ case implicitVersion ^. versionGraphs of + (transitionHeight, transitionGraph) `Above` Bottom (_, startGraph) -> do + db' <- liftIO $ testRocksDb "Chainweb.Test.Cut" baseDb + wdb <- liftIO (initWebBlockHeaderDb db') + let startCut = genesisCut + let startCids = graphChainIds startGraph + -- to start, mine until we are one block behind the transition on all chains. + preTransitionCut <- flip execStateT startCut $ + replicateM_ (int $ transitionHeight - 1) $ do + forM_ startCids $ \cid -> do + c <- get + Right (T2 _ c') <- lift $ mine wdb 0 cid c + put c' + -- then, pick a breakout chain which we will attempt to mine beyond + -- the transition before the rest of the chains reach the + -- transition. + -- note that in order to do this, the transition chain *must* have + -- adjacent chains post-transition that all exist pre-transition, + -- otherwise we cannot continue to mine it past the transition. + (breakoutChain, breakoutChainAdjacents) <- T.pick $ do + T.suchThat + (do + breakoutChain <- T.oneof (return <$> toList startCids) + let breakoutChainAdjacents = adjacentChainIds transitionGraph breakoutChain + return (breakoutChain, breakoutChainAdjacents) + ) + (\(_, breakoutChainAdjacents) -> + breakoutChainAdjacents `HS.isSubsetOf` graphChainIds startGraph) + -- now we set up a dangerous situation: we mine the breakout chain + -- and its adjacents to get them to the transition height. unless + -- it's prevented, the breakout chain should be able to progress + -- beyond the transition. + dangerousCut <- flip execStateT preTransitionCut $ + forM_ (breakoutChain : toList breakoutChainAdjacents) $ \cid -> do + c <- get + Right (T2 _ c') <- lift $ mine wdb 0 cid c + put c' + let adjacentBlocks = HM.mapWithKey + (\acid () -> Parent $ dangerousCut ^?! ixg acid) + (HS.toMap breakoutChainAdjacents) + (_, ext) <- T.run $ + extend (_versionForkNumber implicitVersion) dangerousCut Nothing Nothing + WorkParents + { _workParent' = Parent $ dangerousCut ^?! ixg breakoutChain + , _workAdjacentParents' = adjacentBlocks + } + SolvedWork + { _solvedAdjacentHash = + adjacentsHash $ BlockHashRecord (fmap (view blockHash) <$> adjacentBlocks) + , _solvedChainId = breakoutChain + , _solvedParentHash = Parent $ + dangerousCut ^?! ixg breakoutChain . blockHash + , _solvedPayloadHash = _payloadWithOutputsPayloadHash $ testPayload + $ B8.intercalate "," [ sshow (_versionName implicitVersion), sshow breakoutChain, "TEST PAYLOAD"] + , _solvedWorkNonce = Nonce 0 + , _solvedWorkCreationTime = BlockCreationTime epoch + } + liftIO $ deleteNamespaceRocksDb db' + -- there should be no such legal cut extension. + T.assert (isNothing ext) + _ -> error "timedConsensusVersion graphs have changed" + where + v = timedConsensusVersion 0 petersenChainGraph twentyChainGraph + mine :: HasVersion => WebBlockHeaderDb -> Int -> ChainId -> Cut -> T.PropertyM IO (Either MineFailure (T2 BlockHeader Cut)) + mine wdb seed cid c = do + n' <- T.pick $ Nonce . int . (* seed) <$> T.arbitrary + delay <- pickBlind $ arbitraryBlockTimeOffset Time.second (plus Time.second Time.second) + liftIO (testMine' wdb n' delay pay cid c) + where + pay = _payloadWithOutputsPayloadHash $ testPayload + $ B8.intercalate "," [ sshow (_versionName implicitVersion), sshow cid, "TEST PAYLOAD"] + +properties_lattice_passing + :: HasVersion + => RocksDb -> [(String, T.Property)] +properties_lattice_passing db = + [ ("joinIdemPotent", ioTest db prop_joinIdempotent) + , ("joinCommutative", ioTest db prop_joinCommutative) + , ("joinIdentity", ioTest db prop_joinIdentity) - , ("meetIdemPotent", ioTest db v prop_meetIdempotent) - , ("meetCommutative", ioTest db v prop_meetCommutative) - , ("meetAssociative", ioTest db v prop_meetAssociative) + , ("meetIdemPotent", ioTest db prop_meetIdempotent) + , ("meetCommutative", ioTest db prop_meetCommutative) + , ("meetAssociative", ioTest db prop_meetAssociative) - , ("joinMeetAbsorption", ioTest db v prop_joinMeetAbsorption) + , ("joinMeetAbsorption", ioTest db prop_joinMeetAbsorption) ] -- -------------------------------------------------------------------------- -- @@ -555,9 +709,9 @@ properties_lattice_passing db v = prop_cutBraiding :: Cut -> Bool prop_cutBraiding = either throw (const True) . checkBraidingOfCut -prop_cutBraidingGenesis :: ChainwebVersion -> Bool -prop_cutBraidingGenesis v = either throw (const True) - $ checkBraidingOfCut (genesisCut v) +prop_cutBraidingGenesis :: HasVersion => Bool +prop_cutBraidingGenesis = either throw (const True) + $ checkBraidingOfCut genesisCut -- TODO -- @@ -566,64 +720,78 @@ prop_cutBraidingGenesis v = either throw (const True) -- -- * this order induces a lattice -properties_cut :: ChainwebVersion -> [(String, T.Property)] -properties_cut v = - [ ("Cut has valid braiding" , T.property $ T.forAll (arbitraryCut v) prop_cutBraiding) - , ("Genesis Cut has valid braiding", T.property (prop_cutBraidingGenesis v)) +properties_cut :: HasVersion => [(String, T.Property)] +properties_cut = + [ ("Cut has valid braiding" , T.property $ T.forAll arbitraryCut prop_cutBraiding) + , ("Genesis Cut has valid braiding", T.property prop_cutBraidingGenesis) ] -- -------------------------------------------------------------------------- -- -- Meet Properties -prop_meetGenesisCut :: WebBlockHeaderDb -> T.PropertyM IO Bool -prop_meetGenesisCut wdb = liftIO $ (==) c <$> meet wdb c c - where - c = testGenCut wdb +prop_meetGenesisCut + :: HasVersion + => WebBlockHeaderDb -> T.PropertyM IO Bool +prop_meetGenesisCut wdb = liftIO $ + (==) genesisCut <$> meet wdb genesisCut genesisCut -- -------------------------------------------------------------------------- -- -- Misc Properties -prop_arbitraryForkBraiding :: RocksDb -> ChainwebVersion -> T.Property -prop_arbitraryForkBraiding db v = ioTest db v $ \wdb -> do +prop_arbitraryForkBraiding + :: HasVersion + => RocksDb -> T.Property +prop_arbitraryForkBraiding db = ioTest db $ \wdb -> do TestFork b cl cr <- arbitraryFork wdb T.assert (prop_cutBraiding b) T.assert (prop_cutBraiding cl) T.assert (prop_cutBraiding cr) return True -prop_joinBase :: RocksDb -> ChainwebVersion -> T.Property -prop_joinBase db v = ioTest db v $ \wdb -> do +prop_joinBase + :: HasVersion + => RocksDb -> T.Property +prop_joinBase db = ioTest db $ \wdb -> do TestFork b cl cr <- arbitraryFork wdb m <- liftIO $ join wdb (prioritizeHeavier cl cr) cl cr return (_joinBase m == b) -prop_joinBaseMeet :: RocksDb -> ChainwebVersion -> T.Property -prop_joinBaseMeet db v = ioTest db v $ \wdb -> do +prop_joinBaseMeet + :: HasVersion + => RocksDb -> T.Property +prop_joinBaseMeet db = ioTest db $ \wdb -> do TestFork _ a b <- arbitraryFork wdb liftIO $ (==) <$> meet wdb a b <*> (_joinBase <$> join wdb (prioritizeHeavier a b) a b) -properties_testMining :: RocksDb -> ChainwebVersion -> [(String, T.Property)] -properties_testMining db v = - [ ("Cuts of arbitrary fork have valid braiding", prop_arbitraryForkBraiding db v)] - -properties_miscCut :: RocksDb -> ChainwebVersion -> [(String, T.Property)] -properties_miscCut db v = - [ ("prop_joinBase", prop_joinBase db v) - , ("prop_joinBaseMeet", prop_joinBaseMeet db v) - , ("prop_meetGenesisCut", ioTest db v prop_meetGenesisCut) - , ("Cuts of arbitrary fork have valid braiding", prop_arbitraryForkBraiding db v) +properties_testMining + :: HasVersion + => RocksDb -> [(String, T.Property)] +properties_testMining db = + [ ("Cuts of arbitrary fork have valid braiding", prop_arbitraryForkBraiding db)] + +properties_miscCut + :: HasVersion + => RocksDb -> [(String, T.Property)] +properties_miscCut db = + [ ("prop_joinBase", prop_joinBase db) + , ("prop_joinBaseMeet", prop_joinBaseMeet db) + , ("prop_meetGenesisCut", ioTest db prop_meetGenesisCut) + , ("Cuts of arbitrary fork have valid braiding", prop_arbitraryForkBraiding db) + -- , ("extendNoMixedTransitionalCuts", prop_extendNoMixedTransitionalCuts db) + -- , ("joinNoMixedTransitionalCuts", prop_joinNoMixedTransitionalCuts db) ] -- -------------------------------------------------------------------------- -- -- Other Miscelaneous Properties prop_blockCountAtChainHeight :: ChainGraph -> ChainGraph -> T.Property -prop_blockCountAtChainHeight g0 g1 = T.counterexample (show v) - $ T.conjoin $ p <$> [0..10] +prop_blockCountAtChainHeight g0 g1 = + T.counterexample (show v) + $ T.conjoin $ p <$> [0..10] where - p i = T.counterexample (show i) $ int @_ @Int (globalBlockCountAt v i) T.=== h (int i) + p i = withVersion v $ T.counterexample (show i) $ int @_ @Int (globalBlockCountAt i) T.=== h (int i) h i = min 8 (i + 1) * int (order g0) + max 0 (i - 7) * int (order g1) -- (8, g1) :| [(0, g0)] @@ -650,10 +818,11 @@ properties_misc = properties :: RocksDb -> [(String, T.Property)] properties db - = properties_lattice_passing db v - <> properties_cut v - <> properties_testMining db v - <> properties_miscCut db v + = withVersion v + $ properties_lattice_passing db + <> withVersion v properties_cut + <> properties_testMining db + <> properties_miscCut db <> properties_misc where v = barebonesTestVersion pairChainGraph @@ -662,13 +831,13 @@ properties db -- TestTools ioTest - :: RocksDb - -> ChainwebVersion + :: HasVersion + => RocksDb -> (WebBlockHeaderDb -> T.PropertyM IO Bool) -> T.Property -ioTest baseDb v f = T.monadicIO $ do +ioTest baseDb f = T.monadicIO $ do db' <- liftIO $ testRocksDb "Chainweb.Test.Cut" baseDb - liftIO (initWebBlockHeaderDb db' v) >>= f >>= T.assert + liftIO (initWebBlockHeaderDb db') >>= f >>= T.assert liftIO $ deleteNamespaceRocksDb db' pickBlind :: T.Gen a -> T.PropertyM IO a diff --git a/test/lib/Chainweb/Test/Cut/TestBlockDb.hs b/test/lib/Chainweb/Test/Cut/TestBlockDb.hs index f7689e452c..ef40b30e9c 100644 --- a/test/lib/Chainweb/Test/Cut/TestBlockDb.hs +++ b/test/lib/Chainweb/Test/Cut/TestBlockDb.hs @@ -30,22 +30,23 @@ import Control.Monad.IO.Class import Control.Monad.Trans.Resource import qualified Data.HashMap.Strict as HM -import Chainweb.Block +import Chainweb.Pact.Block import Chainweb.BlockHeader import Chainweb.BlockHeaderDB import Chainweb.ChainId import Chainweb.Cut import Chainweb.Test.Utils import Chainweb.Test.Cut (GenBlockTime, testMine', MineFailure(BadAdjacents)) -import Chainweb.Payload -import Chainweb.Payload.PayloadStore -import Chainweb.Payload.PayloadStore.RocksDB +import Chainweb.Pact.Payload +import Chainweb.Pact.Payload.PayloadStore +import Chainweb.Pact.Payload.PayloadStore.RocksDB import Chainweb.Utils import Chainweb.Version import Chainweb.WebBlockHeaderDB import Chainweb.Storage.Table.RocksDB import Chainweb.BlockHeight +import Chainweb.Parent data TestBlockDb = TestBlockDb { _bdbWebBlockHeaderDb :: WebBlockHeaderDb @@ -53,18 +54,14 @@ data TestBlockDb = TestBlockDb , _bdbCut :: MVar Cut } -instance HasChainwebVersion TestBlockDb where - _chainwebVersion = _chainwebVersion . _bdbWebBlockHeaderDb - -- | Initialize TestBlockDb. -mkTestBlockDb :: ChainwebVersion -> RocksDb -> ResourceT IO TestBlockDb -mkTestBlockDb cv rdb = do +mkTestBlockDb :: HasVersion => RocksDb -> ResourceT IO TestBlockDb +mkTestBlockDb rdb = do testRdb <- withTestRocksDb "mkTestBlockDb" rdb liftIO $ do - wdb <- initWebBlockHeaderDb testRdb cv + wdb <- initWebBlockHeaderDb testRdb let pdb = newPayloadDb testRdb - initializePayloadDb cv pdb - initCut <- newMVar $ genesisCut cv + initCut <- newMVar genesisCut return $! TestBlockDb wdb pdb initCut -- | Initialize TestBlockDb in 'IO'. This is discouraged in most test environments. @@ -72,13 +69,12 @@ mkTestBlockDb cv rdb = do -- -- Take care to call 'deleteNamespaceRocksDb' on the 'RocksDb' that this returns -- in between test runs. -mkTestBlockDbIO :: ChainwebVersion -> RocksDb -> IO (T2 TestBlockDb RocksDb) -mkTestBlockDbIO v rdb = do +mkTestBlockDbIO :: HasVersion => RocksDb -> IO (T2 TestBlockDb RocksDb) +mkTestBlockDbIO rdb = do testRdb <- testRocksDb "mkTestBlockDbIO" rdb - wdb <- initWebBlockHeaderDb testRdb v + wdb <- initWebBlockHeaderDb testRdb let pdb = newPayloadDb testRdb - initializePayloadDb v pdb - initCut <- newMVar $ genesisCut v + initCut <- newMVar genesisCut return $! T2 (TestBlockDb wdb pdb initCut) testRdb -- | Add a block. @@ -87,7 +83,8 @@ mkTestBlockDbIO v rdb = do -- the chain is blocked. Retry with another chain! -- addTestBlockDb - :: TestBlockDb + :: HasVersion + => TestBlockDb -> BlockHeight -> Nonce -> GenBlockTime @@ -113,18 +110,18 @@ addTestBlockDb (TestBlockDb wdb pdb cmv) bh n gbt cid outs = do Left e -> throwM $ userError ("addTestBlockDb: " <> show e) -- | Get header for chain on current cut. -getParentTestBlockDb :: TestBlockDb -> ChainId -> IO BlockHeader +getParentTestBlockDb :: TestBlockDb -> ChainId -> IO (Parent BlockHeader) getParentTestBlockDb (TestBlockDb _ _ cmv) cid = do c <- readMVar cmv fromMaybeM (userError $ "Internal error, parent not found for cid " ++ show cid) $ - HM.lookup cid $ _cutMap c + Parent <$> HM.lookup cid (_cutMap c) -- | Get header for chain on current cut. -getParentBlockTestBlockDb :: TestBlockDb -> ChainId -> IO Block +getParentBlockTestBlockDb :: TestBlockDb -> ChainId -> IO (Parent Block) getParentBlockTestBlockDb tdb cid = do - bh <- getParentTestBlockDb tdb cid + Parent bh <- getParentTestBlockDb tdb cid pwo <- fromJuste <$> lookupPayloadWithHeight (_bdbPayloadDb tdb) (Just $ view blockHeight bh) (view blockPayloadHash bh) - return Block + return $ Parent Block { _blockHeader = bh , _blockPayloadWithOutputs = pwo } @@ -136,6 +133,6 @@ setCutTestBlockDb :: TestBlockDb -> Cut -> IO () setCutTestBlockDb (TestBlockDb _ _ cmv) c = void $ swapMVar cmv c -- | Convenience accessor -getBlockHeaderDb :: MonadThrow m => ChainId -> TestBlockDb -> m BlockHeaderDb +getBlockHeaderDb :: HasVersion => MonadThrow m => ChainId -> TestBlockDb -> m BlockHeaderDb getBlockHeaderDb cid (TestBlockDb wdb _ _) = getWebBlockHeaderDb wdb cid diff --git a/test/lib/Chainweb/Test/MultiNode.hs b/test/lib/Chainweb/Test/MultiNode.hs index 5c77e78034..ed050ee7a4 100644 --- a/test/lib/Chainweb/Test/MultiNode.hs +++ b/test/lib/Chainweb/Test/MultiNode.hs @@ -37,103 +37,89 @@ -- similulate a full-scale chain in a miniaturized settings. -- module Chainweb.Test.MultiNode - ( efficiencyTest - , forkVoteTestSucceedUnanimous - , forkVoteTestSucceedTwiceUnanimous - , forkVoteTestFailUnanimous - , forkVoteTestSucceedFourFifths - , forkVoteTestFailFourFifths + ( test , replayTest - , compactAndResumeTest +-- TODO: PP +-- , compactAndResumeTest , pactImportTest - , compactLiveNodeTest +-- TODO: PP +-- , compactLiveNodeTest ) where import Control.Concurrent -import Control.Concurrent.Async -import Control.Concurrent.STM -import Control.DeepSeq -import Control.Exception -import Control.Lens -import Control.Monad -import Chronos qualified - -import Patience.Map qualified as Patience -import Data.ByteString.Base16 qualified as Base16 -import Chainweb.Pact.Backend.PactState.EmbeddedSnapshot (Snapshot(..)) -import Data.Aeson (ToJSON) -import Data.Foldable -import Data.Hashable -import qualified Data.HashMap.Strict as HM -import qualified Data.HashSet as HS -import Data.IORef -import qualified Data.List as L -import Data.Set (Set) -import qualified Data.Set as Set -import qualified Data.Text as T -import Data.Text (Text) -import qualified Data.Text.Encoding as T -import Data.ByteString (ByteString) -import qualified Pact.JSON.Encode as J - -import GHC.Generics - -import Numeric.Natural - -import qualified Streaming.Prelude as S -import Prelude hiding (log) - -import System.Directory (createDirectoryIfMissing) -import System.FilePath -import System.IO.Temp -import System.LogLevel -import System.Timeout - -import Test.Tasty.HUnit - -import PropertyMatchers qualified as P - --- internal modules - import Chainweb.BlockHash import Chainweb.BlockHeader +import Chainweb.BlockHeader.Genesis.InstantTimedCPM0Payload qualified as IN0 +import Chainweb.BlockHeader.Genesis.InstantTimedCPM1to9Payload qualified as INN import Chainweb.BlockHeight +import Chainweb.ChainId import Chainweb.Chainweb import Chainweb.Chainweb.Configuration import Chainweb.Chainweb.CutResources import Chainweb.Chainweb.PeerResources -import Chainweb.ForkState -import Chainweb.Pact.Backend.Compaction qualified as Sigma -import Chainweb.Pact.Backend.Utils (withSqliteDb) import Chainweb.Cut +import Chainweb.Cut.CutHashes import Chainweb.CutDB import Chainweb.Graph import Chainweb.Logger import Chainweb.Miner.Config import Chainweb.Miner.Pact import Chainweb.Pact.Backend.PactState (allChains, getLatestBlockHeight, getLatestPactStateAtDiffable, TableDiffable(..), addChainIdLabel) +import Chainweb.Pact.Backend.PactState.EmbeddedSnapshot (Snapshot(..)) import Chainweb.Pact.Backend.PactState.GrandHash.Algorithm (ChainGrandHash(..)) import Chainweb.Pact.Backend.PactState.GrandHash.Calc qualified as GrandHash.Calc import Chainweb.Pact.Backend.PactState.GrandHash.Import qualified as GrandHash.Import import Chainweb.Pact.Backend.PactState.GrandHash.Utils qualified as GrandHash.Utils +import Chainweb.PayloadProvider.Pact.Configuration (defaultPactProviderConfig, PactProviderConfig (_pactConfigGenesisPayload), _pactConfigMiner) +import Chainweb.Scheduler (Scheduler, withScheduler) +import Chainweb.Storage.Table (IterableTable(withTableIterator), Casify) +import Chainweb.Storage.Table.RocksDB import Chainweb.Test.P2P.Peer.BootstrapConfig -import Chainweb.Test.Pact4.Utils (sigmaCompact) -import Chainweb.Test.TestVersions import Chainweb.Test.Utils -import Chainweb.Time (Seconds(..)) +import Chainweb.Time (Seconds(..), Time(..), TimeSpan(..), getCurrentTimeIntegral) import Chainweb.Utils import Chainweb.Version import Chainweb.Version.Utils import Chainweb.WebBlockHeaderDB - -import Chainweb.Storage.Table.RocksDB - -import P2P.Node.Configuration -import P2P.Peer - -import Database.SQLite3.Direct (Database) +import Control.Concurrent.Async +import Control.DeepSeq +import Control.Exception +import Control.Lens (set, view, (^?!), ix) +import Control.Monad +import Control.Monad.IO.Class (liftIO) +import Control.Monad.Trans.Resource (runResourceT) +import Data.Aeson (ToJSON, Value, object, (.=)) +import Data.ByteString (ByteString) +import Data.ByteString.Base16 qualified as Base16 +import Data.Foldable +import Data.Function +import Data.HashMap.Strict qualified as HM +import Data.HashSet qualified as HS +import Data.Hashable +import Data.IORef +import Data.List qualified as L import Data.Map (Map) import Data.Map.Strict qualified as Map +import Data.Set (Set) +import Data.Set qualified as Set +import Data.Text (Text) +import Data.Text qualified as T +import Data.Text.Encoding qualified as T +import Data.Text.IO qualified as T +import Database.SQLite3.Direct (Database) +import GHC.Generics +import Numeric.Natural +import P2P.Node.Configuration +import P2P.Peer +import Pact.JSON.Encode qualified as J +import Patience.Map qualified as Patience +import Prelude hiding (log) +import Streaming.Prelude qualified as S +import System.FilePath +import System.IO.Temp +import System.LogLevel +import System.Timeout +import Test.Tasty.HUnit -- | Integer node identifier; node 0 is the bootstrap. newtype NodeId = NodeId Int @@ -161,13 +147,14 @@ instance HasTextRepresentation NodeId where -- | Test Configuration for a scaled down Test chainweb. -- multiConfig - :: Int - -- ^ number of nodes - -> (ChainwebConfiguration -> ChainwebConfiguration) -multiConfig n = - set (configP2p . p2pConfigPeer . peerConfigHost) host - . set (configP2p . p2pConfigPeer . peerConfigPort) 0 - . set (configP2p . p2pConfigPeer . peerConfigInterface) interface + :: HasVersion + => Natural + -- ^ number of node + -> ChainwebConfiguration +multiConfig n = defaultChainwebConfiguration implicitVersion + & set (configP2p . p2pConfigPeer . peerConfigHost) host + & set (configP2p . p2pConfigPeer . peerConfigPort) 0 + & set (configP2p . p2pConfigPeer . peerConfigInterface) interface -- Only listen on the loopback device. On Mac OS X this prevents the -- firewall dialog form poping up. @@ -193,20 +180,26 @@ multiConfig n = . set (configMining . miningCoordination . coordinationEnabled) True . set (configMining . miningInNode) miner - . set configReintroTxs True - -- enable transaction re-introduction - - . set configThrottling throttling + & set configThrottling throttling -- throttling is effectively disabled to not slow down the test nodes - . set (configServiceApi . serviceApiConfigPort) 0 - . set (configServiceApi . serviceApiConfigInterface) interface - . set (configCuts . cutFetchTimeout) 10_000_000 + & set (configServiceApi . serviceApiConfigPort) 0 + & set (configServiceApi . serviceApiConfigInterface) interface + & set (configCuts . cutFetchTimeout) 10_000_000 + & set (configPayloadProviders . payloadProviderConfigPact) + (onChains $ + [(cid, defaultPactProviderConfig + { _pactConfigGenesisPayload = Just gp + , _pactConfigMiner = Just noMiner + }) + | (cid, gp) <- + (unsafeChainId 0, IN0.payloadBlock) + : [(unsafeChainId cid, INN.payloadBlock) | cid <- [1..19]] + ]) where miner = NodeMiningConfig { _nodeMiningEnabled = True - , _nodeMiner = noMiner - , _nodeTestMiners = MinerCount (int n) + , _nodeTestMiners = MinerCount n } throttling = defaultThrottlingConfig @@ -214,6 +207,9 @@ multiConfig n = , _throttlingPeerRate = 10_000 -- per second, one for each p2p network } +multiConfigBuilders :: HasVersion => Natural -> [ChainwebConfiguration -> ChainwebConfiguration] +multiConfigBuilders n = replicate (int n) $ const (multiConfig n) + -- | Configure a bootstrap node -- multiBootstrapConfig @@ -223,7 +219,7 @@ multiBootstrapConfig conf = conf & set (configP2p . p2pConfigPeer) peerConfig & set (configP2p . p2pConfigKnownPeers) [] where - peerConfig = (head $ testBootstrapPeerConfig $ _configChainwebVersion conf) + peerConfig = head (testBootstrapPeerConfig $ _configChainwebVersion conf) & set peerConfigPort 0 -- Normally, the port of bootstrap nodes is hard-coded. But in -- test-suites that may run concurrently we want to use a port that is @@ -236,46 +232,61 @@ multiBootstrapConfig conf = conf -- Minimal Node Setup that logs conensus state to the given mvar harvestConsensusState - :: GenericLogger + :: HasVersion + => GenericLogger -> MVar ConsensusState -> NodeId -> StartedChainweb logger + -> RocksDb -> IO () -harvestConsensusState _ _ _ (Replayed _ _) = +harvestConsensusState _ _ _ (RewoundToCut _) _ = error "harvestConsensusState: doesn't work when replaying, replays don't do consensus" -harvestConsensusState logger stateVar nid (StartedChainweb cw) = do +harvestConsensusState logger stateVar nid (StartedChainweb cw) rdb = do + sampler <- forkIO $ do + let cutdb = view (chainwebCutResources . cutResCutDb) cw + forever $ do + threadDelay 100_000 + c <- _cut cutdb + Time (TimeSpan us) <- getCurrentTimeIntegral + let t = int us / 1_000_000 :: Double + modifyMVar_ stateVar $ \s -> return $! s + { _stateCutTrace = HM.insertWith (\new old -> old <> new) nid [(t, _cutHeight c)] (_stateCutTrace s) + } runChainweb cw (\_ -> return ()) `finally` do + killThread sampler logFunctionText logger Info "write sample data" modifyMVar_ stateVar $ sampleConsensusState nid - (view (chainwebCutResources . cutsCutDb . cutDbWebBlockHeaderDb) cw) - (view (chainwebCutResources . cutsCutDb) cw) + (view (chainwebCutResources . cutResCutDb . cutDbWebBlockHeaderDb) cw) + (view (chainwebCutResources . cutResCutDb) cw) + (cutHashesTable rdb) + logFunctionText logger Info "assert on cut count" logFunctionText logger Info "shutdown node" multiNode :: LogLevel - -> (T.Text -> IO ()) -> MVar PeerInfo -> ChainwebConfiguration + -> Scheduler -> RocksDb -> FilePath -> NodeId -- ^ Unique node id. Node id 0 is used for the bootstrap node - -> (forall logger. NodeId -> StartedChainweb logger -> IO ()) + -> (forall logger. NodeId -> StartedChainweb logger -> RocksDb -> IO ()) -> IO () -multiNode loglevel write bootstrapPeerInfoVar conf rdb pactDbDir nid inner = do +multiNode loglevel bootstrapPeerInfoVar conf sched rdb pactDbDir nid inner = do withSystemTempDirectory "multiNode-backup-dir" $ \backupTmpDir -> - withChainweb conf logger namespacedNodeRocksDb (pactDbDir show nid) backupTmpDir False $ \cw -> do - case cw of - StartedChainweb cw' -> - when (nid == bootstrapNodeId) $ putMVar bootstrapPeerInfoVar - $ view (chainwebPeer . peerResPeer . peerInfo) cw' - Replayed _ _ -> return () - inner nid cw + withChainweb conf logger sched namespacedNodeRocksDb (pactDbDir show nid) backupTmpDir $ \cw -> do + case cw of + StartedChainweb cw' -> + when (nid == bootstrapNodeId) $ putMVar bootstrapPeerInfoVar + $ view (chainwebPeer . peerResPeer . peerInfo) cw' + RewoundToCut _ -> return () + inner nid cw namespacedNodeRocksDb where logger :: GenericLogger - logger = addLabel ("node", toText nid) $ genericLogger loglevel write + logger = addLabel ("node", toText nid) $ genericLogger loglevel T.putStrLn namespacedNodeRocksDb = rdb { _rocksDbNamespace = T.encodeUtf8 $ toText nid } @@ -290,24 +301,25 @@ runNodes -- ^ number of nodes -> RocksDb -> FilePath - -> (forall logger. NodeId -> StartedChainweb logger -> IO ()) + -> (forall logger. NodeId -> StartedChainweb logger -> RocksDb -> IO ()) -> IO () -runNodes loglevel write v confBuilders rdb pactDbDir inner = do +runNodes loglevel write v confBuilders rdb pactDbDir inner = runResourceT $ do -- NOTE: pact is enabled until we have a good way to disable it globally in -- "Chainweb.Chainweb". -- -- TODO: disable pact for these tests -- - bootstrapPortVar <- newEmptyMVar + sched <- withScheduler (logFunctionText $ genericLogger loglevel write) 2 + bootstrapPortVar <- liftIO newEmptyMVar -- this is a hack for testing: normally bootstrap node peer infos are -- hardcoded. To avoid conflicts in concurrent test runs we extract an -- OS assigned port from the bootstrap node during startup and inject it -- into the configuration of the remaining nodes. let baseConf = defaultChainwebConfiguration v - forConcurrently_ (zip [0..] confBuilders) $ \(i, confBuilder) -> do - threadDelay (500_000 * int i) + liftIO $ forConcurrently_ (zip [0..] confBuilders) $ \(i, confBuilder) -> do + threadDelay (100_000 * int i) conf <- if | i == 0 -> @@ -315,7 +327,7 @@ runNodes loglevel write v confBuilders rdb pactDbDir inner = do | otherwise -> setBootstrapPeerInfo <$> readMVar bootstrapPortVar <*> pure baseConf - multiNode loglevel write bootstrapPortVar (confBuilder conf) rdb pactDbDir (NodeId i) inner + multiNode loglevel bootstrapPortVar (confBuilder conf) sched rdb pactDbDir (NodeId i) inner runNodesForSeconds :: LogLevel @@ -328,76 +340,77 @@ runNodesForSeconds -- ^ test duration in seconds -> RocksDb -> FilePath - -> (forall logger. NodeId -> StartedChainweb logger -> IO ()) + -> (forall logger. NodeId -> StartedChainweb logger -> RocksDb -> IO ()) -> IO () runNodesForSeconds loglevel write v confBuilders (Seconds seconds) rdb pactDbDir inner = do void $ timeout (int seconds * 1_000_000) $ runNodes loglevel write v confBuilders rdb pactDbDir inner --- | Ensure that we can compact a live node(s). --- --- This test works like so: --- 1. Run a number of chainweb nodes in a network for 10 seconds. --- 2. Ensure that the nodes made sufficient progress. --- 3. Run two threads: --- - The first runs all of the nodes for 60 seconds. --- - The second compacts all of the nodes, after sleeping for 5 seconds. --- 4. At the end we compare how long each thread took. The node thread should --- outlive the compaction thread. -compactLiveNodeTest :: () - => LogLevel - -> ChainwebVersion - -> Int - -> RocksDb - -> FilePath - -> FilePath - -> (String -> IO ()) - -> IO () -compactLiveNodeTest logLevel v n rocksDb srcPactDir targetPactDir step = do - let logFun = step . T.unpack - let logger = genericLogger logLevel logFun - - logFun "Phase 1... creating blocks" - - -- N.B: This consensus state stuff counts the number of blocks - -- in RocksDB, rather than the number of blocks in all chains - -- on the current cut. This is fine because we ultimately just want - -- to make sure that we are making progress (i.e, new blocks). - stateVar <- newMVar (emptyConsensusState v) - let ct :: NodeId -> StartedChainweb logger -> IO () - ct = harvestConsensusState logger stateVar - do - runNodesForSeconds logLevel logFun v (replicate n $ multiConfig n) 10 rocksDb srcPactDir ct - Just stats1 <- consensusStateSummary <$> swapMVar stateVar (emptyConsensusState v) - assertGe "average block count before proceeding" (Actual $ _statBlockCount stats1) (Expected 50) - logFun $ sshow stats1 - - let compactAll = Chronos.stopwatch_ $ do - threadDelay 5_000_000 - Sigma.withDefaultLogger logLevel $ \lgr -> do - forM_ [0 .. int @_ @Word n - 1] $ \nid -> do - -- We haven't gotten to run the node against the target yet, - -- and nothing has created its db directories, so we do that here. - createDirectoryIfMissing False (targetPactDir show nid) - forM_ (allChains v) $ \cid -> do - let logger' = addLabel ("nodeId", sshow nid) $ addLabel ("chainId", chainIdToText cid) lgr - withSqliteDb cid logger' (srcPactDir show nid) False $ \srcDb -> do - withSqliteDb cid logger' (targetPactDir show nid) False $ \targetDb -> do - sigmaCompact srcDb targetDb (BlockHeight 25) - - let run = Chronos.stopwatch_ $ do - -- It may seem a bit strange that we never run the node against the - -- compacted state (see that we are using 'srcPactDir' here). This is - -- because we are only trying to see that compacting a node as it is, - -- does not disrupt it. - runNodesForSeconds logLevel logFun v (replicate n $ multiConfig n) 60 rocksDb srcPactDir ct - Just stats2 <- consensusStateSummary <$> swapMVar stateVar (emptyConsensusState v) - assertGe "average block count before proceeding" (Actual $ _statBlockCount stats2) (Expected 100) - logFun $ sshow stats2 - - (compactTime, nodeTime) <- concurrently compactAll run - - assertGe "node runs beyond compaction" (Actual nodeTime) (Expected compactTime) +-- TODO: PP +-- -- | Ensure that we can compact a live node(s). +-- -- +-- -- This test works like so: +-- -- 1. Run a number of chainweb nodes in a network for 10 seconds. +-- -- 2. Ensure that the nodes made sufficient progress. +-- -- 3. Run two threads: +-- -- - The first runs all of the nodes for 60 seconds. +-- -- - The second compacts all of the nodes, after sleeping for 5 seconds. +-- -- 4. At the end we compare how long each thread took. The node thread should +-- -- outlive the compaction thread. +-- compactLiveNodeTest :: () +-- => HasVersion +-- => LogLevel +-- -> Natural +-- -> RocksDb +-- -> FilePath +-- -> FilePath +-- -> (String -> IO ()) +-- -> IO () +-- compactLiveNodeTest logLevel n rocksDb srcPactDir targetPactDir step = do +-- let logFun = step . T.unpack +-- let logger = genericLogger logLevel logFun + +-- logFun "Phase 1... creating blocks" + +-- -- N.B: This consensus state stuff counts the number of blocks +-- -- in RocksDB, rather than the number of blocks in all chains +-- -- on the current cut. This is fine because we ultimately just want +-- -- to make sure that we are making progress (i.e, new blocks). +-- stateVar <- newMVar emptyConsensusState +-- let ct :: Int -> StartedChainweb logger -> IO () +-- ct = harvestConsensusState logger stateVar +-- do +-- runNodesForSeconds logLevel logFun (multiConfig n) n 10 rocksDb srcPactDir ct +-- Just stats1 <- consensusStateSummary <$> swapMVar stateVar emptyConsensusState +-- assertGe "average block count before proceeding" (Actual $ _statBlockCount stats1) (Expected 50) +-- logFun $ sshow stats1 + +-- let compactAll = Chronos.stopwatch_ $ do +-- threadDelay 5_000_000 +-- Sigma.withDefaultLogger logLevel $ \lgr -> do +-- forM_ [0 .. int @_ @Word n - 1] $ \nid -> do +-- -- We haven't gotten to run the node against the target yet, +-- -- and nothing has created its db directories, so we do that here. +-- createDirectoryIfMissing False (targetPactDir show nid) +-- forM_ (allChains v) $ \cid -> do +-- let logger' = addLabel ("nodeId", sshow nid) $ addLabel ("chainId", chainIdToText cid) lgr +-- withSqliteDb cid logger' (srcPactDir show nid) False $ \srcDb -> do +-- withSqliteDb cid logger' (targetPactDir show nid) False $ \targetDb -> do +-- sigmaCompact srcDb targetDb (BlockHeight 25) + +-- let run = Chronos.stopwatch_ $ do +-- -- It may seem a bit strange that we never run the node against the +-- -- compacted state (see that we are using 'srcPactDir' here). This is +-- -- because we are only trying to see that compacting a node as it is, +-- -- does not disrupt it. +-- runNodesForSeconds logLevel logFun (multiConfig n) n 60 rocksDb srcPactDir ct +-- Just stats2 <- consensusStateSummary <$> swapMVar stateVar emptyConsensusState +-- assertGe "average block count before proceeding" (Actual $ _statBlockCount stats2) (Expected 100) +-- logFun $ sshow stats2 + +-- (compactTime, nodeTime) <- concurrently compactAll run + +-- assertGe "node runs beyond compaction" (Actual nodeTime) (Expected compactTime) -- | This test is essentially just calling pact-calc followed by pact-import, -- and making sure that works end to end. @@ -417,14 +430,14 @@ compactLiveNodeTest logLevel v n rocksDb srcPactDir targetPactDir step = do -- 6. Lastly, we compare the state between the two databases (original and -- copy) at the verified 'BlockHeight'. There should be no differences. pactImportTest :: () + => HasVersion => LogLevel - -> ChainwebVersion - -> Int + -> Natural -> RocksDb -> FilePath -> (String -> IO ()) -> IO () -pactImportTest logLevel v n rocksDb pactDir step = do +pactImportTest logLevel n rocksDb pactDir step = do let logFun = step . T.unpack let logger = genericLogger logLevel logFun @@ -435,16 +448,16 @@ pactImportTest logLevel v n rocksDb pactDir step = do -- in RocksDB, rather than the number of blocks in all chains -- on the current cut. This is fine because we ultimately just want -- to make sure that we are making progress (i.e, new blocks). - stateVar <- newMVar (emptyConsensusState v) - let ct :: NodeId -> StartedChainweb logger -> IO () + stateVar <- newMVar emptyConsensusState + let ct :: NodeId -> StartedChainweb logger -> RocksDb -> IO () ct = harvestConsensusState logger stateVar - runNodesForSeconds logLevel logFun v (replicate n $ multiConfig n) 10 rocksDb pactDir ct - consensusState <- swapMVar stateVar (emptyConsensusState v) + runNodesForSeconds logLevel logFun implicitVersion (multiConfigBuilders n) 10 rocksDb pactDir ct + consensusState <- swapMVar stateVar emptyConsensusState Just stats1 <- pure $ consensusStateSummary consensusState assertGe "average block count before proceeding" (Actual $ _statBlockCount stats1) (Expected 50) logFun $ sshow stats1 - let chains = allChains v + let chains = allChains forM_ [0 .. int @_ @Word n - 1] $ \nid -> do let logger' = addLabel ("nodeId", sshow nid) logger logFunctionText logger' Info $ "Verifying node " <> sshow nid @@ -456,8 +469,8 @@ pactImportTest logLevel v n rocksDb pactDir step = do let rdb = rocksDb { _rocksDbNamespace = T.encodeUtf8 $ toText @Word nid } latestBlockHeight <- do - wbhdb <- initWebBlockHeaderDb rdb v - latestCutHeaders <- readHighestCutHeaders' v (\_ _ -> pure ()) wbhdb (cutHashesTable rdb) + wbhdb <- initWebBlockHeaderDb rdb + latestCutHeaders <- readHighestCutHeaders (\_ _ -> pure ()) wbhdb (cutHashesTable rdb) pure $ maximum $ fmap (view blockHeight) latestCutHeaders let targetChunkSize :: BlockHeight @@ -471,17 +484,17 @@ pactImportTest logLevel v n rocksDb pactDir step = do (\t -> if t >= targetChunkSize then Just (t, t - targetChunkSize) else Nothing) (latestBlockHeight - latestBlockHeight `mod` targetChunkSize) - grands <- GrandHash.Calc.pactCalc logger' v pactConns rdb (GrandHash.Calc.TargetAll targets) + grands <- GrandHash.Calc.pactCalc logger' pactConns rdb (GrandHash.Calc.TargetAll targets) logFunctionText logger' Info "Verifying state" - snapshot@(snapshotBlockHeight, snapshotHashes) <- GrandHash.Import.pactVerify logger' v pactConns rdb grands + snapshot@(snapshotBlockHeight, snapshotHashes) <- GrandHash.Import.pactVerify logger' pactConns rdb grands logFunctionText logger' Debug $ "SNAPSHOT BLOCKHEIGHT = " <> sshow (fst snapshot) logFunctionText logger' Debug $ "SNAPSHOT HASHES = " <> sshow (HM.map (\s -> (T.decodeUtf8 (Base16.encode (getChainGrandHash s.pactHash)), view blockHeight s.blockHeader)) (snd snapshot)) logFunctionText logger' Info "Making a copy of the pact state, and dropping the post-verified content" withSystemTempDirectory "pact-copy" $ \copyPactDir -> do let copyNodeDir = copyPactDir show nid - GrandHash.Import.pactDropPostVerified logger' v pactNodeDir copyNodeDir snapshotBlockHeight snapshotHashes + GrandHash.Import.pactDropPostVerified logger' pactNodeDir copyNodeDir snapshotBlockHeight snapshotHashes GrandHash.Utils.withConnections logger' copyNodeDir chains $ \pactCopyConns -> do logFunctionText logger' Info "Checking latest block heights on copy to make sure they match verified state" @@ -503,7 +516,7 @@ pactImportTest logLevel v n rocksDb pactDir step = do let db = pactCopyConns ^?! ix cid getPactStateAtDiffable db snapshotBlockHeight let stateDiff = Map.filter (not . Patience.isSame) (Patience.diff srcStateAt tgtStateAt) - when (not (null stateDiff)) $ do + unless (null stateDiff) $ do forM_ (Map.toList stateDiff) $ \(tbl, delta) -> do case delta of Patience.Same _ -> do @@ -525,184 +538,153 @@ pactImportTest logLevel v n rocksDb pactDir step = do log Error $ "In table " <> tbl <> ", there was a difference in rowdata at rowkey " <> T.decodeUtf8 x <> "." assertFailure "Diff failed" --- | Run nodes --- Each node creates blocks --- We wait until they've made a sufficient amount of blocks --- We stop the nodes --- We compact the databases of each node --- We restart all nodes with the same database dirs --- We observe that they can make progress -compactAndResumeTest :: () - => LogLevel - -> ChainwebVersion - -> Int - -> RocksDb - -> RocksDb - -> FilePath - -> FilePath - -> (String -> IO ()) - -> IO () -compactAndResumeTest logLevel v n srcRocksDb targetRocksDb srcPactDir targetPactDir step = do - let logFun = step . T.unpack - let logger = genericLogger logLevel logFun - - logFun "phase 1... creating blocks" - -- N.B: This consensus state stuff counts the number of blocks - -- in RocksDB, rather than the number of blocks in all chains - -- on the current cut. This is fine because we ultimately just want - -- to make sure that we are making progress (i.e, new blocks). - stateVar <- newMVar (emptyConsensusState v) - let ct :: NodeId -> StartedChainweb logger -> IO () - ct = harvestConsensusState logger stateVar - runNodesForSeconds logLevel logFun v (replicate n $ multiConfig n) 10 srcRocksDb srcPactDir ct - Just stats1 <- consensusStateSummary <$> swapMVar stateVar (emptyConsensusState v) - assertGe "average block count before compaction" (Actual $ _statBlockCount stats1) (Expected 50) - logFun $ sshow stats1 - - logFun "phase 2... compacting" - - logFun "phase 2.1...compacting pact state" - forM_ [0 .. int @_ @Word n - 1] $ \nid -> do - forM_ (allChains v) $ \cid -> do - let logger' = addLabel ("nodeId", sshow nid) $ addLabel ("chainId", chainIdToText cid) logger - withSqliteDb cid logger' (srcPactDir show nid) False $ \srcDb -> do - withSqliteDb cid logger' (targetPactDir show nid) False $ \targetDb -> do - sigmaCompact srcDb targetDb (BlockHeight 25) - - logFun "phase 2.2...compacting RocksDB" - forM_ [0 .. int @_ @Word n - 1] $ \nid -> do - let srcRdb = srcRocksDb { _rocksDbNamespace = T.encodeUtf8 (toText nid) } - let tgtRdb = targetRocksDb { _rocksDbNamespace = T.encodeUtf8 (toText nid) } - Sigma.doCompactRocksDb (addLabel ("nodeId", sshow nid) logger) v (allChains v) 25 srcRdb tgtRdb - - logFun "phase 3... restarting nodes and ensuring progress" - runNodesForSeconds logLevel logFun v - (replicate n $ - multiConfig n - & mapped . configFullHistoricPactState .~ False) - 10 targetRocksDb targetPactDir ct - Just stats2 <- consensusStateSummary <$> swapMVar stateVar (emptyConsensusState v) - -- We ensure that we've gotten to at least 1.5x the previous block count - assertGe "average block count post-compaction" (Actual $ _statBlockCount stats2) (Expected (3 * _statBlockCount stats1 `div` 2)) - logFun $ sshow stats2 +-- TODO: PP +-- -- | Run nodes +-- -- Each node creates blocks +-- -- We wait until they've made a sufficient amount of blocks +-- -- We stop the nodes +-- -- We compact the databases of each node +-- -- We restart all nodes with the same database dirs +-- -- We observe that they can make progress +-- compactAndResumeTest :: () +-- => HasVersion +-- => LogLevel +-- -> Natural +-- -> RocksDb +-- -> RocksDb +-- -> FilePath +-- -> FilePath +-- -> (String -> IO ()) +-- -> IO () +-- compactAndResumeTest logLevel n srcRocksDb targetRocksDb srcPactDir targetPactDir step = do +-- let logFun = step . T.unpack +-- let logger = genericLogger logLevel logFun + +-- logFun "phase 1... creating blocks" +-- -- N.B: This consensus state stuff counts the number of blocks +-- -- in RocksDB, rather than the number of blocks in all chains +-- -- on the current cut. This is fine because we ultimately just want +-- -- to make sure that we are making progress (i.e, new blocks). +-- stateVar <- newMVar emptyConsensusState +-- let ct :: Int -> StartedChainweb logger -> IO () +-- ct = harvestConsensusState logger stateVar +-- runNodesForSeconds logLevel logFun (multiConfig n) n 10 srcRocksDb srcPactDir ct +-- Just stats1 <- consensusStateSummary <$> swapMVar stateVar emptyConsensusState +-- assertGe "average block count before compaction" (Actual $ _statBlockCount stats1) (Expected 50) +-- logFun $ sshow stats1 + +-- logFun "phase 2... compacting" + +-- logFun "phase 2.1...compacting pact state" +-- forM_ [0 .. int @_ @Word n - 1] $ \nid -> do +-- forM_ (allChains v) $ \cid -> do +-- let logger' = addLabel ("nodeId", sshow nid) $ addLabel ("chainId", chainIdToText cid) logger +-- withSqliteDb cid logger' (srcPactDir show nid) False $ \srcDb -> do +-- withSqliteDb cid logger' (targetPactDir show nid) False $ \targetDb -> do +-- sigmaCompact srcDb targetDb (BlockHeight 25) + +-- logFun "phase 2.2...compacting RocksDB" +-- forM_ [0 .. int @_ @Word n - 1] $ \nid -> do +-- let srcRdb = srcRocksDb { _rocksDbNamespace = T.encodeUtf8 (toText nid) } +-- let tgtRdb = targetRocksDb { _rocksDbNamespace = T.encodeUtf8 (toText nid) } +-- Sigma.doCompactRocksDb (addLabel ("nodeId", sshow nid) logger) allChains 25 srcRdb tgtRdb + +-- logFun "phase 3... restarting nodes and ensuring progress" +-- runNodesForSeconds logLevel logFun (multiConfig n) { _configFullHistoricPactState = False } n 10 targetRocksDb targetPactDir ct +-- Just stats2 <- consensusStateSummary <$> swapMVar stateVar emptyConsensusState +-- -- We ensure that we've gotten to at least 1.5x the previous block count +-- assertGe "average block count post-compaction" (Actual $ _statBlockCount stats2) (Expected (3 * _statBlockCount stats1 `div` 2)) +-- logFun $ sshow stats2 replayTest - :: LogLevel - -> ChainwebVersion - -> Int + :: HasVersion + => LogLevel + -> Natural -> RocksDb -> FilePath -> (String -> IO ()) -> IO () -replayTest loglevel v n rdb pactDbDir step = do +replayTest loglevel n rdb pactDbDir step = do let tastylog = step . T.unpack let logFun = step . T.unpack tastylog "phase 1..." - stateVar <- newMVar $ emptyConsensusState v + stateVar <- newMVar emptyConsensusState let ct = harvestConsensusState (genericLogger loglevel logFun) stateVar - runNodesForSeconds loglevel logFun v (replicate n $ multiConfig n) 60 rdb pactDbDir ct - Just stats1 <- consensusStateSummary <$> swapMVar stateVar (emptyConsensusState v) - assertGe "maximum cut height before reset" (Actual $ _statMaxHeight stats1) (Expected $ 10) + runNodesForSeconds loglevel logFun implicitVersion (multiConfigBuilders n) 60 rdb pactDbDir ct + Just stats1 <- consensusStateSummary <$> swapMVar stateVar emptyConsensusState + assertGe "maximum cut height before reset" (Actual $ _statMaxHeight stats1) (Expected 10) tastylog $ sshow stats1 - tastylog $ "phase 2... resetting" - runNodesForSeconds loglevel logFun v - (replicate n - $ multiConfig n - & mapped . configCuts . cutInitialBlockHeightLimit .~ Just 5) - 30 rdb pactDbDir ct - state2 <- swapMVar stateVar (emptyConsensusState v) - let stats2 = fromJuste $ consensusStateSummary state2 - tastylog $ sshow stats2 - assertGe "block count after reset" (Actual $ _statBlockCount stats2) (Expected $ _statBlockCount stats1) - tastylog $ "phase 3... replaying" + tastylog "phase 3... replaying" let replayInitialHeight = 5 firstReplayCompleteRef <- newIORef False - runNodesForSeconds loglevel logFun v - (replicate n - $ multiConfig n - & mapped . configCuts . cutInitialBlockHeightLimit - .~ Just replayInitialHeight - & mapped . configOnlySyncPact .~ True) - (Seconds 20) rdb pactDbDir $ \nid cw -> case cw of - Replayed l (Just u) -> do + runNodesForSeconds loglevel logFun implicitVersion + (fmap (set (configCuts . cutInitialBlockHeightLimit) (Just replayInitialHeight) .) (multiConfigBuilders n)) + (Seconds 20) rdb pactDbDir $ \_ cw _ -> case cw of + RewoundToCut rewoundToCut -> do writeIORef firstReplayCompleteRef True - _ <- flip HM.traverseWithKey (_cutMap l) $ \cid bh -> - assertEqual ("lower chain " <> sshow cid) replayInitialHeight (view blockHeight bh) - -- TODO: this is flaky, presumably because a node's cutdb - -- is not being cancelled synchronously enough - assertEqual "upper cut" (_stateCutMap state2 HM.! nid) u - _ <- flip HM.traverseWithKey (_cutMap u) $ \cid bh -> - assertGe ("upper chain " <> sshow cid) (Actual $ view blockHeight bh) (Expected replayInitialHeight) - return () - Replayed _ Nothing -> error "replayTest: no replay upper bound" - _ -> error "replayTest: not a replay" - assertEqual "first replay completion" True =<< readIORef firstReplayCompleteRef - let fastForwardHeight = 10 - tastylog $ "phase 4... replaying with fast-forward limit" - secondReplayCompleteRef <- newIORef False - runNodesForSeconds loglevel logFun v - (replicate n - $ multiConfig n - & mapped . configCuts . cutInitialBlockHeightLimit - .~ Just replayInitialHeight - & mapped . configCuts . cutFastForwardBlockHeightLimit - .~ Just fastForwardHeight - & mapped . configOnlySyncPact .~ True - ) - (Seconds 20) rdb pactDbDir $ \_ cw -> case cw of - Replayed l (Just u) -> do - writeIORef secondReplayCompleteRef True - _ <- flip HM.traverseWithKey (_cutMap l) $ \cid bh -> + _ <- flip HM.traverseWithKey (_cutMap rewoundToCut) $ \cid bh -> assertEqual ("lower chain " <> sshow cid) replayInitialHeight (view blockHeight bh) - _ <- flip HM.traverseWithKey (_cutMap u) $ \cid bh -> - assertEqual ("upper chain " <> sshow cid) fastForwardHeight (view blockHeight bh) return () - Replayed _ Nothing -> do - error "replayTest: no replay upper bound" _ -> error "replayTest: not a replay" - assertEqual "second replay completion" True =<< readIORef secondReplayCompleteRef + assertEqual "replay completion" True =<< readIORef firstReplayCompleteRef + runNodesForSeconds loglevel logFun implicitVersion (multiConfigBuilders n) 60 rdb pactDbDir ct + Just stats2 <- consensusStateSummary <$> swapMVar stateVar emptyConsensusState + assertGe "maximum cut height after reset" (Actual $ _statMaxHeight stats2) (Expected $ _statMaxHeight stats1) + assertLe "maximum cut height after reset" (Actual $ _statMaxHeight stats2) (Expected $ round @Double (int (_statMaxHeight stats1) * 2.1)) tastylog "done." -- -------------------------------------------------------------------------- -- -- Test that block production is efficient. The block delay in this test is -- random with a mean of 1 second; we expect to produce *around* a block a second. -efficiencyTest - :: LogLevel - -> ChainwebVersion - -> Int - -- ^ number of nodes +test + :: HasVersion + => LogLevel + -> Natural -> Seconds -> RocksDb -> FilePath -> (String -> IO ()) -> IO () -efficiencyTest loglevel v n seconds rdb pactDbDir step = do +test loglevel n seconds rdb pactDbDir step = do -- Count log messages and only print the first 60 messages let tastylog = step . T.unpack - let logFun = tastylog + let logFun = T.putStrLn maxLogMsgs = 60 var <- newMVar (0 :: Int) let countedLog msg = modifyMVar_ var $ \c -> force (succ c) <$ when (c < maxLogMsgs) (logFun msg) - stateVar <- newMVar (emptyConsensusState v) - runNodesForSeconds loglevel countedLog v (replicate n $ multiConfig n) seconds rdb pactDbDir + stateVar <- newMVar emptyConsensusState + runNodesForSeconds loglevel countedLog implicitVersion (multiConfigBuilders n) seconds rdb pactDbDir (harvestConsensusState (genericLogger loglevel logFun) stateVar) - consensusStateSummary <$> readMVar stateVar >>= \case + state <- readMVar stateVar + case consensusStateSummary state of Nothing -> assertFailure "chainweb didn't make any progress" Just stats -> do logsCount <- readMVar var tastylog $ "Number of logs: " <> sshow logsCount - tastylog $ "Expected BlockCount: " <> sshow (expectedBlockCount v seconds) -- 80 + 19.5 * 20 - tastylog $ J.encodeText stats - tastylog $ J.encodeText $ J.object - [ "maxEfficiency%" J..= J.number (realToFrac $ (bc $ _statMaxHeight stats) * (100 :: Double) / int (_statBlockCount stats)) - , "minEfficiency%" J..= J.number (realToFrac $ (bc $ _statMinHeight stats) * (100 :: Double) / int (_statBlockCount stats)) - , "medEfficiency%" J..= J.number (realToFrac $ (bc $ _statMedHeight stats) * (100 :: Double) / int (_statBlockCount stats)) - , "avgEfficiency%" J..= J.number (realToFrac $ (bc $ round (_statAvgHeight stats)) * (100 :: Double) / int (_statBlockCount stats)) + tastylog $ "Expected BlockCount: " <> sshow (expectedBlockCount seconds) -- 80 + 19.5 * 20 + tastylog $ encodeToText stats + tastylog $ encodeToText $ object + [ "maxEfficiency%" .= (realToFrac (bc $ _statMaxHeight stats) * (100 :: Double) / int (_statBlockCount stats)) + , "minEfficiency%" .= (realToFrac (bc $ _statMinHeight stats) * (100 :: Double) / int (_statBlockCount stats)) + , "medEfficiency%" .= (realToFrac (bc $ _statMedHeight stats) * (100 :: Double) / int (_statBlockCount stats)) + , "avgEfficiency%" .= (realToFrac (bc $ round (_statAvgHeight stats)) * (100 :: Double) / int (_statBlockCount stats)) ] + let (orphans, canonical) = orphanStats state + tastylog $ encodeToText $ object + [ "canonicalHeaders" .= canonical + , "orphanHeaders" .= orphans + , "orphanRate%" .= (int orphans * (100 :: Double) / int (orphans + canonical)) + ] + forM_ (cutSyncStats state) $ \v -> tastylog $ encodeToText v + (assertGe "number of blocks") (Actual $ _statBlockCount stats) (Expected $ _statBlockCount l) + (assertLe "max stored cut count") + (Actual $ _statMaxCutCount stats) + (Expected $ ceiling (avgBlockHeightAtCutHeight $ _statMaxHeight stats) + + int (diameterAtCutHeight (_statMaxHeight stats))) (assertGe "maximum cut height") (Actual $ _statMaxHeight stats) (Expected $ _statMaxHeight l) (assertGe "minimum cut height") (Actual $ _statMinHeight stats) (Expected $ _statMinHeight l) (assertGe "median cut height") (Actual $ _statMedHeight stats) (Expected $ _statMedHeight l) @@ -714,135 +696,10 @@ efficiencyTest loglevel v n seconds rdb pactDbDir step = do (assertLe "average cut height") (Actual $ _statAvgHeight stats) (Expected $ _statAvgHeight u) where - l = lowerStats v seconds - u = upperStats v seconds - - bc x = realToFrac $ blockCountAtCutHeight v x - order (chainGraphAtCutHeight v x) - -forkVoteTestSucceedUnanimous - :: LogLevel -> RocksDb -> FilePath -> (String -> IO ()) -> IO () -forkVoteTestSucceedUnanimous loglevel rdb pactDbDir _step = do - let nodeCount = 2 - let versionForkNum = ForkNumber 1 - let v = timedConsensusVersion versionForkNum petersenChainGraph petersenChainGraph - let baseConf = multiConfig nodeCount - forkVoteTest loglevel rdb pactDbDir _step - v (replicate nodeCount baseConf) (int $ forkEpochLength v + 1) >>= - P.alignExact - (HM.fromList - [(NodeId (int nid), P.equals P.? ForkNumber 1) - | nid <- [0..nodeCount-1]] - ) - -forkVoteTestFailUnanimous - :: LogLevel -> RocksDb -> FilePath -> (String -> IO ()) -> IO () -forkVoteTestFailUnanimous loglevel rdb pactDbDir _step = do - let nodeCount = 2 - let versionForkNum = ForkNumber 1 - let v = timedConsensusVersion versionForkNum petersenChainGraph petersenChainGraph - let baseConf = multiConfig nodeCount - & mapped . configMining . miningCoordination . coordinationTargetForkOverride - .~ True - forkVoteTest loglevel rdb pactDbDir _step - v (replicate nodeCount baseConf) (int $ forkEpochLength v + 1) >>= - P.alignExact - (HM.fromList - [(NodeId (int nid), P.equals P.? ForkNumber 0) - | nid <- [0..nodeCount-1]] - ) - -forkVoteTestSucceedTwiceUnanimous - :: LogLevel -> RocksDb -> FilePath -> (String -> IO ()) -> IO () -forkVoteTestSucceedTwiceUnanimous loglevel rdb pactDbDir _step = do - let nodeCount = 2 - let versionForkNum = ForkNumber 2 - let v = timedConsensusVersion versionForkNum petersenChainGraph petersenChainGraph - let baseConf = multiConfig nodeCount - forkVoteTest loglevel rdb pactDbDir _step - v (replicate nodeCount baseConf) (int $ forkEpochLength v * 2 + 1) >>= - P.alignExact - (HM.fromList - [(NodeId (int nid), P.equals P.? ForkNumber 2) - | nid <- [0..nodeCount-1]] - ) - -forkVoteTestSucceedFourFifths - :: LogLevel -> RocksDb -> FilePath -> (String -> IO ()) -> IO () -forkVoteTestSucceedFourFifths loglevel rdb pactDbDir _step = do - let nodeCount = 5 - let versionForkNum = ForkNumber 1 - -- for nodes to have different votes, there needs to be more than once chain. - let v = timedConsensusVersion versionForkNum petersenChainGraph petersenChainGraph - let noVoteConf = multiConfig nodeCount - & mapped . configMining . miningCoordination . coordinationTargetForkOverride - .~ True - let voteConf = multiConfig nodeCount - forkVoteTest loglevel rdb pactDbDir _step - v (replicate 4 voteConf <> replicate 1 noVoteConf) (int $ forkEpochLength v + 1) >>= - P.alignExact - (HM.fromList $ - [(NodeId (int nid), P.equals P.? ForkNumber 1) - | nid <- [0..nodeCount-1] - ]) - -forkVoteTestFailFourFifths - :: LogLevel -> RocksDb -> FilePath -> (String -> IO ()) -> IO () -forkVoteTestFailFourFifths loglevel rdb pactDbDir _step = do - let nodeCount = 5 - let versionForkNum = ForkNumber 1 - -- for nodes to have different votes, there needs to be more than once chain. - let v = timedConsensusVersion versionForkNum petersenChainGraph petersenChainGraph - let noVoteConf = multiConfig nodeCount - & mapped . configMining . miningCoordination . coordinationTargetForkOverride - .~ True - let voteConf = multiConfig nodeCount - forkVoteTest loglevel rdb pactDbDir _step - v (replicate 1 voteConf <> replicate 4 noVoteConf) (int $ forkEpochLength v + 1) >>= - P.alignExact - (HM.fromList $ - [(NodeId (int nid), P.equals P.? ForkNumber 0) - | nid <- [0..nodeCount-1]] - ) - -forkVoteTest - :: LogLevel -> RocksDb -> FilePath -> (String -> IO ()) - -> ChainwebVersion -> [ChainwebConfiguration -> ChainwebConfiguration] -> BlockHeight - -> IO (HM.HashMap NodeId ForkNumber) -forkVoteTest loglevel rdb pactDbDir _step v confBuilders heightThreshold = do - -- Count log messages and only print the first 60 messages - let tastylog = putStrLn . T.unpack - let maxLogMsgs = 60 - var <- newMVar (0 :: Int) - let countedLog msg = modifyMVar_ var $ \c -> force (succ c) <$ - when (c < maxLogMsgs) (tastylog msg) - - forkNumVar <- newMVar mempty - doneVars <- sequenceA $ newEmptyTMVarIO <$ confBuilders - void $ race - (atomically $ traverse_ takeTMVar doneVars) - (runNodes loglevel countedLog v confBuilders rdb pactDbDir (harvestForkNumber doneVars forkNumVar)) - - readMVar forkNumVar - - where - sayWhen doneVar cw = atomically $ do - curCut <- cw ^. chainwebCutResources . cutsCutDb . cutStm - guard (_cutMinHeight curCut > heightThreshold) - void $ tryPutTMVar doneVar () - - harvestForkNumber _ _ _ (Replayed _ _) = - error "harvestForkNumber: doesn't work when replaying, replays don't do consensus" - harvestForkNumber doneVars stateVar (NodeId nid) (StartedChainweb cw) = do - void $ race - (sayWhen (doneVars !! int nid) cw) - (runChainweb cw (\_ -> return ())) - `finally` do - let cutDb = view (chainwebCutResources . cutsCutDb) cw - latestCutHeaders <- readHighestCutHeaders cutDb - let highestForkNumber = - maximum $ view blockForkNumber <$> HM.elems latestCutHeaders - modifyMVar_ stateVar $ - return . HM.insert (NodeId nid) highestForkNumber + l = lowerStats seconds + u = upperStats seconds + + bc x = blockCountAtCutHeight x - order (chainGraphAtCutHeight x) -- -------------------------------------------------------------------------- -- -- Results @@ -852,33 +709,47 @@ data ConsensusState = ConsensusState -- ^ for short tests this is fine. For larger test runs we should -- use HyperLogLog+ - , _stateCutMap :: !(HM.HashMap NodeId Cut) - -- ^ Node Id map - , _stateChainwebVersion :: !ChainwebVersion + , _stateCutMap :: !(HM.HashMap NodeId (Int, Cut)) + -- ^ The latest cut in each node, as well as the number of cuts stored + + , _stateHeightCounts :: !(HM.HashMap (ChainId, BlockHeight) Int) + -- ^ number of distinct block headers observed at each (chain, height), + -- for orphan rate analysis + + , _stateCutTrace :: !(HM.HashMap NodeId [(Double, CutHeight)]) + -- ^ (sample time in POSIX seconds, cut height) samples taken during + -- the run, for cut sync latency analysis } deriving (Show, Generic, NFData) -instance HasChainwebVersion ConsensusState where - _chainwebVersion = _stateChainwebVersion - -emptyConsensusState :: ChainwebVersion -> ConsensusState -emptyConsensusState v = ConsensusState mempty mempty v +emptyConsensusState :: ConsensusState +emptyConsensusState = ConsensusState mempty mempty mempty mempty sampleConsensusState - :: NodeId + :: HasVersion + => NodeId -- ^ node Id -> WebBlockHeaderDb - -> CutDb tbl + -> CutDb l + -> Casify RocksDbTable CutHashes -> ConsensusState -> IO ConsensusState -sampleConsensusState nid bhdb cutdb s = do - !hashes' <- webEntries bhdb - $ S.fold_ (flip HS.insert) (_stateBlockHashes s) id - . S.map (view blockHash) +sampleConsensusState nid bhdb cutdb ct s = do + numStoredCuts <- withTableIterator ct $ \i -> iterToEntryStream i & S.length_ + (!hashes', !heightCounts') <- webEntries bhdb Nothing Nothing + $ S.fold_ + (\(hs, m) bh -> + let h = view blockHash bh + in if HS.member h hs + then (hs, m) + else (HS.insert h hs, HM.insertWith (+) (_chainId bh, view blockHeight bh) 1 m)) + (_stateBlockHashes s, _stateHeightCounts s) + id !c <- _cut cutdb return $! s { _stateBlockHashes = hashes' - , _stateCutMap = HM.insert nid c (_stateCutMap s) + , _stateCutMap = HM.insert nid (numStoredCuts, c) (_stateCutMap s) + , _stateHeightCounts = heightCounts' } data Stats = Stats @@ -887,25 +758,27 @@ data Stats = Stats , _statMinHeight :: !CutHeight , _statMedHeight :: !CutHeight , _statAvgHeight :: !Double + , _statMaxCutCount :: Int } deriving (Show, Eq, Ord, Generic, ToJSON) instance J.Encode Stats where build = J.build . J.encodeWithAeson -consensusStateSummary :: ConsensusState -> Maybe Stats +consensusStateSummary :: HasVersion => ConsensusState -> Maybe Stats consensusStateSummary s | HM.null (_stateCutMap s) = Nothing | otherwise = Just Stats - { _statBlockCount = int $ hashCount + { _statBlockCount = int hashCount , _statMaxHeight = maxHeight , _statMinHeight = minHeight , _statMedHeight = medHeight , _statAvgHeight = avgHeight + , _statMaxCutCount = fst $ maximumBy (compare `on` fst) $ _stateCutMap s } where - cutHeights = _cutHeight <$> _stateCutMap s - graph = chainGraphAt s - $ maximum . concatMap chainHeights + cutHeights = _cutHeight . snd <$> _stateCutMap s + graph = chainGraphAt + $ maximum . concatMap (chainHeights . snd) $ toList $ _stateCutMap s hashCount = HS.size (_stateBlockHashes s) - int (order graph) @@ -924,32 +797,93 @@ consensusStateSummary s avgHeight = avg $ HM.elems cutHeights medHeight = median $ HM.elems cutHeights -expectedBlockCount :: ChainwebVersion -> Seconds -> Double -expectedBlockCount v s = expectedGlobalBlockCountAfterSeconds v s +expectedBlockCount :: HasVersion => Seconds -> Double +expectedBlockCount s = expectedGlobalBlockCountAfterSeconds s -lowerStats :: ChainwebVersion -> Seconds -> Stats -lowerStats v seconds = Stats +-- | Count canonical vs orphan headers relative to the highest cut observed in +-- any node. A header is canonical if its (chain, height) is at or below the +-- height of that chain in the best cut; all other headers at canonical heights +-- are orphans. +orphanStats :: ConsensusState -> (Int, Int) +orphanStats s = L.foldl' step (0, 0) (HM.toList (_stateHeightCounts s)) + where + bestCut = snd $ maximumBy (compare `on` _cutHeight . snd) $ HM.elems (_stateCutMap s) + maxHeights = HM.map (view blockHeight) (_cutMap bestCut) + step (orphans, canonical) ((cid, h), k) + | Just h' <- HM.lookup cid maxHeights, h <= h' + = (orphans + k - 1, canonical + 1) + | otherwise = (orphans, canonical) + +-- | Measure cut sync latency from per-node cut height traces: for each cut +-- height, how long after the first node reached it did a typical (median) +-- node reach it, and how long did the last node take. Heights in the initial +-- startup transient (below a quarter of the commonly reached height) are +-- excluded. +cutSyncStats :: ConsensusState -> Maybe Value +cutSyncStats s + | length reachMaps < 2 = Nothing + | null lags = Nothing + | otherwise = Just $ object + [ "medianSyncMs" .= pct 0.5 (map fst3 lags) + , "p90SyncMs" .= pct 0.9 (map fst3 lags) + , "maxSyncMs" .= pct 0.5 (map thd3 lags) + , "heightsMeasured" .= length lags + ] + where + reachMaps = map reach (HM.elems (_stateCutTrace s)) + where + -- first time this node reached each height; samples are in time order + reach = go 0 . L.sortOn fst + where + go _ [] = [] + go prev ((t, h):rest) + | h <= prev = go prev rest + | otherwise = [(ht, t) | ht <- [prev + 1 .. h]] ++ go h rest + hi = minimum (map (fst . last) reachMaps) + lo = hi `div` 4 + lags :: [(Int, Int, Int)] + lags = L.sort + [ ( round $ 1000 * (med - mn) + , round $ 1000 * (p90 - mn) + , round $ 1000 * (mx - mn) + ) + | h <- [lo .. hi] + , let ts = L.sort [t | m <- reachMaps, Just t <- [L.lookup h m]] + , length ts == length reachMaps + , let mn = head ts + mx = last ts + med = pct 0.5 ts + p90 = pct 0.9 ts + ] + fst3 (a,_,_) = a + thd3 (_,_,c) = c + pct p xs = xs !! min (length xs - 1) (floor (p * int (length xs - 1))) + +lowerStats :: HasVersion => Seconds -> Stats +lowerStats seconds = Stats { _statBlockCount = round $ ebc * 0.6 -- temporarily, was 0.8 - , _statMaxHeight = round $ ebc * 0.5 -- temporarily, was 0.7 - , _statMinHeight = round $ ebc * 0.1 -- temporarily, was 0.3 - , _statMedHeight = round $ ebc * 0.5 - , _statAvgHeight = ebc * 0.5 + , _statMaxHeight = round $ ebc * 0.1 -- temporarily, was 0.7 + , _statMinHeight = round $ ebc * 0.05 -- temporarily, was 0.3 + , _statMedHeight = round $ ebc * 0.1 + , _statAvgHeight = ebc * 0.1 + , _statMaxCutCount = undefined } where - ebc = expectedBlockCount v seconds + ebc = expectedBlockCount seconds -upperStats :: ChainwebVersion -> Seconds -> Stats -upperStats v seconds = Stats +upperStats :: HasVersion => Seconds -> Stats +upperStats seconds = Stats { _statBlockCount = round $ ebc * 1.4 , _statMaxHeight = round $ ech * 1.4 , _statMinHeight = round $ ech * 1.4 , _statMedHeight = round $ ech * 1.4 , _statAvgHeight = ech * 1.4 + , _statMaxCutCount = undefined } where - ebc = expectedBlockCount v seconds - ech = expectedCutHeightAfterSeconds v seconds + ebc = expectedBlockCount seconds + ech = expectedCutHeightAfterSeconds seconds nextLowestPowerOfTen :: forall a. (Integral a, Ord a) => a -> a nextLowestPowerOfTen n diff --git a/test/lib/Chainweb/Test/Orphans/Internal.hs b/test/lib/Chainweb/Test/Orphans/Internal.hs index a442a651d8..f30a34c26f 100644 --- a/test/lib/Chainweb/Test/Orphans/Internal.hs +++ b/test/lib/Chainweb/Test/Orphans/Internal.hs @@ -6,6 +6,8 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} @@ -42,70 +44,11 @@ module Chainweb.Test.Orphans.Internal , arbitraryMerkleHeaderProof , arbitraryMerkleBodyProof --- ** Output Proofs -, arbitraryOutputMerkleProof -, arbitraryOutputProof -, mkTestOutputProof -, arbitraryOutputEvents -, arbitraryPayloadWithStructuredOutputs - --- ** Events Proofs -, mkTestEventsProof -, arbitraryEventsProof -, EventPactValue(..) -, ProofPactEvent(..) - -- ** Misc , arbitraryPage ) where import Control.Applicative -import Control.Lens (view, set) -import Control.Monad -import Control.Monad.Catch - -import Crypto.Hash.Algorithms - -import Data.Aeson hiding (Error) -import qualified Data.ByteString as B -import qualified Data.ByteString.Short as BS -import Data.Foldable -import Data.Function -import qualified Data.HashMap.Strict as HM -import qualified Data.HashSet as HS -import Data.Kind -import qualified Data.List as L -import Data.MerkleLog -import Data.Streaming.Network.Internal -import qualified Data.Text as T -import qualified Data.Text.Encoding as T -import Data.Type.Equality -import qualified Data.Vector as V - -import GHC.Stack - -import Numeric.Natural - -import qualified Pact.JSON.Encode as J -import Pact.Types.Command -import Pact.Types.PactValue -import Pact.Types.Runtime (PactEvent(..), Literal(..)) - -import Prelude hiding (Applicative(..)) - -import System.IO.Unsafe - -import Test.QuickCheck.Arbitrary -import Test.QuickCheck.Exception (discard) -import Test.QuickCheck.Gen -import Test.QuickCheck.Modifiers - -import Unsafe.Coerce - -import Test.QuickCheck.Instances ({- Arbitrary V4.UUID -}) - --- internal modules - import Chainweb.BlockCreationTime import Chainweb.BlockHash import Chainweb.BlockHeader @@ -113,7 +56,6 @@ import Chainweb.BlockHeaderDB.RestAPI import Chainweb.BlockHeight import Chainweb.BlockWeight import Chainweb.ChainId -import Chainweb.Chainweb import Chainweb.Chainweb.Configuration import Chainweb.Crypto.MerkleLog import Chainweb.Cut.Create @@ -122,25 +64,24 @@ import Chainweb.Difficulty import Chainweb.ForkState import Chainweb.Graph import Chainweb.HostAddress -import Chainweb.Mempool.Mempool -import Chainweb.Mempool.RestAPI import Chainweb.MerkleLogHash import Chainweb.MerkleUniverse import Chainweb.Miner.Config import Chainweb.Miner.Pact import Chainweb.NodeVersion +import Chainweb.Pact.Mempool.Mempool +import Chainweb.Pact.Mempool.RestAPI +import Chainweb.Pact.Payload import Chainweb.Pact.RestAPI.SPV -import Chainweb.Pact.Types -import Chainweb.Payload +import Chainweb.Parent +import Chainweb.PayloadProvider import Chainweb.PowHash +import Chainweb.Ranked import Chainweb.RestAPI.NetworkID import Chainweb.RestAPI.NodeInfo import Chainweb.RestAPI.Utils -import Chainweb.SPV import Chainweb.SPV.EventProof -import Chainweb.SPV.OutputProof import Chainweb.SPV.PayloadProof -import Chainweb.Test.Orphans.Pact import Chainweb.Test.Orphans.Time () import Chainweb.Test.TestVersions import Chainweb.Time @@ -149,23 +90,51 @@ import Chainweb.Utils.Paging import Chainweb.Utils.Rule (ruleElems) import Chainweb.Utils.Serialization import Chainweb.Version -import Chainweb.Version.RecapDevelopment import Chainweb.Version.Mainnet +import Chainweb.Version.RecapDevelopment import Chainweb.Version.Registry import Chainweb.Version.Testnet04 import Chainweb.Version.Utils - +import Control.Lens (set, view) +import Control.Monad +import Control.Monad.Catch +import Data.Aeson hiding (Error) +import Data.ByteString qualified as B +import Data.ByteString.Short qualified as BS +import Data.Foldable +import Data.Function +import Data.Functor ((<&>)) +import Data.HashMap.Strict qualified as HM +import Data.HashSet qualified as HS +import Data.Kind +import Data.MerkleLog.V1 import Data.Singletons - +import Data.Streaming.Network.Internal +import Data.Text qualified as T +import Data.Text.Encoding qualified as T +import Data.Type.Equality +import GHC.Stack import Network.X509.SelfSigned - +import Numeric.Natural import P2P.Node.Configuration import P2P.Node.PeerDB import P2P.Peer import P2P.Test.Orphans () - +import Pact.Core.Capabilities +import Pact.Core.Command.Types hiding (ChainId, NetworkId) +import Pact.Core.Literal +import Pact.Core.PactValue +import Pact.Core.StableEncoding +import Pact.JSON.Encode qualified as J +import Prelude hiding (Applicative(..)) +import System.IO.Unsafe import System.Logger.Types - +import Test.QuickCheck.Arbitrary +import Test.QuickCheck.Exception (discard) +import Test.QuickCheck.Gen +import Test.QuickCheck.Instances ({- Arbitrary V4.UUID -}) +import Test.QuickCheck.Modifiers +import Unsafe.Coerce import Utils.Logging -- -------------------------------------------------------------------------- -- @@ -287,21 +256,33 @@ instance Arbitrary NodeInfo where arbitrary = do v <- arbitrary curHeight <- arbitrary - let graphs = unpackGraphs v - let curGraph = head $ dropWhile (\(h,_) -> h > curHeight) graphs - let curChains = map fst $ snd curGraph - return $ NodeInfo - { nodeVersion = _versionName v - , nodePackageVersion = chainwebNodeVersionHeaderValue - , nodeApiVersion = prettyApiVersion - , nodeChains = T.pack . show <$> curChains - , nodeNumberOfChains = length curChains - , nodeGraphHistory = graphs - , nodeLatestBehaviorHeight = latestBehaviorAt v - , nodeGenesisHeights = map (\c -> (chainIdToText c, genesisHeight v c)) $ HS.toList $ chainIds v - , nodeHistoricalChains = ruleElems $ HM.toList . HM.map HS.toList . toAdjacencySets <$> _versionGraphs v - , nodeBlockDelay = _versionBlockDelay v - } + withVersion v $ do + let graphs = unpackGraphs + let curGraph = head $ dropWhile (\(h,_) -> h > curHeight) graphs + let curChains = map fst $ snd curGraph + return $ NodeInfo + { nodeVersion = _versionName v + , nodePackageVersion = chainwebNodeVersionHeaderValue + , nodeApiVersion = prettyApiVersion + , nodeChains = T.pack . show <$> curChains + , nodeNumberOfChains = length curChains + , nodeGraphHistory = graphs + , nodeLatestBehaviorHeight = latestBehaviorAt + , nodeGenesisHeights = map (\c -> (toText c, genesisHeight c)) $ HS.toList chainIds + , nodeHistoricalChains = ruleElems $ fmap (HM.toList . HM.map HS.toList . toAdjacencySets) $ _versionGraphs v + , nodeBlockDelay = _versionBlockDelay v + , nodePayloadProviders = _versionPayloadProviderTypes implicitVersion <&> \case + EvmProvider n -> object + [ "type" .= ("eth" :: T.Text) + , "ethChainId" .= n + ] + PactProvider -> object + [ "type" .= ("pact" :: T.Text) + ] + MinimalProvider -> object + [ "type" .= ("parked" :: T.Text) + ] + } -- -------------------------------------------------------------------------- -- -- Block Header @@ -330,51 +311,51 @@ instance Arbitrary EpochStartTime where instance Arbitrary ForkState where arbitrary = do v <- arbitrary - votes <- chooseBoundedIntegral (0, int (forkEpochLength v) * voteStep) + votes <- chooseBoundedIntegral (0, int (withVersion v forkEpochLength) * voteStep) number <- chooseBoundedIntegral (0, 100000000) return $ ForkState 0 & set forkVotes votes & set forkNumber number -instance Arbitrary BlockHeader where - arbitrary = arbitrary >>= arbitraryBlockHeaderVersion +instance HasVersion => Arbitrary BlockHeader where + arbitrary = arbitraryBlockHeaderVersion arbitraryBlockHashRecordVersionHeightChain - :: ChainwebVersion - -> BlockHeight + :: HasVersion + => BlockHeight -> ChainId -> Gen BlockHashRecord -arbitraryBlockHashRecordVersionHeightChain v h cid +arbitraryBlockHashRecordVersionHeightChain h cid | isWebChain graph cid = BlockHashRecord . HM.fromList . zip (toList $ adjacentChainIds graph cid) - <$> infiniteListOf arbitrary + <$> infiniteListOf (Parent <$> arbitrary) | otherwise = discard where graph - | h == genesisHeight v cid = chainGraphAt v h - | otherwise = chainGraphAt v (h - 1) + | h == genesisHeight cid = chainGraphAt h + | otherwise = chainGraphAt (h - 1) -arbitraryBlockHeaderVersion :: ChainwebVersion -> Gen BlockHeader -arbitraryBlockHeaderVersion v = do +arbitraryBlockHeaderVersion :: HasVersion => Gen BlockHeader +arbitraryBlockHeaderVersion = do h <- arbitrary - arbitraryBlockHeaderVersionHeight v h + arbitraryBlockHeaderVersionHeight h arbitraryBlockHeaderVersionHeight - :: ChainwebVersion - -> BlockHeight + :: HasVersion + => BlockHeight -> Gen BlockHeader -arbitraryBlockHeaderVersionHeight v h = do - cid <- elements $ toList $ chainIdsAt v h - arbitraryBlockHeaderVersionHeightChain v h cid +arbitraryBlockHeaderVersionHeight h = do + cid <- elements $ toList $ chainIdsAt h + arbitraryBlockHeaderVersionHeightChain h cid arbitraryBlockHeaderVersionHeightChain - :: ChainwebVersion - -> BlockHeight + :: HasVersion + => BlockHeight -> ChainId -> Gen BlockHeader -arbitraryBlockHeaderVersionHeightChain v h cid - | isWebChain (chainGraphAt v h) cid = do +arbitraryBlockHeaderVersionHeightChain h cid + | isWebChain (chainGraphAt h) cid = do t <- chooseEnum (epoch, add (scaleTimeSpan @Int (365 * 200) day) epoch) fromLog @ChainwebMerkleHashAlgorithm . newMerkleLog <$> entries t | otherwise = discard @@ -383,32 +364,33 @@ arbitraryBlockHeaderVersionHeightChain v h cid -- TODO: pick between 0 and the version fork number = liftA2 (:+:) (pure $ ForkState 0) -- feature flags $ liftA2 (:+:) (pure $ BlockCreationTime t) -- time - $ liftA2 (:+:) arbitrary -- parent hash + $ liftA2 (:+:) (Parent <$> arbitrary) -- parent hash $ liftA2 (:+:) arbitrary -- target $ liftA2 (:+:) arbitrary -- payload hash $ liftA2 (:+:) (pure cid) -- chain id $ liftA2 (:+:) arbitrary -- weight $ liftA2 (:+:) (pure h) -- height - $ liftA2 (:+:) (pure (_versionCode v)) -- version + $ liftA2 (:+:) (pure (_versionCode implicitVersion)) -- version $ liftA2 (:+:) (EpochStartTime <$> chooseEnum (toEnum 0, t)) -- epoch start $ liftA2 (:+:) (Nonce <$> chooseAny) -- nonce $ fmap (MerkleLogBody . blockHashRecordToVector) - (arbitraryBlockHashRecordVersionHeightChain v h cid) -- adjacents + (arbitraryBlockHashRecordVersionHeightChain h cid) -- adjacents -instance Arbitrary HeaderUpdate where +instance HasVersion => Arbitrary HeaderUpdate where arbitrary = HeaderUpdate <$> (ObjectEncoded <$> arbitrary) <*> arbitrary <*> arbitrary - <*> arbitrary - <*> arbitrary -instance Arbitrary BlockHashWithHeight where - arbitrary = BlockHashWithHeight <$> arbitrary <*> arbitrary +instance Arbitrary (Ranked BlockHash) where + arbitrary = Ranked <$> arbitrary <*> arbitrary -- -------------------------------------------------------------------------- -- -- Arbitrary CutHashes +instance Arbitrary EncodedPayloadData where + arbitrary = EncodedPayloadData <$> arbitrary + instance Arbitrary CutId where arbitrary = do bs <- arbitraryBytes 32 @@ -416,10 +398,10 @@ instance Arbitrary CutId where Left e -> error $ "Arbitrary Instance for CutId: " <> show e Right x -> return x -instance Arbitrary CutHashes where +instance HasVersion => Arbitrary CutHashes where arbitrary = CutHashes <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary - <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary + <*> arbitrary <*> arbitrary <*> (fmap EncodedPayloadData <$> arbitrary) <*> return Nothing instance Arbitrary CutHeight where @@ -429,17 +411,19 @@ instance Arbitrary CutHeight where -- -------------------------------------------------------------------------- -- -- Mining Work -instance Arbitrary WorkHeader where +instance HasVersion => Arbitrary MiningWork where arbitrary = do hdr <- arbitrary - return $ WorkHeader - { _workHeaderChainId = _chainId hdr - , _workHeaderTarget = view blockTarget hdr - , _workHeaderBytes = BS.toShort $ runPutS $ encodeBlockHeaderWithoutHash hdr + return $ MiningWork + { _miningWorkChainId = _chainId hdr + , _miningWorkTarget = view blockTarget hdr + , _miningWorkBytes = BS.toShort $ runPutS $ encodeAsMiningWork hdr } -instance Arbitrary SolvedWork where - arbitrary = SolvedWork <$> arbitrary +instance HasVersion => Arbitrary SolvedWork where + arbitrary = fromJuste . runGetS decodeSolvedWork . BS.fromShort . work <$> arbitrary + where + work hdr = BS.toShort $ runPutS $ encodeAsMiningWork hdr -- -------------------------------------------------------------------------- -- -- Payload over arbitrary bytesstrings @@ -492,11 +476,11 @@ instance MerkleHashAlgorithm a => Arbitrary (OutputTree_ a) where instance Arbitrary (MerkleTree ChainwebMerkleHashAlgorithm) where arbitrary = oneof [ arbitraryPayloadMerkleTree - , arbitraryMerkleTree @_ @BlockHeader + , arbitrary >>= \v -> withVersion v $ arbitraryMerkleTree @_ @BlockHeader ] arbitraryHeaderMerkleTree :: Gen (MerkleTree ChainwebMerkleHashAlgorithm) -arbitraryHeaderMerkleTree = arbitraryMerkleTree @_ @BlockHeader +arbitraryHeaderMerkleTree = arbitrary >>= \v -> withVersion v $ arbitraryMerkleTree @_ @BlockHeader arbitraryPayloadMerkleTree :: forall a @@ -537,7 +521,7 @@ arbitraryMerkleProof = do (b, hs, bs) <- gen idx <- choose (0, hs + bs - 1) let result = if idx > (hs - 1) - then bodyProof @a b (idx - hs) + then bodyProofV1 @a b (idx - hs) else mkHeaderProof @a b (fromIntegral idx) case result of Left !e -> error $ "Chainweb.Test.Orphans.Internal.arbitraryMerkleProof: " <> show e @@ -558,7 +542,7 @@ arbitraryMerkleBodyProof arbitraryMerkleBodyProof = do (b, s) <- gen !idx <- choose (0, s - 1) - case bodyProof b idx of + case bodyProofV1 b idx of Left !e -> error $ "Chainweb.Test.Orphans.Internal.arbitraryMerkleBodyProof: " <> show e Right x -> return x where @@ -593,20 +577,20 @@ mkHeaderProof -> Natural -> m (MerkleProof a) mkHeaderProof b idx = case toLog @a b of - mlog@(MerkleLog _ (_ :+: _) _ :: MerkleLog a ChainwebHashTag (h ': t) (MerkleLogBody b)) -> do + mlog@(MerkleLog _ (_ :+: _) :: MerkleLog a ChainwebHashTag (h ': t) (MerkleLogBody b)) -> do case someN idx of -- Index 0 - SomeSing SZ -> headerProof @(AtIndex 'Z (h ': t)) @a b + SomeSing SZ -> headerProofV1 @(AtIndex 'Z (h ': t)) @a b -- Index > 0 SomeSing x@(SS _) -> case x of -- Assert (at runtime) that the index is within bounds (Sing :: Sing n) -> case lt x (headerSizeN mlog) of Just Refl -> case hasHeader @_ @_ @_ @_ @_ @_ @n mlog of - Dict _ -> headerProof @(AtIndex n (h ': t)) @a b + Dict _ -> headerProofV1 @(AtIndex n (h ': t)) @a b Nothing -> error "must not happen" headerSizeN :: MerkleLog a u t b -> Sing (Length t) -headerSizeN (MerkleLog _ l _) = go l +headerSizeN (MerkleLog _ l) = go l where go :: forall a u t b . MerkleLogEntries a u t b -> Sing (Length t) go MerkleLogBody{} = SZ @@ -665,8 +649,8 @@ hasHeader mlog = case go (sing @N @i) mlog of ) (MerkleLog a u (x' ': t') b) go SZ m = Dict m - go (SS (n :: Sing n)) m@(MerkleLog r (_ :+: t@(_ :+: _)) b) = - case go n (MerkleLog r t b) of + go (SS (n :: Sing n)) m@(MerkleLog r (_ :+: t@(_ :+: _))) = + case go n (MerkleLog r t) of -- FIXME: avoid use of unsafeCoerce -- @@ -688,68 +672,69 @@ hasHeader mlog = case go (sing @N @i) mlog of -- -------------------------------------------------------------------------- -- -- Output MerkleProofs / Netsted Merkle Proof -arbitraryPayloadWithStructuredOutputs :: Gen (V.Vector RequestKey, PayloadWithOutputs) -arbitraryPayloadWithStructuredOutputs = resize 10 $ do - txs <- V.fromList . L.nubBy ((==) `on` _crReqKey . snd) - <$> listOf ((,) <$> arbitrary @Transaction <*> genResult) - payloads <- newPayloadWithOutputs - <$> arbitrary - <*> arbitrary - <*> pure (fmap (TransactionOutput . J.encodeStrict) <$> txs) - return (_crReqKey . snd <$> txs, payloads) - where - genResult = arbitraryCommandResultWithEvents arbitraryProofPactEvent - --- | This creates proof over payloads that contain arbitrary bytestrings. --- -arbitraryOutputMerkleProof - :: forall a - . MerkleHashAlgorithm a - => Gen (MerkleProof a) -arbitraryOutputMerkleProof = do - (p, s) <- genPayload - idx <- choose (0, s - 1) - case outputMerkleProofByIdx @a p idx of - Left e -> error $ "Chainweb.Test.Orphans.Internal.arbitraryBlockOutputsMerkleProof: " <> show e - Right x -> return x - where - -- this uses the default chainweb hash - genPayload = suchThatMap (arbitrary @PayloadWithOutputs) $ \p -> - let s = V.length (_payloadWithOutputsTransactions p) - in (p, s) <$ guard (s > 0) - -arbitraryOutputProof - :: forall a - . MerkleHashAlgorithm a - => Gen (PayloadProof a) -arbitraryOutputProof = do - (ks, p) <- genPayload - k <- elements $ V.toList ks - return $ mkTestOutputProof p k - where - -- this uses the default chainweb hash - genPayload = suchThat arbitraryPayloadWithStructuredOutputs $ \(_, p) -> - V.length (_payloadWithOutputsTransactions p) > 0 - -mkTestOutputProof - :: forall a - . MerkleHashAlgorithm a - => HasCallStack - => PayloadWithOutputs - -> RequestKey - -> PayloadProof a -mkTestOutputProof p reqKey = unsafePerformIO $ createOutputProof_ @a p reqKey - -instance MerkleHashAlgorithm a => Arbitrary (PayloadProof a) where - arbitrary = arbitraryOutputProof - --- | This creates proof over payloads that contain arbitrary bytestrings. --- --- TODO: use a more complex nested proof here, like the ones that occur in --- cross chain SPV proofs. --- -instance MerkleHashAlgorithm a => Arbitrary (MerkleProof a) where - arbitrary = arbitraryOutputMerkleProof +-- arbitraryPayloadWithStructuredOutputs :: Gen (V.Vector RequestKey, PayloadWithOutputs) +-- arbitraryPayloadWithStructuredOutputs = resize 10 $ do +-- txs <- V.fromList . L.nubBy ((==) `on` _crReqKey . snd) +-- <$> listOf ((,) <$> arbitrary @Transaction <*> genResult) +-- payloads <- newPayloadWithOutputs +-- <$> arbitrary +-- <*> arbitrary +-- -- TODO: PP +-- <*> pure (fmap (TransactionOutput . J.encodeStrict . fmap (pactErrorToOnChainError . fmap spanInfoToLineInfo)) <$> txs) +-- return (_crReqKey . snd <$> txs, payloads) +-- where +-- genResult = arbitraryCommandResultWithEvents arbitraryProofPactEvent + +-- -- | This creates proof over payloads that contain arbitrary bytestrings. +-- -- +-- arbitraryOutputMerkleProof +-- :: forall a +-- . MerkleHashAlgorithm a +-- => Gen (MerkleProof a) +-- arbitraryOutputMerkleProof = do +-- (p, s) <- genPayload +-- idx <- choose (0, s - 1) +-- case outputMerkleProofByIdx @a p idx of +-- Left e -> error $ "Chainweb.Test.Orphans.Internal.arbitraryBlockOutputsMerkleProof: " <> show e +-- Right x -> return x +-- where +-- -- this uses the default chainweb hash +-- genPayload = suchThatMap (arbitrary @PayloadWithOutputs) $ \p -> +-- let s = V.length (_payloadWithOutputsTransactions p) +-- in (p, s) <$ guard (s > 0) + +-- arbitraryOutputProof +-- :: forall a +-- . MerkleHashAlgorithm a +-- => Gen (PayloadProof a) +-- arbitraryOutputProof = do +-- (ks, p) <- genPayload +-- k <- elements $ V.toList ks +-- return $ mkTestOutputProof p k +-- where +-- -- this uses the default chainweb hash +-- genPayload = suchThat arbitraryPayloadWithStructuredOutputs $ \(_, p) -> +-- V.length (_payloadWithOutputsTransactions p) > 0 + +-- mkTestOutputProof +-- :: forall a +-- . MerkleHashAlgorithm a +-- => HasCallStack +-- => PayloadWithOutputs +-- -> RequestKey +-- -> PayloadProof a +-- mkTestOutputProof p reqKey = unsafePerformIO $ createOutputProof_ @a p reqKey + +-- instance MerkleHashAlgorithm a => Arbitrary (PayloadProof a) where +-- arbitrary = arbitraryOutputProof + +-- -- | This creates proof over payloads that contain arbitrary bytestrings. +-- -- +-- -- TODO: use a more complex nested proof here, like the ones that occur in +-- -- cross chain SPV proofs. +-- -- +-- instance MerkleHashAlgorithm a => Arbitrary (MerkleProof a) where +-- arbitrary = arbitraryOutputMerkleProof -- -------------------------------------------------------------------------- -- -- Events Merkle Proofs @@ -763,18 +748,18 @@ mkTestEventsProof -> PayloadProof a mkTestEventsProof p reqKey = unsafePerformIO $ createEventsProof_ @a p reqKey -arbitraryEventsProof - :: forall a - . MerkleHashAlgorithm a - => Gen (PayloadProof a) -arbitraryEventsProof = do - (ks, p) <- genPayload - k <- elements $ V.toList ks - return $ mkTestEventsProof p k - where - -- this uses the default chainweb hash - genPayload = suchThat arbitraryPayloadWithStructuredOutputs $ \(_, p) -> - V.length (_payloadWithOutputsTransactions p) > 0 +-- arbitraryEventsProof +-- :: forall a +-- . MerkleHashAlgorithm a +-- => Gen (PayloadProof a) +-- arbitraryEventsProof = do +-- (ks, p) <- genPayload +-- k <- elements $ V.toList ks +-- return $ mkTestEventsProof p k +-- where +-- -- this uses the default chainweb hash +-- genPayload = suchThat arbitraryPayloadWithStructuredOutputs $ \(_, p) -> +-- V.length (_payloadWithOutputsTransactions p) > 0 -- -------------------------------------------------------------------------- -- -- Misc @@ -795,14 +780,6 @@ instance Arbitrary ChainId where instance Arbitrary Fork where arbitrary = elements [minBound..maxBound] -instance Arbitrary ChainDatabaseGcConfig where - arbitrary = elements - [ GcNone - , GcHeaders - , GcHeadersChecked - , GcFull - ] - instance Arbitrary a => Arbitrary (EnableConfig a) where arbitrary = EnableConfig <$> arbitrary <*> arbitrary @@ -837,14 +814,10 @@ instance Arbitrary CoordinationConfig where <$> arbitrary <*> arbitrary <*> arbitrary - <*> arbitrary - <*> arbitrary - <*> arbitrary - <*> arbitrary instance Arbitrary NodeMiningConfig where arbitrary = NodeMiningConfig - <$> arbitrary <*> arbitrary <*> pure (MinerCount 10) + <$> arbitrary <*> pure (MinerCount 10) instance Arbitrary MiningConfig where arbitrary = MiningConfig <$> arbitrary <*> arbitrary @@ -860,26 +833,28 @@ arbitraryEventPactValue = oneof , PLiteral . LInteger . int256ToInteger <$> arbitrary ] --- | Arbitrary Pact events that are supported in events proofs --- -arbitraryProofPactEvent :: Gen PactEvent -arbitraryProofPactEvent = PactEvent - <$> arbitrary - <*> listOf arbitraryEventPactValue - <*> arbitrary - <*> arbitrary +-- -- | Arbitrary Pact events that are supported in events proofs +-- -- +-- arbitraryProofPactEvent :: Gen (PactEvent PactValue) +-- arbitraryProofPactEvent = PactEvent +-- <$> arbitrary +-- <*> listOf arbitraryEventPactValue +-- <*> arbitrary +-- <*> arbitrary -arbitraryOutputEvents :: Gen OutputEvents -arbitraryOutputEvents = OutputEvents - <$> arbitrary - <*> (V.fromList <$> listOf arbitraryProofPactEvent) +-- arbitraryOutputEvents :: Gen OutputEvents +-- arbitraryOutputEvents = OutputEvents +-- <$> arbitrary +-- <*> (V.fromList <$> listOf arbitraryProofPactEvent) -instance Arbitrary OutputEvents where - arbitrary = arbitraryOutputEvents +-- instance Arbitrary OutputEvents where +-- arbitrary = arbitraryOutputEvents -- | Events that are supported in proofs -- -newtype ProofPactEvent = ProofPactEvent { getProofPactEvent :: PactEvent } +newtype ProofPactEvent = ProofPactEvent + { getProofPactEvent :: StableEncoding (PactEvent PactValue) + } deriving (Show) deriving newtype (Eq, FromJSON) @@ -887,8 +862,8 @@ instance ToJSON ProofPactEvent where toJSON = J.toJsonViaEncode . getProofPactEvent {-# INLINEABLE toJSON #-} -instance Arbitrary ProofPactEvent where - arbitrary = ProofPactEvent <$> arbitraryProofPactEvent +-- instance Arbitrary ProofPactEvent where +-- arbitrary = ProofPactEvent . StableEncoding <$> arbitraryProofPactEvent instance MerkleHashAlgorithm a => Arbitrary (BlockEventsHash_ a) where arbitrary = BlockEventsHash <$> arbitrary @@ -899,7 +874,9 @@ instance Arbitrary Int256 where -- | PactValues that are supported in Proofs -- -newtype EventPactValue = EventPactValue { getEventPactValue :: PactValue } +newtype EventPactValue = EventPactValue + { getEventPactValue :: PactValue + } deriving (Show, Eq, Ord) instance Arbitrary EventPactValue where @@ -908,29 +885,26 @@ instance Arbitrary EventPactValue where instance Arbitrary SpvAlgorithm where arbitrary = elements [SpvSHA512t_256, SpvKeccak_256] -instance Arbitrary SpvSubjectIdentifier where - arbitrary = SpvSubjectIdentifier <$> arbitrary <*> arbitrary <*> arbitrary +-- instance Arbitrary SpvSubjectIdentifier where +-- arbitrary = SpvSubjectIdentifier <$> arbitrary <*> arbitrary <*> arbitrary instance Arbitrary SpvSubjectType where arbitrary = elements [SpvSubjectResult, SpvSubjectEvents] -instance Arbitrary SpvRequest where - arbitrary = SpvRequest <$> arbitrary <*> arbitrary +-- instance Arbitrary SpvRequest where +-- arbitrary = SpvRequest <$> arbitrary <*> arbitrary -instance Arbitrary Spv2Request where - arbitrary = Spv2Request <$> arbitrary <*> arbitrary <*> arbitrary +-- instance Arbitrary Spv2Request where +-- arbitrary = Spv2Request <$> arbitrary <*> arbitrary <*> arbitrary -instance Arbitrary (TransactionProof ChainwebMerkleHashAlgorithm) where - arbitrary = TransactionProof <$> arbitrary <*> arbitrary +-- instance Arbitrary (TransactionOutputProof ChainwebMerkleHashAlgorithm) where +-- arbitrary = TransactionOutputProof <$> arbitrary <*> arbitrary -instance Arbitrary (TransactionOutputProof ChainwebMerkleHashAlgorithm) where - arbitrary = TransactionOutputProof <$> arbitrary <*> arbitrary - -instance Arbitrary SomePayloadProof where - arbitrary = oneof - [ SomePayloadProof <$> arbitrary @(PayloadProof ChainwebMerkleHashAlgorithm) - , SomePayloadProof <$> arbitrary @(PayloadProof Keccak_256) - ] +-- instance Arbitrary SomePayloadProof where +-- arbitrary = oneof +-- [ SomePayloadProof <$> arbitrary @(PayloadProof ChainwebMerkleHashAlgorithm) +-- , SomePayloadProof <$> arbitrary @(PayloadProof Keccak256) +-- ] -- Equality for SomePayloadProof is only used for testing. Using 'unsafeCoerce' -- is a bit ugly, but efficient and doesn't require changing production code. @@ -947,11 +921,11 @@ instance Eq SomePayloadProof where instance Arbitrary MinerId where arbitrary = MinerId <$> arbitrary -instance Arbitrary MinerKeys where - arbitrary = MinerKeys <$> arbitrary +-- instance Arbitrary MinerGuard where +-- arbitrary = MinerGuard <$> arbitrary -instance Arbitrary Miner where - arbitrary = Miner <$> arbitrary <*> arbitrary +-- instance Arbitrary Miner where +-- arbitrary = Miner <$> arbitrary <*> arbitrary -- -------------------------------------------------------------------------- -- -- Mempool diff --git a/test/lib/Chainweb/Test/Orphans/Pact.hs b/test/lib/Chainweb/Test/Orphans/Pact.hs deleted file mode 100644 index 5f57055c06..0000000000 --- a/test/lib/Chainweb/Test/Orphans/Pact.hs +++ /dev/null @@ -1,70 +0,0 @@ -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TypeApplications #-} - -{-# OPTIONS_GHC -fno-warn-orphans #-} - --- | --- Module: Chainweb.Test.Orphans.Pact --- Copyright: Copyright © 2021 Kadena LLC. --- License: MIT --- Maintainer: Lars Kuhtz --- Stability: experimental --- --- Orphand Arbitrary Instances for Pact Types --- -module Chainweb.Test.Orphans.Pact -( arbitraryJsonValue -, arbitraryCommandResultWithEvents -, arbitraryMaybe -) where - -import qualified Data.Aeson as A -import qualified Data.Vector as V - -import Pact.Types.Command -import Pact.Types.Runtime - -import Test.QuickCheck - --- -------------------------------------------------------------------------- -- --- - -arbitraryJsonValue :: Gen A.Value -arbitraryJsonValue = go (3 :: Int) - where - go 0 = oneof - [ pure A.Null - , A.String <$> arbitrary - , A.Number <$> arbitrary - ] - go i = oneof - [ A.object <$> listOf ((,) <$> arbitrary <*> go (i - 1)) - , A.Array . V.fromList <$> listOf (go (i - 1)) - , pure A.Null - , A.String <$> arbitrary - , A.Number <$> arbitrary - ] - --- | Generates only successful results without continuations. --- -arbitraryCommandResultWithEvents :: Gen PactEvent -> Gen (CommandResult Hash) -arbitraryCommandResultWithEvents genEvent = CommandResult - <$> arbitrary -- _crReqKey - <*> arbitrary -- _crTxId - <*> arbitrary -- _crResult - <*> arbitrary -- _crGas - <*> arbitrary -- _crLogs - <*> pure Nothing -- _crContinuation - <*> arbitraryMaybe (resize 5 arbitraryJsonValue) -- _crMetaData - <*> (resize 10 (listOf genEvent)) -- _crEvents - -arbitraryMaybe :: Gen a -> Gen (Maybe a) -arbitraryMaybe gen = arbitrary >>= mapM (const @_ @() gen) - diff --git a/test/lib/Chainweb/Test/Pact5/CmdBuilder.hs b/test/lib/Chainweb/Test/Pact/CmdBuilder.hs similarity index 79% rename from test/lib/Chainweb/Test/Pact5/CmdBuilder.hs rename to test/lib/Chainweb/Test/Pact/CmdBuilder.hs index ded0c3b26f..f8e5355fb7 100644 --- a/test/lib/Chainweb/Test/Pact5/CmdBuilder.hs +++ b/test/lib/Chainweb/Test/Pact/CmdBuilder.hs @@ -17,16 +17,15 @@ {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE PatternSynonyms #-} -module Chainweb.Test.Pact5.CmdBuilder where +module Chainweb.Test.Pact.CmdBuilder where -import Pact.Types.ChainMeta qualified as Pact4 -import Pact.Types.Command qualified as Pact4 -import Pact.JSON.Legacy.Value qualified as J -import Chainweb.Pact4.Transaction qualified as Pact4 +-- import Pact.JSON.Legacy.Value qualified as J import Control.Lens hiding ((.=)) import Pact.Core.Command.Types import Data.Text (Text) import GHC.Generics +import GHC.Stack +import Pact.Core.Capabilities import Pact.Core.Guards import Pact.Core.Command.RPC import Pact.Core.ChainData @@ -34,10 +33,10 @@ import Pact.Core.Gas.Types import Control.Exception.Safe import Control.Monad.IO.Class import Chainweb.Time -import Chainweb.Version +import Chainweb.Version hiding (ChainId) import qualified Chainweb.ChainId as Chainweb import Data.ByteString (ByteString) -import qualified Chainweb.Pact5.Transaction as Pact5 +import qualified Chainweb.Pact.Transaction as Pact import qualified Data.Text.Encoding as T import Chainweb.Utils import Data.Maybe @@ -45,15 +44,17 @@ import Pact.Core.Command.Crypto import Pact.Core.Command.Util import qualified Data.Text as T import Pact.Core.Names (Field(..)) -import Pact.Core.PactValue (pattern PString) +import Pact.Core.PactValue (PactValue(..), pattern PString) import qualified Data.Set as Set -import Chainweb.Pact.RestAPI.Server (validatePact5Command) -import Pact.Core.Command.Client (ApiKeyPair (..), mkCommandWithDynKeys, PactValue(..)) +import Pact.Core.StableEncoding +import Chainweb.Pact.RestAPI.Server (validateCommand) +import Pact.Core.Command.Client (ApiKeyPair (..), mkCommandWithDynKeys) +import Pact.Core.ChainData qualified as Pact import System.Random import Control.Monad import Data.Vector qualified as Vector import Data.Map.Strict qualified as Map -import Data.Aeson qualified as Aeson +-- import Data.Aeson qualified as Aeson type TextKeyPair = (Text,Text) @@ -175,7 +176,7 @@ defaultCmd cid = CmdBuilder , _cbVerifiers = [] , _cbRPC = mkExec' "1" , _cbNonce = Nothing - , _cbChainId = chainIdToText cid + , _cbChainId = toText cid , _cbSender = "sender00" , _cbGasLimit = GasLimit (Gas 10_000) , _cbGasPrice = GasPrice 0.000_1 @@ -185,38 +186,28 @@ defaultCmd cid = CmdBuilder -- | Build parsed + verified Pact command -- TODO: Use the new `assertPact4Command` function. -buildCwCmd :: (MonadThrow m, MonadIO m) => ChainwebVersion -> CmdBuilder -> m Pact5.Transaction -buildCwCmd v cmd = buildTextCmd v cmd >>= \(c :: Command Text) -> - case validatePact5Command v c of - Left err -> throwM $ userError $ "buildCwCmd failed: " ++ err +buildCwCmd :: (HasCallStack, HasVersion, MonadThrow m, MonadIO m) => CmdBuilder -> m Pact.Transaction +buildCwCmd cmd = buildTextCmd cmd >>= \(c :: Command Text) -> + case validateCommand c of + Left err -> error $ "buildCwCmd failed: " ++ err Right cmd' -> return cmd' --- | Build a Pact4 command without parsing it. This can be useful for inserting txs directly into the mempool for testing. -buildCwCmdNoParse :: forall m. (MonadThrow m, MonadIO m) => ChainwebVersion -> CmdBuilder -> m Pact4.UnparsedTransaction -buildCwCmdNoParse v cmd = do - cmd5 <- buildTextCmd v cmd - cmd4 <- case Aeson.fromJSON @(Pact4.Command Text) $ J._getLegacyValue $ J.toLegacyJsonViaEncode cmd5 of - Aeson.Error e -> throwM $ userError $ "buildCwCmdNoParse failed: " ++ e - Aeson.Success c -> return c - - let decodePayload :: ByteString -> m (Pact4.Payload Pact4.PublicMeta Text) - decodePayload bs = case Aeson.eitherDecodeStrict' bs of - Left err -> throwM $ userError $ "buildCwCmdNoParse failed to decode json payload: " ++ err - Right payload -> return payload - - let payloadBytes = T.encodeUtf8 $ Pact4._cmdPayload cmd4 - payload <- decodePayload payloadBytes - return $ Pact4.mkPayloadWithText $ fmap (\_ -> (payloadBytes, payload)) cmd4 +-- | Build parsed, not verified Pact command +buildCwCmdNoSigCheck :: (HasCallStack, HasVersion, MonadThrow m, MonadIO m) => CmdBuilder -> m Pact.Transaction +buildCwCmdNoSigCheck cmd = buildTextCmd cmd >>= \(cmdText :: Command Text) -> + case Pact.parseCommand cmdText of + Left err -> error $ "buildCwCmd failed: " ++ sshow err + Right parsedCmd -> return parsedCmd -- | Build unparsed, unverified command -- -buildTextCmd :: (MonadThrow m, MonadIO m) => ChainwebVersion -> CmdBuilder -> m (Command Text) -buildTextCmd v = fmap (fmap T.decodeUtf8) . buildRawCmd v +buildTextCmd :: (MonadThrow m, MonadIO m, HasVersion) => CmdBuilder -> m (Command Text) +buildTextCmd = fmap (fmap T.decodeUtf8) . buildRawCmd -- | Build a raw bytestring command -- -buildRawCmd :: (MonadThrow m, MonadIO m) => ChainwebVersion -> CmdBuilder -> m (Command ByteString) -buildRawCmd v CmdBuilder{..} = do +buildRawCmd :: (MonadThrow m, MonadIO m, HasVersion) => CmdBuilder -> m (Command ByteString) +buildRawCmd CmdBuilder{..} = do kps <- liftIO $ traverse mkDynKeyPairs _cbSigners nonce <- liftIO $ maybe (fmap T.pack $ replicateM 10 $ randomRIO ('a', 'z')) return _cbNonce creationTime <- liftIO $ do @@ -237,8 +228,8 @@ buildRawCmd v CmdBuilder{..} = do cmd <- liftIO $ mkCommandWithDynKeys kps _cbVerifiers (StableEncoding pm) nonce (Just nid) _cbRPC pure cmd where - nid = NetworkId (sshow v) - cid = ChainId _cbChainId + nid = NetworkId (sshow implicitVersion) + cid = Pact.ChainId _cbChainId dieL :: MonadThrow m => [Char] -> Either [Char] a -> m a dieL msg = either (\s -> throwM $ userError $ msg ++ ": " ++ s) return diff --git a/test/lib/Chainweb/Test/Pact/Utils.hs b/test/lib/Chainweb/Test/Pact/Utils.hs new file mode 100644 index 0000000000..48ebdc76d0 --- /dev/null +++ b/test/lib/Chainweb/Test/Pact/Utils.hs @@ -0,0 +1,137 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NumericUnderscores #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PackageImports #-} +{-# LANGUAGE TypeApplications #-} + +module Chainweb.Test.Pact.Utils +( +-- * Logging + getTestLogLevel +, testLogFn +, getTestLogger + +-- * Resources +, withMempool +, withBlockDbs + +-- * Properties +, event +, successfulTx + +-- * Utilities +, coinModuleName +) +where + +import Chainweb.Chainweb (validatingMempoolConfig) +import Chainweb.ChainId +import Chainweb.Logger +import Chainweb.Pact.Mempool.InMem +import Chainweb.Pact.Mempool.Mempool (MempoolBackend (..)) +import Chainweb.Pact.PactService +import Chainweb.Pact.Payload.PayloadStore +import Chainweb.Pact.Payload.PayloadStore.RocksDB +import Chainweb.Pact.Transaction qualified as Pact +import Chainweb.Pact.Types +import Chainweb.Storage.Table.RocksDB +import Chainweb.Version +import Chainweb.WebBlockHeaderDB +import Control.Monad.IO.Class +import Control.Monad.Trans.Resource (ResourceT) +import Data.Maybe (fromMaybe) +import Data.Text (Text) +import Data.Text qualified as Text +import Data.Text.IO qualified as Text +import Pact.Core.Capabilities +import Pact.Core.Command.Types qualified as Pact +import Pact.Core.Gas qualified as Pact +import Pact.Core.Names +import Pact.Core.PactValue +import PropertyMatchers ((?)) +import PropertyMatchers qualified as P +import System.Environment (lookupEnv) +import System.LogLevel + +withBlockDbs :: HasVersion => RocksDb -> ResourceT IO (PayloadDb RocksDbTable, WebBlockHeaderDb) +withBlockDbs rdb = do + webBHDb <- liftIO $ initWebBlockHeaderDb rdb + let payloadDb = newPayloadDb rdb + return (payloadDb, webBHDb) + +withMempool + :: (Logger logger) + => HasVersion + => logger + -> ServiceEnv tbl + -> ResourceT IO (MempoolBackend Pact.Transaction) +withMempool logger pact = do + let mempoolCfg = validatingMempoolConfig + (_chainId pact) + (Pact.GasLimit $ Pact.Gas 150_000) (Pact.GasPrice 1e-8) + (execPreInsertCheckReq logger pact) + liftIO $ startInMemoryMempoolTest mempoolCfg + +-- withRunPactService :: (Logger logger) +-- => logger +-- -> ChainwebVersion +-- -> ChainId +-- -> MempoolBackend Pact.Transaction +-- -> WebBlockHeaderDb +-- -> PayloadDb RocksDbTable +-- -> PactServiceConfig +-- -> ResourceT IO () +-- withRunPactService logger v cid mempool webBHDb payloadDb pactServiceConfig = do +-- sqlite <- withTempSQLiteResource +-- blockHeaderDb <- liftIO $ getWebBlockHeaderDb webBHDb cid +-- mempoolConsensus <- liftIO $ mkMempoolConsensus mempool blockHeaderDb (Just payloadDb) +-- let mempoolAccess = pactMemPoolAccess mempoolConsensus logger + +-- void $ Resource.allocate +-- (forkIO $ runPactService v cid logger Nothing pactQueue mempoolAccess blockHeaderDb payloadDb sqlite pactServiceConfig) --bhdb (_bdbPayloadDb tdb) sqlite pactServiceConfig) +-- (\tid -> throwTo tid ThreadKilled) + +getTestLogLevel :: IO LogLevel +getTestLogLevel = do + let parseLogLevel txt = case Text.toUpper txt of + "DEBUG" -> Debug + "INFO" -> Info + "WARN" -> Warn + "ERROR" -> Error + _ -> Error + fromMaybe Error . fmap (parseLogLevel . Text.pack) <$> lookupEnv "CHAINWEB_TEST_LOG_LEVEL" + +-- | Generally, we want tests to throw an exception on an Error log, but we don't want +-- to throw an exception on any other level of log. +testLogFn :: LogLevel -> Text -> IO () +testLogFn ll msg = case ll of + Error -> do + error (Text.unpack msg) + _ -> do + Text.putStrLn msg + +getTestLogger :: IO GenericLogger +getTestLogger = do + logLevel <- getTestLogLevel + return $ genericLogger logLevel (testLogFn logLevel) + +-- usually we don't want to check the module hash +event + :: P.Prop Text + -> P.Prop [PactValue] + -> P.Prop ModuleName + -> P.Prop (PactEvent PactValue) +event n args modName = P.checkAll + [ P.fun _peName n + , P.fun _peArgs args + , P.fun _peModule modName + ] + +coinModuleName :: ModuleName +coinModuleName = ModuleName "coin" Nothing + +successfulTx :: P.Prop (Pact.CommandResult log err) +successfulTx = P.fun Pact._crResult ? P.match Pact._PactResultOk P.succeed diff --git a/test/lib/Chainweb/Test/Pact4/Utils.hs b/test/lib/Chainweb/Test/Pact4/Utils.hs index cbce23610d..d2dc2d7ce7 100644 --- a/test/lib/Chainweb/Test/Pact4/Utils.hs +++ b/test/lib/Chainweb/Test/Pact4/Utils.hs @@ -1,22 +1,21 @@ -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE ImportQualifiedPost #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE NumericUnderscores #-} {-# LANGUAGE OverloadedRecordDot #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ImportQualifiedPost #-} -{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE ViewPatterns #-} -{-# LANGUAGE DataKinds #-} {-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns #-} -- | @@ -62,7 +61,6 @@ module Chainweb.Test.Pact4.Utils , mkXChainTransferCap -- * Command builder , defaultCmd -, buildCwCmd , buildTextCmd , mkExec' , mkExec @@ -87,27 +85,12 @@ module Chainweb.Test.Pact4.Utils , CmdSigner , csSigner , csPrivKey --- * Pact Service creation -, withPactTestBlockDb -, withPactTestBlockDb' -, withWebPactExecutionService -, withWebPactExecutionServiceCompaction -, withPactCtxSQLite -, WithPactCtxSQLite -- * Other service creation , initializeSQLite , freeSQLiteResource -, freeGasModel -, testPactServiceConfig , withBlockHeaderDb , withSqliteDb --- * Mempool utils -, delegateMemPoolAccess -, withDelegateMempool -, setMempool -, setOneShotMempool -- * Block formation -, runCut , Noncer , zeroNoncer -- * Pact State @@ -125,52 +108,36 @@ module Chainweb.Test.Pact4.Utils , someBlockHeader , testPactFilesDir , getPWOByHeader -, throwIfNotPact4 ) where -import Control.Arrow ((&&&)) -import Control.Concurrent.Async -import Control.Concurrent.MVar + import Control.Lens hiding ((.=)) import Control.Monad import Control.Monad.Catch import Control.Monad.IO.Class - import Data.Aeson (Value(..), object, (.=), Key) import Data.ByteString (ByteString) -import qualified Data.ByteString.Short as BS +import Data.ByteString.Short qualified as BS import Data.Decimal -import Data.Foldable -import qualified Data.HashMap.Strict as HM -import Data.IORef import Data.List qualified as List import Data.Map (Map) -import qualified Data.Map.Strict as M +import Data.Map.Strict qualified as M import Data.Maybe import Data.Text (Text) -import qualified Data.Text as T -import qualified Data.Text.Encoding as T +import Data.Text qualified as T +import Data.Text.Encoding qualified as T import Data.String -import qualified Data.Vector as V - +import Data.Vector qualified as V import Database.SQLite3.Direct (Database) - import GHC.Generics - import Streaming.Prelude qualified as S import System.LogLevel - import Test.Tasty -import Test.Tasty.HUnit(assertFailure) - --- internal pact modules - import Pact.ApiReq (ApiKeyPair(..), mkKeyPairs) -import Pact.Gas import Pact.JSON.Legacy.Value import Pact.Types.Capability -import qualified Pact.Types.ChainId as P +import Pact.Types.ChainId qualified as P import Pact.Types.ChainMeta import Pact.Types.Command import Pact.Types.Crypto @@ -179,7 +146,7 @@ import Pact.Types.Gas import Pact.Types.Hash import Pact.Types.Info (noInfo) import Pact.Types.KeySet -import qualified Pact.Types.Logger as P +import Pact.Types.Logger qualified as P import Pact.Types.Names import Pact.Types.PactValue import Pact.Types.RPC @@ -187,46 +154,31 @@ import Pact.Types.Runtime (PactEvent(..)) import Pact.Types.Term import Pact.Types.Util (parseB16TextOnly) import Pact.Types.Verifier - --- internal modules - import Chainweb.BlockHeader import Chainweb.BlockHeaderDB hiding (withBlockHeaderDb) import Chainweb.BlockHeight import Chainweb.ChainId import Chainweb.Graph import Chainweb.Logger -import Chainweb.Miner.Pact import Chainweb.Pact.Backend.Compaction qualified as Sigma import Chainweb.Pact.Backend.PactState qualified as PactState import Chainweb.Pact.Backend.PactState (TableDiffable(..), Table(..), PactRow(..)) -import Chainweb.Pact.PactService.Checkpointer.Internal (initCheckpointerResources) import Chainweb.Pact.Backend.SQLite.DirectV2 - import Chainweb.Pact.Backend.Utils hiding (tbl, withSqliteDb) -import Chainweb.Pact.PactService -import Chainweb.Pact.RestAPI.Server (validateCommand) -import Chainweb.Pact.Service.PactQueue -import Chainweb.Pact.Types import Chainweb.Pact4.Types -import Chainweb.Payload -import Chainweb.Payload.PayloadStore -import Chainweb.Test.Cut +import Chainweb.Pact.Payload +import Chainweb.Pact.Payload.PayloadStore import Chainweb.Test.Cut.TestBlockDb import Chainweb.Test.Utils import Chainweb.Test.Utils.BlockHeader import Chainweb.Test.TestVersions import Chainweb.Time -import qualified Chainweb.Pact4.Transaction as Pact4 import Chainweb.Utils -import Chainweb.Version (ChainwebVersion(..), chainIds) -import qualified Chainweb.Version as Version -import Chainweb.Version.Utils (someChainId) -import Chainweb.WebBlockHeaderDB -import Chainweb.WebPactExecutionService - -import Chainweb.Storage.Table.RocksDB +import Chainweb.Version (ChainwebVersion(..)) +import Chainweb.Version qualified as Version import Chainweb.Pact.Backend.Types +import Chainweb.Parent +import Chainweb.Storage.Table.RocksDB -- ----------------------------------------------------------------------- -- -- Keys @@ -451,7 +403,7 @@ mkXResumeEvent sender receiver amount ks mn mh tid sid -- | Cap smart constructor. mkCapability :: ModuleName -> Text -> [PactValue] -> SigCapability -mkCapability mn cap args = SigCapability (QualifiedName mn cap noInfo) args +mkCapability mn cap args = SigCapability (QualifiedName mn cap Pact.Types.Info.noInfo) args -- | Convenience to make caps like TRANSFER, GAS etc. mkCoinCap :: Text -> [PactValue] -> SigCapability @@ -566,29 +518,20 @@ defaultCmd = CmdBuilder , _cbCreationTime = 0 -- epoch } --- | Build parsed + verified Pact command --- --- TODO: Use the new `assertPact4Command` function. -buildCwCmd :: (MonadThrow m, MonadIO m) => Text -> ChainwebVersion -> CmdBuilder -> m Pact4.Transaction -buildCwCmd nonce v cmd = buildRawCmd nonce v cmd >>= \(c :: Command ByteString) -> - case validateCommand v (_cbChainId cmd) (T.decodeUtf8 <$> c) of - Left err -> throwM $ userError $ "buildCmd failed: " ++ T.unpack err - Right cmd' -> return cmd' - -- | Build unparsed, unverified command -- -buildTextCmd :: Text -> ChainwebVersion -> CmdBuilder -> IO (Command Text) -buildTextCmd nonce v = fmap (fmap T.decodeUtf8) . buildRawCmd nonce v +buildTextCmd :: Version.HasVersion => Text -> CmdBuilder -> IO (Command Text) +buildTextCmd nonce = fmap (fmap T.decodeUtf8) . buildRawCmd nonce -- | Build a raw bytestring command -- -buildRawCmd :: (MonadThrow m, MonadIO m) => Text -> ChainwebVersion -> CmdBuilder -> m (Command ByteString) -buildRawCmd nonce v (set cbNonce nonce -> CmdBuilder{..}) = do +buildRawCmd :: (MonadThrow m, MonadIO m) => Version.HasVersion => Text -> CmdBuilder -> m (Command ByteString) +buildRawCmd nonce (set cbNonce nonce -> CmdBuilder{..}) = do kps <- liftIO $ traverse mkDynKeyPairs _cbSigners cmd <- liftIO $ mkCommandWithDynKeys kps _cbVerifiers pm _cbNonce (Just nid) _cbRPC pure cmd where - nid = P.NetworkId (sshow v) + nid = P.NetworkId (sshow Version.implicitVersion) cid = fromString $ show (chainIdInt _cbChainId :: Int) pm = PublicMeta cid _cbSender _cbGasLimit _cbGasPrice _cbTTL _cbCreationTime @@ -643,218 +586,14 @@ pactTestLogger backend showAll = P.initLoggers backend f (P.LogRules mempty) f _ b "DDL" d | not showAll = P.doLog (\_ -> return ()) b "DDL" d f a b c d = P.doLog a b c d --- | Test Pact Execution Context for running inside 'PactServiceM'. --- Only used internally. -data TestPactCtx logger tbl = TestPactCtx - { _testPactCtxState :: !(MVar PactServiceState) - , _testPactCtxEnv :: !(PactServiceEnv logger tbl) - } - -evalPactServiceM_ :: TestPactCtx logger tbl -> PactServiceM logger tbl a -> IO a -evalPactServiceM_ ctx pact = modifyMVar (_testPactCtxState ctx) $ \s -> do - T2 a s' <- runPactServiceM s (_testPactCtxEnv ctx) pact - return (s',a) - -destroyTestPactCtx :: TestPactCtx logger tbl -> IO () -destroyTestPactCtx = void . takeMVar . _testPactCtxState - --- | setup TestPactCtx, internal function. --- Use 'withPactCtxSQLite' in tests. -testPactCtxSQLite - :: forall logger tbl. (Logger logger, CanReadablePayloadCas tbl) - => logger - -> ChainwebVersion - -> Version.ChainId - -> BlockHeaderDb - -> PayloadDb tbl - -> SQLiteEnv - -> PactServiceConfig - -> IO (TestPactCtx logger tbl) -testPactCtxSQLite logger v cid bhdb pdb sqlenv conf = do - cp <- initCheckpointerResources defaultModuleCacheLimit sqlenv DoNotPersistIntraBlockWrites cpLogger v cid - let rs = readRewards - !ctx <- TestPactCtx - <$!> newMVar (PactServiceState mempty) - <*> pure (mkPactServiceEnv cp rs) - evalPactServiceM_ ctx (initialPayloadState v cid) - return ctx - where - cpLogger = addLabel ("chain-id", chainIdToText cid) $ addLabel ("sub-component", "checkpointer") $ logger - mkPactServiceEnv :: Checkpointer logger -> MinerRewards -> PactServiceEnv logger tbl - mkPactServiceEnv cp rs = PactServiceEnv - { _psMempoolAccess = Nothing - , _psCheckpointer = cp - , _psPdb = pdb - , _psBlockHeaderDb = bhdb - , _psMinerRewards = rs - , _psReorgLimit = _pactReorgLimit conf - , _psPreInsertCheckTimeout = _pactPreInsertCheckTimeout conf - , _psOnFatalError = defaultOnFatalError mempty - , _psVersion = v - , _psAllowReadsInLocal = _pactAllowReadsInLocal conf - , _psLogger = addLabel ("chain-id", chainIdToText cid) $ addLabel ("component", "pact") $ logger - , _psGasLogger = do - guard (_pactLogGas conf) - return - $ addLabel ("chain-id", chainIdToText cid) - $ addLabel ("component", "pact") - $ addLabel ("sub-component", "gas") - $ logger - - , _psBlockGasLimit = _pactNewBlockGasLimit conf - , _psEnableLocalTimeout = False - , _psTxFailuresCounter = Nothing - , _psTxTimeLimit = _pactTxTimeLimit conf - } - -freeGasModel :: TxContext -> GasModel -freeGasModel = const $ constGasModel 0 - ---- | A queue-less WebPactExecutionService (for all chains) ---- with direct chain access map for local. -withWebPactExecutionServiceCompaction - :: (Logger logger) - => logger - -> ChainwebVersion - -> PactServiceConfig - -> TestBlockDb - -> ChainMap MemPoolAccess - -> ((WebPactExecutionService, HM.HashMap ChainId (SQLiteEnv, PactExecutionService), WebPactExecutionService, HM.HashMap ChainId (SQLiteEnv, PactExecutionService)) -> IO a) -- TODO: second 'WebPactExecutionService' seems unnecessary? - -> IO a -withWebPactExecutionServiceCompaction logger v pactConfig bdb mempools act = - withDbs $ \srcSqlEnvs -> - withDbs $ \targetSqlEnvs -> do - srcPacts <- mkPacts srcSqlEnvs - let srcWeb = mkWebPactExecutionService (snd <$> srcPacts) - - targetPacts <- mkPacts targetSqlEnvs - let targetWeb = mkWebPactExecutionService (snd <$> targetPacts) - - act (srcWeb, srcPacts, targetWeb, targetPacts) - where - mkPacts :: [SQLiteEnv] -> IO (HM.HashMap ChainId (SQLiteEnv, PactExecutionService)) - mkPacts sqlEnvs = fmap HM.fromList - $ traverse (\(dbEnv, cid) -> (cid,) . (dbEnv,) <$> mkTestPactExecutionService dbEnv cid) - $ zip sqlEnvs - $ toList - $ chainIds v - - withDbs :: ([SQLiteEnv] -> IO x) -> IO x - withDbs f = foldl' (\soFar _ -> withDb soFar) f (chainIds v) [] - - withDb :: ([SQLiteEnv] -> IO x) -> [SQLiteEnv] -> IO x - withDb g envs = withTempSQLiteConnection chainwebPragmas $ \s -> g (s : envs) - - mkTestPactExecutionService :: () - => SQLiteEnv - -> ChainId - -> IO PactExecutionService - mkTestPactExecutionService sqlenv c = do - bhdb <- getBlockHeaderDb c bdb - ctx <- testPactCtxSQLite logger v c bhdb (_bdbPayloadDb bdb) sqlenv pactConfig - return $ PactExecutionService - { _pactNewBlock = \_ m fill ph -> - evalPactServiceM_ ctx $ fmap NewBlockInProgress <$> execNewBlock (mempools ^?! atChain c) m fill ph - , _pactContinueBlock = \_ bip -> - evalPactServiceM_ ctx $ execContinueBlock (mempools ^?! atChain c) bip - , _pactValidateBlock = \h d -> - evalPactServiceM_ ctx $ fst <$> execValidateBlock (mempools ^?! atChain c) h d - , _pactLocal = \pf sv rd cmd -> - evalPactServiceM_ ctx $ execLocal cmd pf sv rd - , _pactLookup = \_cid cd hashes -> - evalPactServiceM_ ctx $ execLookupPactTxs cd hashes - , _pactPreInsertCheck = \_ txs -> - evalPactServiceM_ ctx $ V.map (\_ -> Nothing) <$> execPreInsertCheckReq txs - , _pactBlockTxHistory = \h d -> - evalPactServiceM_ ctx $ execBlockTxHistory h d - , _pactHistoricalLookup = \h d k -> - evalPactServiceM_ ctx $ execHistoricalLookup h d k - , _pactSyncToBlock = \h -> - evalPactServiceM_ ctx $ execSyncToBlock h - , _pactReadOnlyReplay = \l u -> - evalPactServiceM_ ctx $ execReadOnlyReplay l u - } - --- | A queue-less WebPactExecutionService (for all chains) --- with direct chain access map for local. -withWebPactExecutionService - :: (Logger logger) - => logger - -> ChainwebVersion - -> PactServiceConfig - -> TestBlockDb - -> ChainMap MemPoolAccess - -> ((WebPactExecutionService,HM.HashMap ChainId (SQLiteEnv, PactExecutionService)) -> IO a) - -> IO a -withWebPactExecutionService logger v pactConfig bdb mempools act = - withDbs $ \sqlenvs -> do - pacts <- fmap HM.fromList - $ traverse (\(dbEnv, cid) -> (cid,) . (dbEnv,) <$> mkPact dbEnv cid) - $ zip sqlenvs - $ toList - $ chainIds v - act (mkWebPactExecutionService (snd <$> pacts), pacts) - where - withDbs f = foldl' (\soFar _ -> withDb soFar) f (chainIds v) [] - withDb g envs = withTempSQLiteConnection chainwebPragmas $ \s -> g (s : envs) - - mkPact :: SQLiteEnv -> ChainId -> IO PactExecutionService - mkPact sqlenv c = do - bhdb <- getBlockHeaderDb c bdb - ctx <- testPactCtxSQLite logger v c bhdb (_bdbPayloadDb bdb) sqlenv pactConfig - return $ PactExecutionService - { _pactNewBlock = \_ m fill ph -> - evalPactServiceM_ ctx $ fmap NewBlockInProgress <$> execNewBlock (mempools ^?! atChain c) m fill ph - , _pactContinueBlock = \_ bip -> - evalPactServiceM_ ctx $ execContinueBlock (mempools ^?! atChain c) bip - , _pactValidateBlock = \h d -> - evalPactServiceM_ ctx $ fst <$> execValidateBlock (mempools ^?! atChain c) h d - , _pactLocal = \pf sv rd cmd -> - evalPactServiceM_ ctx $ execLocal cmd pf sv rd - , _pactLookup = \_cid cd hashes -> - evalPactServiceM_ ctx $ execLookupPactTxs cd hashes - , _pactPreInsertCheck = \_ txs -> - evalPactServiceM_ ctx $ V.map (\_ -> Nothing) <$> execPreInsertCheckReq txs - , _pactBlockTxHistory = \h d -> - evalPactServiceM_ ctx $ execBlockTxHistory h d - , _pactHistoricalLookup = \h d k -> - evalPactServiceM_ ctx $ execHistoricalLookup h d k - , _pactSyncToBlock = \h -> - evalPactServiceM_ ctx $ execSyncToBlock h - , _pactReadOnlyReplay = \l u -> - evalPactServiceM_ ctx $ execReadOnlyReplay l u - } - -- | Noncer for 'runCut' type Noncer = ChainId -> IO Nonce zeroNoncer :: Noncer zeroNoncer = const (return $ Nonce 0) --- | Populate blocks for every chain of the current cut. Uses provided pact --- service to produce a new block, add it to dbs, etc. -runCut - :: ChainwebVersion - -> TestBlockDb - -> WebPactExecutionService - -> GenBlockTime - -> Noncer - -> Miner - -> IO () -runCut v bdb pact genTime noncer miner = - forM_ (chainIds v) $ \cid -> do - ph <- ParentHeader <$> getParentTestBlockDb bdb cid - !newBlock <- throwIfNoHistory =<< _webPactNewBlock pact cid miner NewBlockFill ph - let pout = newBlockToPayloadWithOutputs newBlock - n <- noncer cid - - -- skip this chain if mining fails and retry with the next chain. - whenM (addTestBlockDb bdb (succ $ view blockHeight $ _parentHeader ph) n genTime cid pout) $ do - h <- getParentTestBlockDb bdb cid - void $ _webPactValidateBlock pact h (CheckablePayloadWithOutputs pout) - initializeSQLite :: IO SQLiteEnv -initializeSQLite = open2 file >>= \case +initializeSQLite = open2 file [] >>= \case Left (_err, _msg) -> internalError "initializeSQLite: A connection could not be opened." Right r -> return r @@ -864,76 +603,12 @@ initializeSQLite = open2 file >>= \case freeSQLiteResource :: SQLiteEnv -> IO () freeSQLiteResource sqlenv = void $ close_v2 sqlenv -type WithPactCtxSQLite logger tbl = forall a . PactServiceM logger tbl a -> IO a - --- | Used to run 'PactServiceM' functions directly on a database (ie not use checkpointer). -withPactCtxSQLite - :: (Logger logger, CanReadablePayloadCas tbl) - => logger - -> ChainwebVersion - -> IO BlockHeaderDb - -> IO (PayloadDb tbl) - -> PactServiceConfig - -> (WithPactCtxSQLite logger tbl -> TestTree) - -> TestTree -withPactCtxSQLite logger v bhdbIO pdbIO conf f = - withResource - initializeSQLite - freeSQLiteResource $ \io -> - withResource (start io) destroy $ \ctxIO -> f $ \toPact -> do - ctx <- ctxIO - evalPactServiceM_ ctx toPact - where - destroy = destroyTestPactCtx - cid = someChainId v - start ios = do - bhdb <- bhdbIO - pdb <- pdbIO - s <- ios - testPactCtxSQLite logger v cid bhdb pdb s conf - toTxCreationTime :: Integral a => Time a -> TxCreationTime toTxCreationTime (Time timespan) = TxCreationTime $ fromIntegral $ timeSpanToSeconds timespan --- | 'MemPoolAccess' that delegates all calls to the contents of provided `IORef`. -delegateMemPoolAccess :: IORef MemPoolAccess -> MemPoolAccess -delegateMemPoolAccess r = MemPoolAccess - { mpaGetBlock = \a b c d e -> call mpaGetBlock $ \f -> f a b c d e - , mpaSetLastHeader = \a -> call mpaSetLastHeader ($ a) - , mpaProcessFork = \a -> call mpaProcessFork ($ a) - , mpaBadlistTx = \a -> call mpaBadlistTx ($ a) - } - where - call :: (MemPoolAccess -> f) -> (f -> IO a) -> IO a - call f g = readIORef r >>= g . f - --- | use a "delegate" which you can dynamically reset/modify. --- Returns the updateable 'IORef MemPoolAccess` for use --- in tests, and the plain 'MemPoolAccess' for initializing --- PactService etc. -withDelegateMempool - :: (IO (IORef MemPoolAccess, MemPoolAccess) -> TestTree) - -> TestTree -withDelegateMempool = withResource' start - where - start = (id &&& delegateMemPoolAccess) <$> newIORef mempty - --- | Set test mempool using IORef. -setMempool :: MonadIO m => IO (IORef MemPoolAccess) -> MemPoolAccess -> m () -setMempool refIO mp = liftIO (refIO >>= flip writeIORef mp) - --- | Set test mempool wrapped with a "one shot" 'mpaGetBlock' adapter. -setOneShotMempool :: MonadIO m => IO (IORef MemPoolAccess) -> MemPoolAccess -> m () -setOneShotMempool mpRefIO mp = do - oneShot <- liftIO $ newIORef False - setMempool mpRefIO $ mp - { mpaGetBlock = \g v i a e -> readIORef oneShot >>= \case - False -> writeIORef oneShot True >> mpaGetBlock mp g v i a e - True -> mempty - } - withBlockHeaderDb - :: IO RocksDb + :: Version.HasVersion + => IO RocksDb -> BlockHeader -> (IO BlockHeaderDb -> TestTree) -> TestTree @@ -944,46 +619,6 @@ withBlockHeaderDb iordb b = withResource start stop testBlockHeaderDb rdb b stop = closeBlockHeaderDb --- | Single-chain Pact via service queue. --- --- The difference between this and 'withPactTestBlockDb' is that, --- this function takes a `SQLiteEnv` resource which it then exposes --- to the test function. --- --- TODO: Consolidate these two functions. -withPactTestBlockDb' - :: ChainwebVersion - -> ChainId - -> RocksDb - -> IO SQLiteEnv - -> IO MemPoolAccess - -> PactServiceConfig - -> (IO (SQLiteEnv,PactQueue,TestBlockDb) -> TestTree) - -> TestTree -withPactTestBlockDb' version cid rdb sqlEnvIO mempoolIO pactConfig f = - withResourceT (mkTestBlockDb version rdb) $ \bdbio -> - withResource (startPact bdbio) stopPact $ f . fmap (view _2) - where - startPact bdbio = do - reqQ <- newPactQueue 2000 - bdb <- bdbio - sqlEnv <- sqlEnvIO - mempool <- mempoolIO - bhdb <- getWebBlockHeaderDb (_bdbWebBlockHeaderDb bdb) cid - let pdb = _bdbPayloadDb bdb - a <- async $ runForever (\_ _ -> return ()) "Chainweb.Test.Pact4.Utils.withPactTestBlockDb" $ - runPactService version cid logger Nothing reqQ mempool bhdb pdb sqlEnv pactConfig - return (a, (sqlEnv,reqQ,bdb)) - - stopPact (a, _) = cancel a - - -- Ideally, we should throw 'error' when the logger is invoked, because - -- error logs should not happen in production and should always be resolved. - -- Unfortunately, that's not yet always the case. So we just drop the - -- message. - -- - logger = genericLogger Error (\_ -> return ()) - withSqliteDb :: () => ChainId -> IO FilePath @@ -1005,41 +640,6 @@ withSqliteDb cid iodir s = withResource start stop s -- logger = genericLogger Error (\_ -> return ()) --- | Single-chain Pact via service queue. -withPactTestBlockDb - :: ChainwebVersion - -> ChainId - -> RocksDb - -> IO MemPoolAccess - -> PactServiceConfig - -> (IO (SQLiteEnv,PactQueue,TestBlockDb) -> TestTree) - -> TestTree -withPactTestBlockDb version cid rdb mempoolIO pactConfig f = - withResourceT (withTempDir "pact-dir") $ \iodir -> - withResourceT (mkTestBlockDb version rdb) $ \bdbio -> - withResource (startPact bdbio iodir) stopPact $ f . fmap (view _2) - where - startPact bdbio iodir = do - reqQ <- newPactQueue 2000 - dir <- iodir - bdb <- bdbio - mempool <- mempoolIO - bhdb <- getWebBlockHeaderDb (_bdbWebBlockHeaderDb bdb) cid - let pdb = _bdbPayloadDb bdb - sqlEnv <- startSqliteDb cid logger dir False - a <- async $ runForever (\_ _ -> return ()) "Chainweb.Test.Pact4.Utils.withPactTestBlockDb" $ - runPactService version cid logger Nothing reqQ mempool bhdb pdb sqlEnv pactConfig - return (a, (sqlEnv,reqQ,bdb)) - - stopPact (a, (sqlEnv, _, _)) = cancel a >> stopSqliteDb sqlEnv - - -- Ideally, we should throw 'error' when the logger is invoked, because - -- error logs should not happen in production and should always be resolved. - -- Unfortunately, that's not yet always the case. So we just drop the - -- message. - -- - logger = genericLogger Error (\_ -> return ()) - dummyLogger :: GenericLogger dummyLogger = genericLogger Error (error . T.unpack) @@ -1050,22 +650,22 @@ hunitDummyLogger :: (String -> IO ()) -> GenericLogger hunitDummyLogger f = genericLogger Error (f . T.unpack) someTestVersion :: ChainwebVersion -someTestVersion = instantCpmTestVersion petersenChainGraph +someTestVersion = instantCpmTestVersion False petersenChainGraph someTestVersionHeader :: BlockHeader -someTestVersionHeader = someBlockHeader someTestVersion 10 +someTestVersionHeader = Version.withVersion someTestVersion $ someBlockHeader 10 -- | The runtime is linear in the requested height. This can be slow if a large -- block height is requested for a chainweb version that simulates realtime -- mining. It is fast enough for testing purposes with "fast" mining chainweb -- versions like 'someTestVersion' for block heights up to, say, 1000. -- -someBlockHeader :: ChainwebVersion -> BlockHeight -> BlockHeader -someBlockHeader v 0 = genesisBlockHeader v (unsafeChainId 0) -someBlockHeader v h = (!! (int h - 1)) +someBlockHeader :: Version.HasVersion => BlockHeight -> BlockHeader +someBlockHeader 0 = genesisBlockHeader (unsafeChainId 0) +someBlockHeader h = (!! (int h - 1)) $ testBlockHeaders - $ ParentHeader - $ genesisBlockHeader v (unsafeChainId 0) + $ Parent + $ genesisBlockHeader (unsafeChainId 0) -- | Get all pact user tables. -- @@ -1109,10 +709,3 @@ getPWOByHeader h (TestBlockDb _ pdb _) = lookupPayloadWithHeight pdb (Just $ view blockHeight h) (view blockPayloadHash h) >>= \case Nothing -> throwM $ userError "getPWOByHeader: payload not found" Just pwo -> return pwo - -throwIfNotPact4 :: Version.ForSomePactVersion f -> IO (f Version.Pact4) -throwIfNotPact4 h = case h of - Version.ForSomePactVersion Version.Pact4T a -> do - pure a - Version.ForSomePactVersion Version.Pact5T _ -> do - assertFailure "throwIfNotPact4: should be pact4" diff --git a/test/lib/Chainweb/Test/Pact4/VerifierPluginTest/Transaction.hs b/test/lib/Chainweb/Test/Pact4/VerifierPluginTest/Transaction.hs deleted file mode 100644 index 912aa762ff..0000000000 --- a/test/lib/Chainweb/Test/Pact4/VerifierPluginTest/Transaction.hs +++ /dev/null @@ -1,279 +0,0 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE NumericUnderscores #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeApplications #-} - -module Chainweb.Test.Pact4.VerifierPluginTest.Transaction -( tests -) where - -import Control.Lens hiding ((.=)) -import Control.Monad.Reader -import Data.IORef -import qualified Data.Vector as V -import Test.Tasty -import Test.Tasty.HUnit - --- internal modules - -import Pact.Types.Capability -import Pact.Types.Command -import Pact.Types.Info (noInfo) -import qualified Pact.JSON.Encode as PactJSON -import Pact.Types.PactValue -import Pact.Types.Term -import Pact.Types.Verifier hiding (verifierName) - -import Chainweb.Miner.Pact -import Chainweb.Pact.Types -import Chainweb.Storage.Table.RocksDB -import Chainweb.Test.Cut.TestBlockDb -import Chainweb.Test.Pact4.Utils -import Chainweb.Test.Utils -import Chainweb.Version - -import qualified Chainweb.Test.Pact4.VerifierPluginTest.Transaction.Message.After225 as After225 -import qualified Chainweb.Test.Pact4.VerifierPluginTest.Transaction.Message.Before225 as Before225 -import Chainweb.Test.Pact4.VerifierPluginTest.Transaction.Utils - - -tests :: RocksDb -> TestTree -tests rdb = testGroup testName - [ test generousConfig "verifierTest" verifierTest - - , test generousConfig "recoverValidatorAnnouncementSuccess" hyperlaneRecoverValidatorAnnouncementSuccess - , test generousConfig "recoverValidatorAnnouncementIncorrectSignatureFailure" - hyperlaneRecoverValidatorAnnouncementIncorrectSignatureFailure - , test generousConfig "recoverValidatorAnnouncementDifferentSignerFailure" - hyperlaneRecoverValidatorAnnouncementDifferentSignerFailure - - , testGroup "Message" - [ Before225.tests rdb - , After225.tests rdb - ] - ] - where - testName = "Chainweb.Test.Pact4.VerifierPluginTest.Transaction" - -- This is way more than what is used in production, but during testing - -- we can be generous. - generousConfig = testPactServiceConfig { _pactNewBlockGasLimit = 300_000 } - - test pactConfig tname f = - withResourceT (mkTestBlockDb testVersion rdb) $ \bdbIO -> do - testCaseSteps tname $ \step -> do - bdb <- bdbIO - let logger = hunitDummyLogger step - mempools <- onAllChains testVersion $ \_ -> do - mempoolRef <- newIORef mempty - return (mempoolRef, delegateMemPoolAccess mempoolRef) - withWebPactExecutionService logger testVersion pactConfig bdb (snd <$> mempools) $ \(pact,_) -> - runReaderT f $ - SingleEnv bdb pact (mempools ^?! atChain cid . _1) noMiner cid - -verifierTest :: PactTestM () -verifierTest = do - runToHeight 118 - - let cap = SigCapability (QualifiedName (ModuleName "m" (Just (NamespaceName "free"))) "G" noInfo) [] - - runBlockTest - [ PactTxTest - (buildBasic (mkExec' "(enforce-verifier 'allow)")) - (assertTxFailure "Should not resolve enforce-verifier" "Cannot resolve enforce-verifier") - , PactTxTest - (buildBasic' - (set cbVerifiers - [Verifier - (VerifierName "missing") - (ParsedVerifierProof $ pString "") - [cap]]) - (mkExec' "1")) - (assertTxSuccess - "Should not run verifiers before they're enabled" (pDecimal 1)) - ] - - runBlockTest - [ PactTxTest - (buildBasicGas 70000 - $ mkExec' $ mconcat - [ "(namespace 'free)" - , "(module m G" - , "(defcap G () (enforce-verifier 'allow))" - , "(defun x () (with-capability (G) 1)))" - ] - ) - (assertTxSuccess - "Should allow enforce-verifier in a capability" - (pString "Loaded module free.m, hash QNTlTCp-KMPkT52CEo_0zGaLJ_PnAxsenyhUck1njcc") - ) - , PactTxTest - (buildBasicGas 10000 (mkExec' "(free.m.x)")) - (\cr -> liftIO $ do - assertTxFailure - "verifier not present" - "Verifier failure allow: not in transaction" - cr - assertTxGas "verifier errors charge all gas" 10000 cr - ) - , PactTxTest - (buildBasic' - (set cbVerifiers - [Verifier - (VerifierName "allow") - (ParsedVerifierProof $ pString (PactJSON.encodeText cap)) - [cap] - ] - ) - (mkExec' "(free.m.x)") - ) - (\cr -> liftIO $ do - assertTxSuccess "should have succeeded" (pDecimal 1) cr - -- The **Allow** verifier costs 100 gas flat - assertEqual "gas should have been charged" 335 (_crGas cr) - ) - , PactTxTest - (buildBasic' - (set cbVerifiers - [Verifier - (VerifierName "missing") - (ParsedVerifierProof $ pString (PactJSON.encodeText cap)) - [cap] - ] - ) - (mkExec' "(free.m.x)") - ) - (assertTxFailure - "should have failed, missing verifier" - "Tx verifier error: verifier does not exist: missing") - ] - --- hyperlane validator announcement tests - -hyperlaneRecoverValidatorAnnouncementSuccess :: PactTestM () -hyperlaneRecoverValidatorAnnouncementSuccess = do - runToHeight 119 - let verifierName = "hyperlane_v3_announcement" - - let cap = SigCapability (QualifiedName (ModuleName "m" (Just (NamespaceName "free"))) "K" noInfo) - [pString "storagelocation", pString "0x6c414e7a15088023e28af44ad0e1d593671e4b15", pString "kb-mailbox"] - - runBlockTest - [ PactTxTest - (buildBasicGas 70000 - $ mkExec' $ mconcat - [ "(namespace 'free)" - , "(module m G" - , "(defcap G () true)" - , "(defcap K (location:string signer:string mailbox:string) (enforce-verifier '" <> verifierName <> "))" - , "(defun x () (with-capability (K \"storagelocation\" \"0x6c414e7a15088023e28af44ad0e1d593671e4b15\" \"kb-mailbox\") 1)))"]) - (assertTxSuccess - "Should deploy module" - (pString "Loaded module free.m, hash JbKuarvFOs3FGnpQ3R2exafA2gKonqa5Ls1-l3rIh8I")) - , checkVerifierNotInTx verifierName - , PactTxTest - (buildBasic' - (set cbGasLimit 20000 . set cbVerifiers - [Verifier - (VerifierName verifierName) - (ParsedVerifierProof $ - PList $ V.fromList - [ pString "storagelocation" - -- TODO: generate instead of using the precomputed value - , pString "U7oftiGhn7rpWJydP6t0FKStdcRd223a8uSTqKjs8K8nJW7U84tzBOgPZTtGKnncwiu8l1185vB38c7-Ov7avBw" - , pString "kb-mailbox" - ] - ) - [cap]]) - (mkExec' "(free.m.x)")) - (\cr -> liftIO $ do - assertTxSuccess "should have succeeded" (pDecimal 1) cr - assertEqual "gas should have been charged" 16492 (_crGas cr)) - ] - -hyperlaneRecoverValidatorAnnouncementIncorrectSignatureFailure :: PactTestM () -hyperlaneRecoverValidatorAnnouncementIncorrectSignatureFailure = do - runToHeight 119 - let verifierName = "hyperlane_v3_announcement" - - let cap = SigCapability (QualifiedName (ModuleName "m" (Just (NamespaceName "free"))) "K" noInfo) - [pString "storagelocation", pString "0x6c414e7a15088023e28af44ad0e1d593671e4b15", pString "kb-mailbox"] - - runBlockTest - [ PactTxTest - (buildBasicGas 70000 - $ mkExec' $ mconcat - [ "(namespace 'free)" - , "(module m G" - , "(defcap G () true)" - , "(defcap K (location:string signer:string mailbox:string) (enforce-verifier '" <> verifierName <> "))" - , "(defun x () (with-capability (K \"storagelocation\" \"0x6c414e7a15088023e28af44ad0e1d593671e4b15\" \"kb-mailbox\") 1)))"]) - (assertTxSuccess - "Should deploy module" - (pString "Loaded module free.m, hash JbKuarvFOs3FGnpQ3R2exafA2gKonqa5Ls1-l3rIh8I")) - , checkVerifierNotInTx verifierName - , PactTxTest - (buildBasic' - (set cbGasLimit 20000 . set cbVerifiers - [Verifier - (VerifierName verifierName) - (ParsedVerifierProof $ - PList $ V.fromList - [ pString "storagelocation" - - -- bad signature (same as from the previous test but the different first symbol) - , pString "Q7oftiGhn7rpWJydP6t0FKStdcRd223a8uSTqKjs8K8nJW7U84tzBOgPZTtGKnncwiu8l1185vB38c7-Ov7avBw" - - , pString "kb-mailbox" - ] - ) - [cap]]) - (mkExec' "(free.m.x)")) - (\cr -> liftIO $ do - assertTxFailure "should have failed with incorrect signature" "Tx verifier error: Failed to recover the address from the signature" cr - assertTxGas "verifier errors charge all gas" 20000 cr) - ] - -hyperlaneRecoverValidatorAnnouncementDifferentSignerFailure :: PactTestM () -hyperlaneRecoverValidatorAnnouncementDifferentSignerFailure = do - runToHeight 119 - let verifierName = "hyperlane_v3_announcement" - - let cap = SigCapability (QualifiedName (ModuleName "m" (Just (NamespaceName "free"))) "K" noInfo) - -- bad signer (same as from the previous test but the different first symbol) - [pString "storagelocation", pString "0x5c414e7a15088023e28af44ad0e1d593671e4b15", pString "kb-mailbox"] - - runBlockTest - [ PactTxTest - (buildBasicGas 70000 - $ mkExec' $ mconcat - [ "(namespace 'free)" - , "(module m G" - , "(defcap G () true)" - , "(defcap K (location:string signer:string mailbox:string) (enforce-verifier '" <> verifierName <> "))" - , "(defun x () (with-capability (K \"storagelocation\" \"0x5c414e7a15088023e28af44ad0e1d593671e4b15\" \"kb-mailbox\") 1)))"]) - (assertTxSuccess - "Should deploy module" - (pString "Loaded module free.m, hash jZR2sS2FjdR-3udU9-DNL1RfsjKISk4AuhNm43yueOA")) - , checkVerifierNotInTx verifierName - , PactTxTest - (buildBasic' - (set cbGasLimit 20000 . set cbVerifiers - [Verifier - (VerifierName verifierName) - (ParsedVerifierProof $ - PList $ V.fromList - [ pString "storagelocation" - , pString "U7oftiGhn7rpWJydP6t0FKStdcRd223a8uSTqKjs8K8nJW7U84tzBOgPZTtGKnncwiu8l1185vB38c7-Ov7avBw" - , pString "kb-mailbox" - ] - ) - [cap]]) - (mkExec' "(free.m.x)")) - (\cr -> liftIO $ do - let errMsg = "Tx verifier error: Incorrect signer. Expected: PLiteral (LString {_lString = \"0x6c414e7a15088023e28af44ad0e1d593671e4b15\"}) but got PLiteral (LString {_lString = \"0x5c414e7a15088023e28af44ad0e1d593671e4b15\"})" - assertTxFailure "should have failed with incorrect signer" errMsg cr - assertTxGas "verifier errors charge all gas" 20000 cr) - ] diff --git a/test/lib/Chainweb/Test/Pact4/VerifierPluginTest/Transaction/Message/After225.hs b/test/lib/Chainweb/Test/Pact4/VerifierPluginTest/Transaction/Message/After225.hs deleted file mode 100644 index 73b6ee237c..0000000000 --- a/test/lib/Chainweb/Test/Pact4/VerifierPluginTest/Transaction/Message/After225.hs +++ /dev/null @@ -1,358 +0,0 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE NumericUnderscores #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeApplications #-} - -module Chainweb.Test.Pact4.VerifierPluginTest.Transaction.Message.After225 (tests) where - -import Control.Lens hiding ((.=)) -import Control.Monad.Reader -import qualified Data.ByteString as B -import qualified Data.Text as T -import qualified Data.Vector as V -import qualified Data.Map.Strict as M -import Test.Tasty -import Test.Tasty.HUnit - --- internal modules - -import Pact.Types.Capability -import Pact.Types.Command -import Pact.Types.PactValue -import Pact.Types.Term -import Pact.Types.Runtime -import Pact.Types.Verifier hiding (verifierName) - -import Chainweb.Miner.Pact -import Chainweb.Pact.Types -import Chainweb.Storage.Table.RocksDB -import Chainweb.Test.Cut.TestBlockDb -import Chainweb.Test.Pact4.Utils -import Chainweb.Test.Utils -import Chainweb.Utils -import Chainweb.Utils.Serialization -import Chainweb.VerifierPlugin.Hyperlane.Binary -import Chainweb.VerifierPlugin.Hyperlane.Utils - -import Chainweb.Test.Pact4.VerifierPluginTest.Transaction.Utils -import Chainweb.Version -import Data.IORef - -tests :: RocksDb -> TestTree -tests rdb = testGroup "After225" - [ test generousConfig "verifySuccess" hyperlaneVerifySuccess - , test generousConfig "verifyMoreValidatorsSuccess" hyperlaneVerifyMoreValidatorsSuccess - , test generousConfig "verifyThresholdZeroError" hyperlaneVerifyThresholdZeroError - , test generousConfig "verifyWrongSignersFailure" hyperlaneVerifyWrongSignersFailure - , test generousConfig "verifyNotEnoughRecoveredSignaturesFailure" hyperlaneVerifyNotEnoughRecoveredSignaturesFailure - , test generousConfig "verifyNotEnoughCapabilitySignaturesFailure" hyperlaneVerifyNotEnoughCapabilitySignaturesFailure - , test generousConfig "verifyIncorrectProofFailure" hyperlaneVerifyMerkleIncorrectProofFailure - , test generousConfig "verifyFailureNotEnoughSignaturesToPassThreshold" hyperlaneVerifyFailureNotEnoughSignaturesToPassThreshold - ] - where - -- This is way more than what is used in production, but during testing - -- we can be generous. - generousConfig = testPactServiceConfig { _pactNewBlockGasLimit = 300_000 } - - test pactConfig tname f = withResourceT (mkTestBlockDb testVersion rdb) $ \bdbIO -> - testCaseSteps tname $ \step -> do - bdb <- bdbIO - let logger = hunitDummyLogger step - mempools <- onAllChains testVersion $ \_ -> do - mempoolRef <- newIORef mempty - return (mempoolRef, delegateMemPoolAccess mempoolRef) - withWebPactExecutionService logger testVersion pactConfig bdb (snd <$> mempools) $ \(pact,_) -> - runReaderT f $ - SingleEnv bdb pact (mempools ^?! atChain cid . _1) noMiner cid - --- hyperlane message tests - --- | Hyperlane test message TokenMessageERC20 encoded in base64: --- --- { "amount": 0.000000000000000123 --- , "chainId": "4" --- , "recipient": { "test-keys" : {"pred": "keys-all", "keys": ["da1a339bd82d2c2e9180626a00dc043275deb3ababb27b5738abf6b9dcee8db6"]} } --- } --- -hyperlaneTokenMessageBase64 :: T.Text -hyperlaneTokenMessageBase64 = "AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAHsABHsicHJlZCI6ICJrZXlzLWFsbCIsICJrZXlzIjpbImRhMWEzMzliZDgyZDJjMmU5MTgwNjI2YTAwZGMwNDMyNzVkZWIzYWJhYmIyN2I1NzM4YWJmNmI5ZGNlZThkYjYiXX0" - --- | Hyperlane test message encoded in base64 -hyperlaneMessageBase64 :: T.Text -hyperlaneMessageBase64 = encodeB64UrlNoPaddingText $ runPutS $ putHyperlaneMessage $ - HyperlaneMessage - { hmVersion = 3 - , hmNonce = 0 - , hmOriginDomain = 31337 - , hmSender = either (error . show) id $ decodeB64UrlNoPaddingText "AAAAAAAAAAAAAAAAf6k4W-ECrD6sKXSD3WIz1is-FJY" - , hmDestinationDomain = 626 - , hmRecipient = either (error . show) id $ decodeB64UrlNoPaddingText "AAAAAAAAAADpgrOqkM0BOY-FQnNzkDXuYlsVcf50GRU" - , hmMessageBody = either (error . show) id $ decodeB64UrlNoPaddingText hyperlaneTokenMessageBase64 - } - -hyperlaneMessageId :: T.Text -hyperlaneMessageId = encodeB64UrlNoPaddingText $ keccak256ByteString $ either (error . show) id $ decodeB64UrlNoPaddingText $ hyperlaneMessageBase64 - --- | Hyperlane test MerkleTree Metadata encoded in base64 --- Test data was generated using the following test in the hyperlane codebase --- https://github.com/hyperlane-xyz/hyperlane-monorepo/blob/b14f997810ebd7dbdff2ac6622a149ae77010ae3/solidity/test/isms/MultisigIsm.t.sol#L35 -mkHyperlaneMerkleTreeMetadataBase64 :: B.ByteString -> [B.ByteString] -> T.Text -mkHyperlaneMerkleTreeMetadataBase64 proof signatures = encodeB64UrlNoPaddingText $ runPutS $ putMerkleRootMultisigIsmMetadata $ - MerkleRootMultisigIsmMetadata - { mrmimOriginMerkleTreeAddress = decodeHexUnsafe "0x2e234dae75c793f67a35089c9d99245e1c58470b" - , mrmimMessageIdIndex = 0 - , mrmimSignedCheckpointMessageId = either (error . show) id $ decodeB64UrlNoPaddingText hyperlaneMessageId - , mrmimMerkleProof = proof - , mrmimSignedCheckpointIndex = 0 - , mrmimSignatures = signatures - } - -hyperlaneMerkleTreeCorrectProof :: B.ByteString -hyperlaneMerkleTreeCorrectProof = decodeHexUnsafe "0x0000000000000000000000000000000000000000000000000000000000000000ad3228b676f7d3cd4284a5443f17f1962b36e491b30a40b2405849e597ba5fb5b4c11951957c6f8f642c4af61cd6b24640fec6dc7fc607ee8206a99e92410d3021ddb9a356815c3fac1026b6dec5df3124afbadb485c9ba5a3e3398a04b7ba85e58769b32a1beaf1ea27375a44095a0d1fb664ce2dd358e7fcbfb78c26a193440eb01ebfc9ed27500cd4dfc979272d1f0913cc9f66540d7e8005811109e1cf2d887c22bd8750d34016ac3c66b5ff102dacdd73f6b014e710b51e8022af9a1968ffd70157e48063fc33c97a050f7f640233bf646cc98d9524c6b92bcf3ab56f839867cc5f7f196b93bae1e27e6320742445d290f2263827498b54fec539f756afcefad4e508c098b9a7e1d8feb19955fb02ba9675585078710969d3440f5054e0f9dc3e7fe016e050eff260334f18a5d4fe391d82092319f5964f2e2eb7c1c3a5f8b13a49e282f609c317a833fb8d976d11517c571d1221a265d25af778ecf8923490c6ceeb450aecdc82e28293031d10c7d73bf85e57bf041a97360aa2c5d99cc1df82d9c4b87413eae2ef048f94b4d3554cea73d92b0f7af96e0271c691e2bb5c67add7c6caf302256adedf7ab114da0acfe870d449a3a489f781d659e8beccda7bce9f4e8618b6bd2f4132ce798cdc7a60e7e1460a7299e3c6342a579626d22733e50f526ec2fa19a22b31e8ed50f23cd1fdf94c9154ed3a7609a2f1ff981fe1d3b5c807b281e4683cc6d6315cf95b9ade8641defcb32372f1c126e398ef7a5a2dce0a8a7f68bb74560f8f71837c2c2ebbcbf7fffb42ae1896f13f7c7479a0b46a28b6f55540f89444f63de0378e3d121be09e06cc9ded1c20e65876d36aa0c65e9645644786b620e2dd2ad648ddfcbf4a7e5b1a3a4ecfe7f64667a3f0b7e2f4418588ed35a2458cffeb39b93d26f18d2ab13bdce6aee58e7b99359ec2dfd95a9c16dc00d6ef18b7933a6f8dc65ccb55667138776f7dea101070dc8796e3774df84f40ae0c8229d0d6069e5c8f39a7c299677a09d367fc7b05e3bc380ee652cdc72595f74c7b1043d0e1ffbab734648c838dfb0527d971b602bc216c9619ef0abf5ac974a1ed57f4050aa510dd9c74f508277b39d7973bb2dfccc5eeb0618db8cd74046ff337f0a7bf2c8e03e10f642c1886798d71806ab1e888d9e5ee87d0838c5655cb21c6cb83313b5a631175dff4963772cce9108188b34ac87c81c41e662ee4dd2dd7b2bc707961b1e646c4047669dcb6584f0d8d770daf5d7e7deb2e388ab20e2573d171a88108e79d820e98f26c0b84aa8b2f4aa4968dbb818ea32293237c50ba75ee485f4c22adf2f741400bdf8d6a9cc7df7ecae576221665d7358448818bb4ae4562849e949e17ac16e0be16688e156b5cf15e098c627c0056a9" - -hyperlaneMerkleTreeIncorrectProof :: B.ByteString -hyperlaneMerkleTreeIncorrectProof - = B.take 31 hyperlaneMerkleTreeCorrectProof - <> "\x19" - <> B.drop 32 hyperlaneMerkleTreeCorrectProof - -validSigner :: T.Text -validSigner = "0x2bd2e3ba4861fae19d87cd77f8557bbad8e92d23" - -validSignature :: T.Text -validSignature = "0xfabe80dd5bf4440e5e7fbc3cdf12325df9c00beb1281c5ddf12e77177046790c49f531ccebb29ba9c9664a581ed1870873850e0cf0c231b779e21f48a1d0dcea1b" - --- | Deploys a contract with a valid signer -deployContractWith :: [T.Text] -> Integer -> T.Text -> PactTxTest -deployContractWith signers threshold moduleHash = - PactTxTest - (buildBasicGas 70000 - $ mkExec' $ mconcat - [ "(namespace 'free)" - , "(module m G" - , "(defschema hyperlane_message" - , " version:integer" - , " nonce:integer" - , " originDomain:integer" - , " destinationDomain:integer" - , " sender:string" - , " recipient:string" - , " messageBody:string" - , ")" - , "(defcap G () true)" - , "(defcap K (messageId:string message:object{hyperlane_message} signers:[string] threshold:integer)" - , " (enforce-verifier 'hyperlane_v3_message)" - , " (enforce (= messageId \"" <> hyperlaneMessageId <> "\") \"invalid messageId\")" - , " (enforce (= messageId (hyperlane-message-id message)) \"invalid calculated messageId\")" - , " (enforce (= signers [" <> (T.intercalate "," $ map (\s -> "\"" <> s <> "\"") signers) <> "]) \"invalid signers\")" - , " (enforce (= (at \"sender\" message) \"AAAAAAAAAAAAAAAAf6k4W-ECrD6sKXSD3WIz1is-FJY\") \"invalid sender\")" - , " (enforce (= (at \"recipient\" message) \"AAAAAAAAAADpgrOqkM0BOY-FQnNzkDXuYlsVcf50GRU\") \"invalid recipient\")" - , " (bind (hyperlane-decode-token-message (at \"messageBody\" message)) " - , " { \"amount\" := amount, " - , " \"chainId\" := chain-id, " - , " \"recipient\" := recipient-guard }" - , " (enforce (= amount 0.000000000000000123) \"invalid amount\")" - , " (enforce (= (create-principal recipient-guard) \"k:da1a339bd82d2c2e9180626a00dc043275deb3ababb27b5738abf6b9dcee8db6\") \"invalid recipient guard\")" - , " (enforce (= (hyperlane-encode-token-message {\"amount\": 123.0, \"chainId\": chain-id, \"recipient\": \"eyJwcmVkIjogImtleXMtYWxsIiwgImtleXMiOlsiZGExYTMzOWJkODJkMmMyZTkxODA2MjZhMDBkYzA0MzI3NWRlYjNhYmFiYjI3YjU3MzhhYmY2YjlkY2VlOGRiNiJdfQ\"" - , "}) (at \"messageBody\" message)) \"invalid encoded message\")" - , " )" - , ")" - , "(defun x () (with-capability (K " - , "\"" <> hyperlaneMessageId <> "\"" - , " {" - , " \"version\": 3," - , " \"nonce\": 0," - , " \"originDomain\": 31337," - , " \"sender\": \"AAAAAAAAAAAAAAAAf6k4W-ECrD6sKXSD3WIz1is-FJY\"," - , " \"destinationDomain\": 626," - , " \"recipient\": \"AAAAAAAAAADpgrOqkM0BOY-FQnNzkDXuYlsVcf50GRU\"," - , " \"messageBody\": \"" <> hyperlaneTokenMessageBase64 <> "\"" - , "}" - , " [" <> (T.intercalate "," $ map (\s -> "\"" <> s <> "\"") signers) <> "]" - , " " <> sshow threshold - , ")" - , " \"succeeded\")))" - ]) - (assertTxSuccess - "Should deploy module" - (pString $ "Loaded module free.m, hash " <> moduleHash)) - --- | Calls '(free.m.x)' from 'deployContractWithValidSigner' -mkMerkleMetadataCallWithGas :: GasLimit -> B.ByteString -> [T.Text] -> [T.Text] -> Integer -> MempoolCmdBuilder -mkMerkleMetadataCallWithGas gas merkleProof signatures signersText threshold = buildBasic' - (set cbGasLimit gas . set cbVerifiers - [Verifier - (VerifierName "hyperlane_v3_message") - (ParsedVerifierProof $ - PList $ V.fromList - [ pString hyperlaneMessageBase64 - - , pString $ mkHyperlaneMerkleTreeMetadataBase64 merkleProof $ map decodeHexUnsafe signatures - ] - ) - [cap]]) - (mkExec' "(free.m.x)") - where - messageId = pString hyperlaneMessageId - message = PObject . ObjectMap . M.fromList $ - [ ("version", PLiteral $ LInteger 3) - , ("nonce", PLiteral $ LInteger 0) - , ("originDomain", PLiteral $ LInteger 31337) - , ("destinationDomain", PLiteral $ LInteger 626) - , ("sender", pString "AAAAAAAAAAAAAAAAf6k4W-ECrD6sKXSD3WIz1is-FJY") - , ("recipient", pString "AAAAAAAAAADpgrOqkM0BOY-FQnNzkDXuYlsVcf50GRU") - , ("messageBody", pString hyperlaneTokenMessageBase64) - ] - - signers = PList $ V.fromList $ map pString signersText - cap = SigCapability (QualifiedName (ModuleName "m" (Just (NamespaceName "free"))) "K" noInfo) - [messageId, message, signers, pInteger threshold] - -mkMerkleMetadataCall :: B.ByteString -> [T.Text] -> [T.Text] -> Integer -> MempoolCmdBuilder -mkMerkleMetadataCall = mkMerkleMetadataCallWithGas 20000 - -hyperlaneVerifySuccess :: PactTestM () -hyperlaneVerifySuccess = do - runToHeight 131 - - let threshold = 1 - runBlockTest - [ deployContractWith [validSigner] threshold "QpXqxeT4QKDK98PZaxQCexpxg8bRWDkF4fmB0IhoLR0" - , checkVerifierNotInTx "hyperlane_v3_message" - , PactTxTest (mkMerkleMetadataCall hyperlaneMerkleTreeCorrectProof [validSignature] [validSigner] threshold) - (\cr -> liftIO $ do - assertTxSuccess "should have succeeded" (pString "succeeded") cr - assertEqual "gas should have been charged" 16582 (_crGas cr)) - ] - -hyperlaneVerifyMoreValidatorsSuccess :: PactTestM () -hyperlaneVerifyMoreValidatorsSuccess = do - runToHeight 131 - - let threshold = 1 - let signers = ["wrongSigner", validSigner] - runBlockTest - [ deployContractWith signers threshold "8hkRC85XbTyMUBEbpwLNXP-KH7mVezY51uKnuznGAAo" - , checkVerifierNotInTx "hyperlane_v3_message" - , PactTxTest (mkMerkleMetadataCall hyperlaneMerkleTreeCorrectProof [validSignature] signers threshold) - (\cr -> liftIO $ do - assertTxSuccess "should have succeeded" (pString "succeeded") cr - assertEqual "gas should have been charged" 16583 (_crGas cr)) - ] - -hyperlaneVerifyThresholdZeroError :: PactTestM () -hyperlaneVerifyThresholdZeroError = do - runToHeight 131 - - runBlockTest - [ PactTxTest - (buildBasicGas 70000 - $ mkExec' $ mconcat - [ "(namespace 'free)" - , "(module m G" - , "(defcap G () true)" - , "(defcap K (messageId:string message signers:[string] threshold:integer)" - , " (enforce-verifier 'hyperlane_v3_message)" - , " (enforce (= signers []) \"invalid signers\")" - , ")" - , "(defun x () (with-capability (K " - , "\"" <> hyperlaneMessageId <> "\"" - , " {" - , " \"version\": 3," - , " \"nonce\": 0," - , " \"originDomain\": 31337," - , " \"sender\": \"AAAAAAAAAAAAAAAAf6k4W-ECrD6sKXSD3WIz1is-FJY\"," - , " \"destinationDomain\": 626," - , " \"recipient\": \"AAAAAAAAAADpgrOqkM0BOY-FQnNzkDXuYlsVcf50GRU\"," - , " \"messageBody\": \"" <> hyperlaneTokenMessageBase64 <> "\"" - , "}" - , " [] 0" - , ")" - , " \"succeeded\")))" - ]) - (assertTxSuccess - "Should deploy module" - (pString "Loaded module free.m, hash dSzwI4Kg9RYSrEqzdqQ9-bhsqn3NrefVXvtPQF7RF80")) - , checkVerifierNotInTx "hyperlane_v3_message" - , PactTxTest (mkMerkleMetadataCall hyperlaneMerkleTreeCorrectProof [] [] 0) - (\cr -> liftIO $ do - assertTxFailure "Verification should fail" "Tx verifier error: Threshold should be greater than 0" cr - assertEqual "gas should have been charged" 20000 (_crGas cr)) - ] - -hyperlaneVerifyWrongSignersFailure :: PactTestM () -hyperlaneVerifyWrongSignersFailure = do - runToHeight 131 - - let threshold = 1 - runBlockTest - [ deployContractWith ["wrongSigner"] threshold "LqQ1Y2N2UXxOnWRBaXQ9lNcit5dESFtetuB3oxQyNEg" - , checkVerifierNotInTx "hyperlane_v3_message" - , PactTxTest (mkMerkleMetadataCall hyperlaneMerkleTreeCorrectProof [validSignature] ["wrongSigner"] threshold) - (\cr -> liftIO $ do - assertTxFailure "Verification should fail" "Tx verifier error: Verification failed" cr - assertEqual "gas should have been charged" 20000 (_crGas cr)) - ] - -hyperlaneVerifyNotEnoughRecoveredSignaturesFailure :: PactTestM () -hyperlaneVerifyNotEnoughRecoveredSignaturesFailure = do - runToHeight 131 - - let threshold = 1 - runBlockTest - [ deployContractWith ["wrongSigner"] threshold "LqQ1Y2N2UXxOnWRBaXQ9lNcit5dESFtetuB3oxQyNEg" - , checkVerifierNotInTx "hyperlane_v3_message" - , PactTxTest (mkMerkleMetadataCall - hyperlaneMerkleTreeCorrectProof [] ["wrongSigner"] threshold) - (\cr -> liftIO $ do - assertTxFailure "Verification should fail with not enough recovered addresses" "Tx verifier error: The number of signatures can't be less than threshold" cr - assertEqual "gas should have been charged" 20000 (_crGas cr)) - ] - -hyperlaneVerifyNotEnoughCapabilitySignaturesFailure :: PactTestM () -hyperlaneVerifyNotEnoughCapabilitySignaturesFailure = do - runToHeight 131 - - let threshold = 2 - runBlockTest - [ deployContractWith [validSigner] threshold "7z1p9sgWQ_RC-iaNSwQU8I7K1pFL2AOFtI-ZyxRdzkg" - , checkVerifierNotInTx "hyperlane_v3_message" - , PactTxTest (mkMerkleMetadataCallWithGas 40000 hyperlaneMerkleTreeCorrectProof [validSignature, validSignature] [validSigner] threshold) - (\cr -> liftIO $ do - assertTxFailure "Verification should fail" "Tx verifier error: Verification failed" cr - assertEqual "gas should have been charged" 40000 (_crGas cr)) - ] - -hyperlaneVerifyMerkleIncorrectProofFailure :: PactTestM () -hyperlaneVerifyMerkleIncorrectProofFailure = do - runToHeight 131 - - let threshold = 1 - runBlockTest - [ deployContractWith [validSigner] threshold "QpXqxeT4QKDK98PZaxQCexpxg8bRWDkF4fmB0IhoLR0" - , checkVerifierNotInTx "hyperlane_v3_message" - , PactTxTest (mkMerkleMetadataCall hyperlaneMerkleTreeIncorrectProof [validSignature] [validSigner] threshold) - (\cr -> liftIO $ do - assertTxFailure "Verification should fail" "Tx verifier error: Verification failed" cr - assertEqual "gas should have been charged" 20000 (_crGas cr)) - ] - --- | We pass 2 signatures, 1st one matches to the correct validator, --- but there is no second valid validator for the 2nd signature, and the verification fails. -hyperlaneVerifyFailureNotEnoughSignaturesToPassThreshold :: PactTestM () -hyperlaneVerifyFailureNotEnoughSignaturesToPassThreshold = do - runToHeight 131 - - let threshold = 2 - let signers = ["wrongSigner", validSigner, "wrongSigner"] - runBlockTest - [ deployContractWith [validSigner] threshold "7z1p9sgWQ_RC-iaNSwQU8I7K1pFL2AOFtI-ZyxRdzkg" - , checkVerifierNotInTx "hyperlane_v3_message" - , PactTxTest (mkMerkleMetadataCallWithGas 40000 hyperlaneMerkleTreeCorrectProof [validSignature, validSignature] signers threshold) - (\cr -> liftIO $ do - assertTxFailure "Verification should fail" "Tx verifier error: Verification failed" cr - assertEqual "gas should have been charged" 40000 (_crGas cr)) - ] diff --git a/test/lib/Chainweb/Test/Pact4/VerifierPluginTest/Transaction/Message/Before225.hs b/test/lib/Chainweb/Test/Pact4/VerifierPluginTest/Transaction/Message/Before225.hs deleted file mode 100644 index c2d8a1ac63..0000000000 --- a/test/lib/Chainweb/Test/Pact4/VerifierPluginTest/Transaction/Message/Before225.hs +++ /dev/null @@ -1,463 +0,0 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE NumericUnderscores #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeApplications #-} - -module Chainweb.Test.Pact4.VerifierPluginTest.Transaction.Message.Before225 (tests) where - -import Control.Lens hiding ((.=)) -import Control.Monad.Reader -import qualified Data.ByteString as B -import qualified Data.Text as T -import qualified Data.Vector as V -import Test.Tasty -import Test.Tasty.HUnit - --- internal modules - -import Pact.Types.Capability -import Pact.Types.Command -import Pact.Types.Info (noInfo) -import Pact.Types.PactValue -import Pact.Types.Term -import Pact.Types.Verifier hiding (verifierName) - -import Chainweb.Miner.Pact -import Chainweb.Pact.Types -import Chainweb.Storage.Table.RocksDB -import Chainweb.Test.Cut.TestBlockDb -import Chainweb.Test.Pact4.Utils -import Chainweb.Test.Utils -import Chainweb.Utils -import Chainweb.Utils.Serialization -import Chainweb.VerifierPlugin.Hyperlane.Binary -import Chainweb.VerifierPlugin.Hyperlane.Utils - -import Chainweb.Test.Pact4.VerifierPluginTest.Transaction.Utils -import Data.IORef -import Chainweb.Version - -tests :: RocksDb -> TestTree -tests rdb = testGroup "Before225" - [ testGroup "MessageId metadata tests" - [ test generousConfig "verifySuccess" hyperlaneVerifyMessageIdSuccess - , test generousConfig "verifyEmptyRecoveredSignaturesSuccess" hyperlaneVerifyMessageIdEmptyRecoveredSignaturesSuccess - , test generousConfig "verifyWrongSignersFailure" hyperlaneVerifyMessageIdWrongSignersFailure - , test generousConfig "verifyNotEnoughRecoveredSignaturesFailure" hyperlaneVerifyMessageIdNotEnoughRecoveredSignaturesFailure - , test generousConfig "verifyNotEnoughCapabilitySignaturesFailure" hyperlaneVerifyMessageIdNotEnoughCapabilitySignaturesFailure - ] - - , testGroup "MerkleTree metadata tests" - [ test generousConfig "verifyNotEnabledFailure" hyperlaneVerifyMerkleNotEnabledFailure - ] - ] - where - -- This is way more than what is used in production, but during testing - -- we can be generous. - generousConfig = testPactServiceConfig { _pactNewBlockGasLimit = 300_000 } - - test pactConfig tname f = - withResourceT (mkTestBlockDb testVersion rdb) $ \bdbIO -> - testCaseSteps tname $ \step -> do - bdb <- bdbIO - let logger = hunitDummyLogger step - mempools <- onAllChains testVersion $ \_ -> do - mempoolRef <- newIORef mempty - return (mempoolRef, delegateMemPoolAccess mempoolRef) - withWebPactExecutionService logger testVersion pactConfig bdb (snd <$> mempools) $ \(pact,_) -> - runReaderT f $ - SingleEnv bdb pact (mempools ^?! atChain cid . _1) noMiner cid - --- hyperlane message tests - --- | Hyperlane test message TokenMessageERC20 encoded in base64: --- --- { "amount": 0.000000000000000123 --- , "chainId": "4" --- , "recipient": { "test-keys" : {"pred": "keys-all", "keys": ["da1a339bd82d2c2e9180626a00dc043275deb3ababb27b5738abf6b9dcee8db6"]} } --- } --- -hyperlaneTokenMessageBase64 :: T.Text -hyperlaneTokenMessageBase64 = "AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAHsABHsicHJlZCI6ICJrZXlzLWFsbCIsICJrZXlzIjpbImRhMWEzMzliZDgyZDJjMmU5MTgwNjI2YTAwZGMwNDMyNzVkZWIzYWJhYmIyN2I1NzM4YWJmNmI5ZGNlZThkYjYiXX0" - --- | Hyperlane test message encoded in base64 -hyperlaneMessageBase64 :: T.Text -hyperlaneMessageBase64 = encodeB64UrlNoPaddingText $ runPutS $ putHyperlaneMessage $ - HyperlaneMessage - { hmVersion = 3 - , hmNonce = 0 - , hmOriginDomain = 31337 - , hmSender = padLeft $ decodeHexUnsafe "0x7fa9385be102ac3eac297483dd6233d62b3e1496" - , hmDestinationDomain = 626 - , hmRecipient = padLeft $ "6YKzqpDNATmPhUJzc5A17mJbFXH-dBkV" - , hmMessageBody = either (error . show) id $ decodeB64UrlNoPaddingText hyperlaneTokenMessageBase64 - } - - --- ========================================================= --- --- MessageId metadata tests --- --- ========================================================= - --- | Hyperlane test MessageId Metadata encoded in base64 -mkHyperlaneMessageIdMetadataBase64 :: [B.ByteString] -> T.Text -mkHyperlaneMessageIdMetadataBase64 signatures = encodeB64UrlNoPaddingText $ runPutS $ putMessageIdMultisigIsmMetadata $ - MessageIdMultisigIsmMetadata - { mmimOriginMerkleTreeAddress = decodeHexUnsafe "0x2e234dae75c793f67a35089c9d99245e1c58470b" - , mmimSignedCheckpointRoot = decodeHexUnsafe "0x6d1257af3b899a1ffd71849d9f5534753accbe25f85983aac343807a9184bd10" - , mmimSignedCheckpointIndex = 0 - , mmimSignatures = signatures - } - -hyperlaneVerifyMessageIdSuccess :: PactTestM () -hyperlaneVerifyMessageIdSuccess = do - runToHeight 127 - let verifierName = "hyperlane_v3_message" - - let - recipient = pString "6YKzqpDNATmPhUJzc5A17mJbFXH-dBkV" - signers = PList $ V.fromList [ pString "0x909de0a3579891470db562c178905bf17a0e2cc1" ] - cap = SigCapability (QualifiedName (ModuleName "m" (Just (NamespaceName "free"))) "K" noInfo) - [pString hyperlaneTokenMessageBase64, recipient, signers] - - runBlockTest - [ PactTxTest - (buildBasicGas 70000 - $ mkExec' $ mconcat - [ "(namespace 'free)" - , "(module m G" - , "(defcap G () true)" - , "(defcap K (messageBody:string recipient:string signers:[string])" - , " (enforce-verifier '" <> verifierName <> ")" - , " (enforce (= signers [\"0x909de0a3579891470db562c178905bf17a0e2cc1\"]) \"invalid signers\")" - , " (enforce (= recipient \"6YKzqpDNATmPhUJzc5A17mJbFXH-dBkV\") \"invalid recipient\")" - , " (bind (hyperlane-decode-token-message \"" <> hyperlaneTokenMessageBase64 <> "\") " - , " { \"amount\" := amount, " - , " \"chainId\" := chain-id, " - , " \"recipient\" := recipient-guard }" - , " (enforce (= amount 0.000000000000000123) \"invalid amount\")" - , " (enforce (= (create-principal recipient-guard) \"k:da1a339bd82d2c2e9180626a00dc043275deb3ababb27b5738abf6b9dcee8db6\") \"invalid recipient guard\")" - , " )" - , ")" - , "(defun x () (with-capability (K " - , "\"" <> hyperlaneTokenMessageBase64 <> "\"" - , " \"6YKzqpDNATmPhUJzc5A17mJbFXH-dBkV\"" - , " [\"0x909de0a3579891470db562c178905bf17a0e2cc1\"]" - , ")" - , " \"succeeded\")))" - ]) - (assertTxSuccess - "Should deploy module" - (pString "Loaded module free.m, hash CbPVttnlGVDHCi2MFqsbkVjNgscz5SwMInZUA5lmJCk")) - , checkVerifierNotInTx verifierName - , PactTxTest - (buildBasic' - (set cbGasLimit 20000 . set cbVerifiers - [Verifier - (VerifierName verifierName) - (ParsedVerifierProof $ - PList $ V.fromList - [ pString hyperlaneMessageBase64 - - -- metadata with one valid signature - , pString $ mkHyperlaneMessageIdMetadataBase64 - [ decodeHexUnsafe "0x60ab9a1a8c880698ad56cc32210ba75f3f73599afca28e85e3935d9c3252c7f353fec4452218367116ae5cb0df978a21b39a4701887651fff1d6058d629521641c"] - ] - ) - [cap]]) - (mkExec' "(free.m.x)")) - (\cr -> liftIO $ do - assertTxSuccess "should have succeeded" (pString "succeeded") cr - assertEqual "gas should have been charged" 16524 (_crGas cr)) - ] - - -hyperlaneVerifyMessageIdEmptyRecoveredSignaturesSuccess :: PactTestM () -hyperlaneVerifyMessageIdEmptyRecoveredSignaturesSuccess = do - runToHeight 127 - let verifierName = "hyperlane_v3_message" - - let - recipient = pString "6YKzqpDNATmPhUJzc5A17mJbFXH-dBkV" - signers = PList $ V.fromList [] - cap = SigCapability (QualifiedName (ModuleName "m" (Just (NamespaceName "free"))) "K" noInfo) - [pString hyperlaneTokenMessageBase64, recipient, signers] - - runBlockTest - [ PactTxTest - (buildBasicGas 70000 - $ mkExec' $ mconcat - [ "(namespace 'free)" - , "(module m G" - , "(defcap G () true)" - , "(defcap K (messageBody:string recipient:string signers:[string]) (enforce-verifier '" <> verifierName <> "))" - , "(defun x () (with-capability (K" - , " \"" <> hyperlaneTokenMessageBase64 <> "\"" - , " \"6YKzqpDNATmPhUJzc5A17mJbFXH-dBkV\" []) 1)))" - ]) - (assertTxSuccess - "Should deploy module" - (pString "Loaded module free.m, hash qimic9pNaQ9A-hdJEQz8XQx91sPXlrGrn22Jg7GrkGg")) - , checkVerifierNotInTx verifierName - , PactTxTest - (buildBasic' - (set cbGasLimit 20000 . set cbVerifiers - [Verifier - (VerifierName verifierName) - (ParsedVerifierProof $ - PList $ V.fromList - [ pString hyperlaneMessageBase64 - - -- metadata without signatures - , pString $ mkHyperlaneMessageIdMetadataBase64 [] - ] - ) - [cap]]) - (mkExec' "(free.m.x)")) - (\cr -> liftIO $ do - assertTxSuccess "should have succeeded" (pDecimal 1) cr - assertEqual "gas should have been charged" 249 (_crGas cr)) - ] - - -hyperlaneVerifyMessageIdWrongSignersFailure :: PactTestM () -hyperlaneVerifyMessageIdWrongSignersFailure = do - runToHeight 127 - let verifierName = "hyperlane_v3_message" - - let - recipient = pString "6YKzqpDNATmPhUJzc5A17mJbFXH-dBkV" - -- incorrect validator - signers = PList $ V.fromList [ pString "wrongValidator" ] - cap = SigCapability (QualifiedName (ModuleName "m" (Just (NamespaceName "free"))) "K" noInfo) - [pString hyperlaneTokenMessageBase64, recipient, signers] - - runBlockTest - [ PactTxTest - (buildBasicGas 70000 - $ mkExec' $ mconcat - [ "(namespace 'free)" - , "(module m G" - , "(defcap G () true)" - , "(defcap K (messageBody:string recipient:string signers:[string]) (enforce-verifier '" <> verifierName <> "))" - , "(defun x () (with-capability (K" - , " \"" <> hyperlaneTokenMessageBase64 <> "\"" - , " \"6YKzqpDNATmPhUJzc5A17mJbFXH-dBkV\" [\"wrongValidator\"]) 1)))" - ]) - (assertTxSuccess - "Should deploy module" - (pString "Loaded module free.m, hash 8-eX_a7n5D_ETZ7FAW6p_WGTHjDK4DC_RD_gbQl7AVY")) - , checkVerifierNotInTx verifierName - , PactTxTest - (buildBasic' - (set cbGasLimit 20000 . set cbVerifiers - [Verifier - (VerifierName verifierName) - (ParsedVerifierProof $ - PList $ V.fromList - [ pString hyperlaneMessageBase64 - - -- metadata with one valid signature - , pString $ mkHyperlaneMessageIdMetadataBase64 - [ decodeHexUnsafe "0x60ab9a1a8c880698ad56cc32210ba75f3f73599afca28e85e3935d9c3252c7f353fec4452218367116ae5cb0df978a21b39a4701887651fff1d6058d629521641c"] - ] - ) - [cap]]) - (mkExec' "(free.m.x)")) - (\cr -> liftIO $ do - let errMsg = "Tx verifier error: Signers don't match. Expected: PList [PLiteral (LString {_lString = \"0x909de0a3579891470db562c178905bf17a0e2cc1\"})] but got PList [PLiteral (LString {_lString = \"wrongValidator\"})]" - assertTxFailure "should have failed with signers don't match" errMsg cr - assertEqual "gas should have been charged" 20000 (_crGas cr)) - ] - -hyperlaneVerifyMessageIdNotEnoughRecoveredSignaturesFailure :: PactTestM () -hyperlaneVerifyMessageIdNotEnoughRecoveredSignaturesFailure = do - runToHeight 127 - let verifierName = "hyperlane_v3_message" - - let - recipient = pString "6YKzqpDNATmPhUJzc5A17mJbFXH-dBkV" - signers = PList $ V.fromList [ pString "wrongValidator" ] - cap = SigCapability (QualifiedName (ModuleName "m" (Just (NamespaceName "free"))) "K" noInfo) - [pString hyperlaneTokenMessageBase64, recipient, signers] - - runBlockTest - [ PactTxTest - (buildBasicGas 70000 - $ mkExec' $ mconcat - [ "(namespace 'free)" - , "(module m G" - , "(defcap G () true)" - , "(defcap K (messageBody:string recipient:string signers:[string]) (enforce-verifier '" <> verifierName <> "))" - , "(defun x () (with-capability (K" - , " \"" <> hyperlaneTokenMessageBase64 <> "\"" - , " \"6YKzqpDNATmPhUJzc5A17mJbFXH-dBkV\" [\"wrongValidator\"]) 1)))" - ]) - (assertTxSuccess - "Should deploy module" - (pString "Loaded module free.m, hash 8-eX_a7n5D_ETZ7FAW6p_WGTHjDK4DC_RD_gbQl7AVY")) - , checkVerifierNotInTx verifierName - , PactTxTest - (buildBasic' - (set cbGasLimit 20000 . set cbVerifiers - [Verifier - (VerifierName verifierName) - (ParsedVerifierProof $ - PList $ V.fromList - [ pString hyperlaneMessageBase64 - - -- metadata without signatures - , pString $ mkHyperlaneMessageIdMetadataBase64 [] - ] - ) - [cap]]) - (mkExec' "(free.m.x)")) - (\cr -> liftIO $ do - let errMsg = "Tx verifier error: Signers don't match. Expected: PList [] but got PList [PLiteral (LString {_lString = \"wrongValidator\"})]" - assertTxFailure "should have failed with signers don't match" errMsg cr - assertEqual "gas should have been charged" 20000 (_crGas cr)) - ] - -hyperlaneVerifyMessageIdNotEnoughCapabilitySignaturesFailure :: PactTestM () -hyperlaneVerifyMessageIdNotEnoughCapabilitySignaturesFailure = do - runToHeight 127 - let verifierName = "hyperlane_v3_message" - - let - recipient = pString "6YKzqpDNATmPhUJzc5A17mJbFXH-dBkV" - signers = PList $ V.fromList [ pString "0x909de0a3579891470db562c178905bf17a0e2cc1" ] - cap = SigCapability (QualifiedName (ModuleName "m" (Just (NamespaceName "free"))) "K" noInfo) - [pString hyperlaneTokenMessageBase64, recipient, signers] - - runBlockTest - [ PactTxTest - (buildBasicGas 70000 - $ mkExec' $ mconcat - [ "(namespace 'free)" - , "(module m G" - , "(defcap G () true)" - , "(defcap K (messageBody:string recipient:string signers:[string]) (enforce-verifier '" <> verifierName <> "))" - , "(defun x () (with-capability (K" - , " \"" <> hyperlaneTokenMessageBase64 <> "\"" - , " \"6YKzqpDNATmPhUJzc5A17mJbFXH-dBkV\" [\"0x909de0a3579891470db562c178905bf17a0e2cc1\"]) 1)))" - ]) - (assertTxSuccess - "Should deploy module" - (pString "Loaded module free.m, hash fpbofdp-l4YpUMhAcJGrGzu1H-l1Y1mA6JTjJi41ADk")) - , checkVerifierNotInTx verifierName - , PactTxTest - (buildBasic' - (set cbGasLimit 40000 . set cbVerifiers - [Verifier - (VerifierName verifierName) - (ParsedVerifierProof $ - PList $ V.fromList - [ pString hyperlaneMessageBase64 - - -- metadata with one valid signature repeated twice - , pString $ mkHyperlaneMessageIdMetadataBase64 - [ decodeHexUnsafe "0x60ab9a1a8c880698ad56cc32210ba75f3f73599afca28e85e3935d9c3252c7f353fec4452218367116ae5cb0df978a21b39a4701887651fff1d6058d629521641c" - , decodeHexUnsafe "0x60ab9a1a8c880698ad56cc32210ba75f3f73599afca28e85e3935d9c3252c7f353fec4452218367116ae5cb0df978a21b39a4701887651fff1d6058d629521641c" - ] - ] - ) - [cap]]) - (mkExec' "(free.m.x)")) - (\cr -> liftIO $ do - let errMsg = "Tx verifier error: Signers don't match. Expected: PList [PLiteral (LString {_lString = \"0x909de0a3579891470db562c178905bf17a0e2cc1\"}),PLiteral (LString {_lString = \"0x909de0a3579891470db562c178905bf17a0e2cc1\"})] but got PList [PLiteral (LString {_lString = \"0x909de0a3579891470db562c178905bf17a0e2cc1\"})]" - assertTxFailure "should have failed with signers don't match" errMsg cr - assertEqual "gas should have been charged" 40000 (_crGas cr)) - ] - --- ========================================================= --- --- MerkleTree metadata tests --- --- ========================================================= - --- | Hyperlane test MerkleTree Metadata encoded in base64 --- Test data was generated using the following test in the hyperlane codebase --- https://github.com/hyperlane-xyz/hyperlane-monorepo/blob/b14f997810ebd7dbdff2ac6622a149ae77010ae3/solidity/test/isms/MultisigIsm.t.sol#L35 -mkHyperlaneMerkleTreeMetadataBase64 :: B.ByteString -> [B.ByteString] -> T.Text -mkHyperlaneMerkleTreeMetadataBase64 proof signatures = encodeB64UrlNoPaddingText $ runPutS $ putMerkleRootMultisigIsmMetadata $ - MerkleRootMultisigIsmMetadata - { mrmimOriginMerkleTreeAddress = decodeHexUnsafe "0x2e234dae75c793f67a35089c9d99245e1c58470b" - , mrmimMessageIdIndex = 0 - , mrmimSignedCheckpointMessageId = decodeHexUnsafe "0x6f370c453c86ad681e936741683cceca8f13c46f2a49b1c9f8c6a23b5bb97aae" - , mrmimMerkleProof = proof - , mrmimSignedCheckpointIndex = 0 - , mrmimSignatures = signatures - } - -hyperlaneMerkleTreeCorrectProof :: B.ByteString -hyperlaneMerkleTreeCorrectProof = decodeHexUnsafe "0x0000000000000000000000000000000000000000000000000000000000000000ad3228b676f7d3cd4284a5443f17f1962b36e491b30a40b2405849e597ba5fb5b4c11951957c6f8f642c4af61cd6b24640fec6dc7fc607ee8206a99e92410d3021ddb9a356815c3fac1026b6dec5df3124afbadb485c9ba5a3e3398a04b7ba85e58769b32a1beaf1ea27375a44095a0d1fb664ce2dd358e7fcbfb78c26a193440eb01ebfc9ed27500cd4dfc979272d1f0913cc9f66540d7e8005811109e1cf2d887c22bd8750d34016ac3c66b5ff102dacdd73f6b014e710b51e8022af9a1968ffd70157e48063fc33c97a050f7f640233bf646cc98d9524c6b92bcf3ab56f839867cc5f7f196b93bae1e27e6320742445d290f2263827498b54fec539f756afcefad4e508c098b9a7e1d8feb19955fb02ba9675585078710969d3440f5054e0f9dc3e7fe016e050eff260334f18a5d4fe391d82092319f5964f2e2eb7c1c3a5f8b13a49e282f609c317a833fb8d976d11517c571d1221a265d25af778ecf8923490c6ceeb450aecdc82e28293031d10c7d73bf85e57bf041a97360aa2c5d99cc1df82d9c4b87413eae2ef048f94b4d3554cea73d92b0f7af96e0271c691e2bb5c67add7c6caf302256adedf7ab114da0acfe870d449a3a489f781d659e8beccda7bce9f4e8618b6bd2f4132ce798cdc7a60e7e1460a7299e3c6342a579626d22733e50f526ec2fa19a22b31e8ed50f23cd1fdf94c9154ed3a7609a2f1ff981fe1d3b5c807b281e4683cc6d6315cf95b9ade8641defcb32372f1c126e398ef7a5a2dce0a8a7f68bb74560f8f71837c2c2ebbcbf7fffb42ae1896f13f7c7479a0b46a28b6f55540f89444f63de0378e3d121be09e06cc9ded1c20e65876d36aa0c65e9645644786b620e2dd2ad648ddfcbf4a7e5b1a3a4ecfe7f64667a3f0b7e2f4418588ed35a2458cffeb39b93d26f18d2ab13bdce6aee58e7b99359ec2dfd95a9c16dc00d6ef18b7933a6f8dc65ccb55667138776f7dea101070dc8796e3774df84f40ae0c8229d0d6069e5c8f39a7c299677a09d367fc7b05e3bc380ee652cdc72595f74c7b1043d0e1ffbab734648c838dfb0527d971b602bc216c9619ef0abf5ac974a1ed57f4050aa510dd9c74f508277b39d7973bb2dfccc5eeb0618db8cd74046ff337f0a7bf2c8e03e10f642c1886798d71806ab1e888d9e5ee87d0838c5655cb21c6cb83313b5a631175dff4963772cce9108188b34ac87c81c41e662ee4dd2dd7b2bc707961b1e646c4047669dcb6584f0d8d770daf5d7e7deb2e388ab20e2573d171a88108e79d820e98f26c0b84aa8b2f4aa4968dbb818ea32293237c50ba75ee485f4c22adf2f741400bdf8d6a9cc7df7ecae576221665d7358448818bb4ae4562849e949e17ac16e0be16688e156b5cf15e098c627c0056a9" - -deployContractForMerkleTests :: PactTxTest -deployContractForMerkleTests = - PactTxTest - (buildBasicGas 70000 - $ mkExec' $ mconcat - [ "(namespace 'free)" - , "(module m G" - , "(defcap G () true)" - , "(defcap K (messageBody:string recipient:string signers:[string])" - , " (enforce-verifier 'hyperlane_v3_message)" - , " (enforce (= signers [\"0x4bd34992e0994e9d3c53c1ccfe5c2e38d907338e\"]) \"invalid signers\")" - , " (enforce (= recipient \"6YKzqpDNATmPhUJzc5A17mJbFXH-dBkV\") \"invalid recipient\")" - , " (bind (hyperlane-decode-token-message \"" <> hyperlaneTokenMessageBase64 <> "\") " - , " { \"amount\" := amount, " - , " \"chainId\" := chain-id, " - , " \"recipient\" := recipient-guard }" - , " (enforce (= amount 0.000000000000000123) \"invalid amount\")" - , " (enforce (= (create-principal recipient-guard) \"k:da1a339bd82d2c2e9180626a00dc043275deb3ababb27b5738abf6b9dcee8db6\") \"invalid recipient guard\")" - , " )" - , ")" - , "(defun x () (with-capability (K " - , "\"" <> hyperlaneTokenMessageBase64 <> "\"" - , " \"6YKzqpDNATmPhUJzc5A17mJbFXH-dBkV\"" - , " [\"0x4bd34992e0994e9d3c53c1ccfe5c2e38d907338e\"]" - , ")" - , " \"succeeded\")))" - ]) - (assertTxSuccess - "Should deploy module" - (pString "Loaded module free.m, hash kU7y3IbldFn1zeYRrrkT0BvLwjtBltyMsMR_E_SL5wU")) - --- | Calls '(free.m.x)' from 'deployContractForMerkleTests' -mkMerkleMetadatWithOneSignatureCall :: B.ByteString -> MempoolCmdBuilder -mkMerkleMetadatWithOneSignatureCall merkleProof = buildBasic' - (set cbGasLimit 20000 . set cbVerifiers - [Verifier - (VerifierName "hyperlane_v3_message") - (ParsedVerifierProof $ - PList $ V.fromList - [ pString hyperlaneMessageBase64 - - , pString $ mkHyperlaneMerkleTreeMetadataBase64 merkleProof - [ decodeHexUnsafe "0xb3df841e9e3036f0858b0376280ef6692be293b53da3fba3384c82d6ca86704619cd7700147e3439fb66a985bdb310a4273204a0b5e5337deec0f00dfc8a5a171c" ] - ] - ) - [cap]]) - (mkExec' "(free.m.x)") - where - recipient = pString "6YKzqpDNATmPhUJzc5A17mJbFXH-dBkV" - signers = PList $ V.fromList [ pString "0x4bd34992e0994e9d3c53c1ccfe5c2e38d907338e" ] - cap = SigCapability (QualifiedName (ModuleName "m" (Just (NamespaceName "free"))) "K" noInfo) - [pString hyperlaneTokenMessageBase64, recipient, signers] - -hyperlaneVerifyMerkleNotEnabledFailure :: PactTestM () -hyperlaneVerifyMerkleNotEnabledFailure = do - runToHeight 127 - - runBlockTest - [ deployContractForMerkleTests - , checkVerifierNotInTx "hyperlane_v3_message" - , PactTxTest (mkMerkleMetadatWithOneSignatureCall hyperlaneMerkleTreeCorrectProof) - (\cr -> liftIO $ do - assertTxFailure "should have failed with uncaught exception" "Tx verifier error: Uncaught exception in verifier" cr - assertEqual "gas should have been charged" 20000 (_crGas cr)) - ] diff --git a/test/lib/Chainweb/Test/Pact4/VerifierPluginTest/Transaction/Utils.hs b/test/lib/Chainweb/Test/Pact4/VerifierPluginTest/Transaction/Utils.hs deleted file mode 100644 index 841e5ca820..0000000000 --- a/test/lib/Chainweb/Test/Pact4/VerifierPluginTest/Transaction/Utils.hs +++ /dev/null @@ -1,248 +0,0 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE NumericUnderscores #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeApplications #-} - -module Chainweb.Test.Pact4.VerifierPluginTest.Transaction.Utils where - -import Control.Concurrent.MVar -import Control.Lens hiding ((.=)) -import Control.Monad -import Control.Monad.Reader -import qualified Data.HashMap.Strict as HM -import Data.IORef -import qualified Data.Text as T -import qualified Data.Vector as V -import Test.Tasty.HUnit - --- internal modules - -import Pact.Types.Command -import Pact.Types.Hash -import Pact.Types.PactError -import Pact.Types.PactValue -import Pact.Types.Pretty -import Pact.Types.RPC -import Pact.Types.Term - -import Chainweb.BlockCreationTime -import Chainweb.BlockHeader -import Chainweb.BlockHeight -import Chainweb.ChainId -import Chainweb.Cut -import Chainweb.Mempool.Mempool -import Chainweb.Miner.Pact - -import Chainweb.Payload -import Chainweb.Test.Cut -import Chainweb.Test.Cut.TestBlockDb -import Chainweb.Test.Pact4.Utils -import Chainweb.Test.Utils -import Chainweb.Test.TestVersions -import Chainweb.Time -import Chainweb.Utils -import Chainweb.Version -import Chainweb.WebPactExecutionService -import Chainweb.Payload.PayloadStore (lookupPayloadWithHeight) -import Chainweb.Pact.Types (MemPoolAccess, mpaGetBlock) - -testVersion :: ChainwebVersion -testVersion = slowForkingCpmTestVersion petersen - -cid :: ChainId -cid = unsafeChainId 9 - -- several tests in this file expect chain 9 - -data SingleEnv = SingleEnv - { _menvBdb :: !TestBlockDb - , _menvPact :: !WebPactExecutionService - , _menvMpa :: !(IORef MemPoolAccess) - , _menvMiner :: !Miner - , _menvChainId :: !ChainId - } - -makeLenses ''SingleEnv - -type PactTestM = ReaderT SingleEnv IO - -newtype MempoolCmdBuilder = MempoolCmdBuilder - { _mempoolCmdBuilder :: ChainId -> BlockCreationTime -> CmdBuilder - } - --- | Block filler. A 'Nothing' result means "skip this filler". -newtype MempoolBlock = MempoolBlock - { _mempoolBlock :: ChainId -> BlockCreationTime -> Maybe [MempoolCmdBuilder] - } - --- | Mempool with an ordered list of fillers. -newtype PactMempool = PactMempool - { _pactMempool :: [MempoolBlock] - } - deriving (Semigroup,Monoid) - - --- | Pair a builder with a test -data PactTxTest = PactTxTest - { _pttBuilder :: MempoolCmdBuilder - , _pttTest :: CommandResult Hash -> Assertion - } - -checkVerifierNotInTx :: T.Text -> PactTxTest -checkVerifierNotInTx v = PactTxTest - (buildBasic (mkExec' "(free.m.x)")) - (\cr -> liftIO $ do - assertTxFailure - "verifier not present" - ("Verifier failure " <> pretty v <> ": not in transaction") - cr - assertTxGas "verifier errors charge all gas" 10000 cr) - --- | Sets mempool with block fillers. A matched filler --- (returning a 'Just' result) is executed and removed from the list. --- Fillers are tested in order. -setPactMempool :: PactMempool -> PactTestM () -setPactMempool (PactMempool fs) = do - mpa <- view menvMpa - mpsRef <- liftIO $ newIORef fs - liftIO $ writeIORef mpa $ mempty { - mpaGetBlock = \_ -> go mpsRef - } - where - go ref mempoolPreBlockCheck bHeight bHash bct = do - mps <- readIORef ref - let runMps i = \case - [] -> return mempty - (mp:r) -> case _mempoolBlock mp cid bct of - Just bs -> do - writeIORef ref (take i mps ++ r) - cmds <- fmap V.fromList $ forM bs $ \b -> - buildCwCmd (sshow bct) testVersion $ _mempoolCmdBuilder b cid bct - tos <- mempoolPreBlockCheck bHeight bHash ((fmap . fmap . fmap) _pcCode cmds) - return $ V.fromList - [ t - | Right t <- V.toList tos - ] - -- return $ fmap fst $ V.filter snd (V.zip cmds validationResults) - Nothing -> runMps (succ i) r - runMps 0 mps - -filterBlock :: (ChainId -> BlockCreationTime -> Bool) -> MempoolBlock -> MempoolBlock -filterBlock f (MempoolBlock b) = MempoolBlock $ \chain bct -> - if f chain bct then b chain bct else Nothing - -blockForChain :: ChainId -> MempoolBlock -> MempoolBlock -blockForChain chid = filterBlock $ \chain _ -> - chain == chid - -runCut' :: PactTestM () -runCut' = do - pact <- view menvPact - bdb <- view menvBdb - miner <- view menvMiner - liftIO $ runCut testVersion bdb pact (offsetBlockTime second) zeroNoncer miner - -assertTxGas :: (HasCallStack, MonadIO m) => String -> Gas -> CommandResult Hash -> m () -assertTxGas msg g = liftIO . assertEqual msg g . _crGas - -assertTxSuccess - :: HasCallStack - => MonadIO m - => String - -> PactValue - -> CommandResult Hash - -> m () -assertTxSuccess msg r tx = do - liftIO $ assertEqual msg (Just r) - (tx ^? crResult . to _pactResult . _Right) - --- | Exact match on error doc -assertTxFailure :: (HasCallStack, MonadIO m) => String -> Doc -> CommandResult Hash -> m () -assertTxFailure msg d tx = - liftIO $ assertEqual msg (Just d) - (tx ^? crResult . to _pactResult . _Left . to peDoc) - --- | Run a single mempool block on current chain with tests for each tx. --- Limitations: can only run a single-chain, single-refill test for --- a given cut height. -runBlockTest :: HasCallStack => [PactTxTest] -> PactTestM () -runBlockTest pts = do - chid <- view menvChainId - setPactMempool $ PactMempool [testsToBlock chid pts] - runCut' - runBlockTests pts - --- | Convert tests to block for specified chain. -testsToBlock :: ChainId -> [PactTxTest] -> MempoolBlock -testsToBlock chid pts = blockForChain chid $ MempoolBlock $ \_ _ -> - pure $ map _pttBuilder pts - --- | Run tests on current cut and chain. -runBlockTests :: HasCallStack => [PactTxTest] -> PactTestM () -runBlockTests pts = do - rs <- txResults - liftIO $ assertEqual "Result length should equal transaction length" (length pts) (length rs) - zipWithM_ go pts (V.toList rs) - where - go :: PactTxTest -> CommandResult Hash -> PactTestM () - go (PactTxTest _ t) cr = liftIO $ t cr - --- | Run cuts to block height. -runToHeight :: BlockHeight -> PactTestM () -runToHeight bhi = do - chid <- view menvChainId - bh <- getHeader chid - when (view blockHeight bh < bhi) $ do - runCut' - runToHeight bhi - -signSender00 :: CmdBuilder -> CmdBuilder -signSender00 = set cbSigners [mkEd25519Signer' sender00 []] - -setFromHeader :: BlockHeader -> CmdBuilder -> CmdBuilder -setFromHeader bh = - set cbChainId (_chainId bh) - . set cbCreationTime (toTxCreationTime $ _bct $ view blockCreationTime bh) - -buildBasic - :: PactRPC T.Text - -> MempoolCmdBuilder -buildBasic = buildBasic' id - -buildBasicGas :: GasLimit -> PactRPC T.Text -> MempoolCmdBuilder -buildBasicGas g = buildBasic' (set cbGasLimit g) - --- | Build with specified setter to mutate defaults. -buildBasic' - :: (CmdBuilder -> CmdBuilder) - -> PactRPC T.Text - -> MempoolCmdBuilder -buildBasic' f r = MempoolCmdBuilder $ \chain bct -> - f $ signSender00 - $ set cbChainId chain - $ set cbCreationTime (toTxCreationTime $ _bct bct) - $ set cbRPC r - $ defaultCmd - --- | Get output on latest cut for chain -getPWO :: ChainId -> PactTestM (PayloadWithOutputs,BlockHeader) -getPWO chid = do - (TestBlockDb _ pdb _) <- view menvBdb - h <- getHeader chid - Just pwo <- liftIO $ lookupPayloadWithHeight pdb (Just $ view blockHeight h) (view blockPayloadHash h) - return (pwo,h) - -getHeader :: ChainId -> PactTestM BlockHeader -getHeader chid = do - (TestBlockDb _ _ cmv) <- view menvBdb - c <- liftIO $ readMVar cmv - fromMaybeM (userError $ "chain lookup failed for " ++ show chid) $ HM.lookup chid (_cutMap c) - -txResults :: HasCallStack => PactTestM (V.Vector (CommandResult Hash)) -txResults = do - chid <- view menvChainId - (o,_h) <- getPWO chid - forM (_payloadWithOutputsTransactions o) $ \(_,txo) -> - decodeStrictOrThrow @_ @(CommandResult Hash) (_transactionOutputBytes txo) diff --git a/test/lib/Chainweb/Test/Pact5/Utils.hs b/test/lib/Chainweb/Test/Pact5/Utils.hs deleted file mode 100644 index 23f0d6d1e9..0000000000 --- a/test/lib/Chainweb/Test/Pact5/Utils.hs +++ /dev/null @@ -1,231 +0,0 @@ -{-# language - FlexibleContexts - , ImportQualifiedPost - , LambdaCase - , NumericUnderscores - , OverloadedStrings - , PackageImports - , TypeApplications -#-} - -module Chainweb.Test.Pact5.Utils - ( initCheckpointer - , pactTxFrom4To5 - - -- * Logging - , getTestLogLevel - , testLogFn - , getTestLogger - - -- * Mempool - , mempoolInsertPact5 - , mempoolLookupPact5 - - -- * Resources - , withTempSQLiteResource - , withInMemSQLiteResource - , withPactQueue - , withMempool - , withRunPactService - , withBlockDbs - - -- * Properties - , event - , successfulTx - -- * Utilities - , coinModuleName - ) - where - -import Chainweb.Chainweb (validatingMempoolConfig) -import "pact" Pact.Types.Command qualified as Pact4 -import "pact" Pact.Types.Hash qualified as Pact4 -import Chainweb.ChainId -import Chainweb.Logger -import Chainweb.Mempool.Consensus -import Chainweb.Mempool.InMem -import Chainweb.Mempool.Mempool (InsertType (..), LookupResult(..), MempoolBackend (..), TransactionHash(..)) ---import Chainweb.Pact.Backend.RelationalCheckpointer -import Chainweb.Pact.PactService.Checkpointer.Internal (initCheckpointerResources) -import Chainweb.Pact.Backend.Types (Checkpointer, IntraBlockPersistence(..), SQLiteEnv) -import Chainweb.Pact.Backend.Utils (openSQLiteConnection, closeSQLiteConnection, chainwebPragmas) -import Chainweb.Pact.PactService -import Chainweb.Pact.PactService.Pact4.ExecBlock () -import Chainweb.Pact.Service.PactInProcApi -import Chainweb.Pact.Service.PactQueue -import Chainweb.Pact.Types -import Chainweb.Pact4.Transaction qualified as Pact4 -import Chainweb.Pact5.Transaction qualified as Pact5 -import Chainweb.Payload.PayloadStore -import Chainweb.Payload.PayloadStore.RocksDB -import Chainweb.Storage.Table.RocksDB -import Chainweb.Utils -import Chainweb.Version -import Chainweb.WebBlockHeaderDB -import Chainweb.WebPactExecutionService -import Control.Concurrent hiding (throwTo) -import Control.Exception (AsyncException (..), throwTo) -import Control.Lens hiding (elements, only) -import Control.Monad -import Control.Monad.IO.Class -import Control.Monad.Trans.Resource (ResourceT, allocate) -import Control.Monad.Trans.Resource qualified as Resource -import Data.Aeson qualified as Aeson -import Data.ByteString.Short qualified as SBS -import Data.HashSet (HashSet) -import Data.HashSet qualified as HashSet -import Data.Maybe (fromMaybe) -import Data.Text (Text) -import Data.Text qualified as Text -import Data.Text.Encoding qualified as Text -import Data.Text.IO qualified as Text -import Data.Vector (Vector) -import Data.Vector qualified as Vector -import Pact.Core.Command.Types qualified as Pact5 -import Pact.Core.Hash qualified as Pact5 -import Pact.Core.Pretty qualified as Pact5 -import Pact.JSON.Encode qualified as J -import Pact.Types.Gas qualified as Pact4 -import System.Environment (lookupEnv) -import System.LogLevel -import PropertyMatchers ((?)) -import PropertyMatchers qualified as P -import Pact.Core.PactValue -import Pact.Core.Capabilities -import Pact.Core.Names - -withBlockDbs :: ChainwebVersion -> RocksDb -> ResourceT IO (PayloadDb RocksDbTable, WebBlockHeaderDb) -withBlockDbs v rdb = do - webBHDb <- liftIO $ initWebBlockHeaderDb rdb v - let payloadDb = newPayloadDb rdb - liftIO $ initializePayloadDb v payloadDb - return (payloadDb, webBHDb) - --- | Internal. See https://www.sqlite.org/c3ref/open.html -withSQLiteResource - :: String - -> ResourceT IO SQLiteEnv -withSQLiteResource file = snd <$> allocate - (openSQLiteConnection file chainwebPragmas) - closeSQLiteConnection - --- | Open a temporary file-backed SQLite database. -withTempSQLiteResource :: ResourceT IO SQLiteEnv -withTempSQLiteResource = withSQLiteResource "" - --- | Open a temporary in-memory SQLite database. -withInMemSQLiteResource :: ResourceT IO SQLiteEnv -withInMemSQLiteResource = withSQLiteResource ":memory:" - -withPactQueue :: ResourceT IO PactQueue -withPactQueue = do - liftIO (newPactQueue 2_000) - -withMempool :: () - => ChainwebVersion - -> ChainId - -> PactQueue - -> ResourceT IO (MempoolBackend Pact4.UnparsedTransaction) -withMempool v cid pactQueue = do - pactExecutionServiceVar <- liftIO $ newMVar (mkPactExecutionService pactQueue) - let mempoolCfg = validatingMempoolConfig cid v (Pact4.GasLimit 150_000) (Pact4.GasPrice 1e-8) pactExecutionServiceVar - liftIO $ startInMemoryMempoolTest mempoolCfg - -withRunPactService :: (Logger logger) - => logger - -> ChainwebVersion - -> ChainId - -> PactQueue - -> MempoolBackend Pact4.UnparsedTransaction - -> WebBlockHeaderDb - -> PayloadDb RocksDbTable - -> PactServiceConfig - -> ResourceT IO () -withRunPactService logger v cid pactQueue mempool webBHDb payloadDb pactServiceConfig = do - sqlite <- withTempSQLiteResource - blockHeaderDb <- liftIO $ getWebBlockHeaderDb webBHDb cid - mempoolConsensus <- liftIO $ mkMempoolConsensus mempool blockHeaderDb (Just payloadDb) - let mempoolAccess = pactMemPoolAccess mempoolConsensus logger - - void $ Resource.allocate - (forkIO $ runPactService v cid logger Nothing pactQueue mempoolAccess blockHeaderDb payloadDb sqlite pactServiceConfig) --bhdb (_bdbPayloadDb tdb) sqlite pactServiceConfig) - (\tid -> throwTo tid ThreadKilled) - --- | Insert a 'Pact5.Transaction' into the mempool. The mempool currently operates by default on --- 'Pact4.UnparsedTransaction's, so the txs have to be converted. -mempoolInsertPact5 :: MempoolBackend Pact4.UnparsedTransaction -> InsertType -> [Pact5.Transaction] -> IO () -mempoolInsertPact5 mp insertType txs = do - let unparsedTxs :: [Pact4.UnparsedTransaction] - unparsedTxs = flip map txs $ \tx -> - case codecDecode Pact4.rawCommandCodec (codecEncode Pact5.payloadCodec tx) of - Left err -> error err - Right a -> a - mempoolInsert mp insertType $ Vector.fromList unparsedTxs - --- | Looks up transactions in the mempool. Returns a set which indicates pending membership of the mempool. -mempoolLookupPact5 :: MempoolBackend Pact4.UnparsedTransaction -> Vector Pact5.Hash -> IO (HashSet Pact5.Hash) -mempoolLookupPact5 mp hashes = do - results <- mempoolLookup mp $ Vector.map (TransactionHash . Pact5.unHash) hashes - return $ HashSet.fromList $ Vector.toList $ flip Vector.mapMaybe results $ \case - Missing -> Nothing - Pending tx -> Just $ Pact5.Hash $ Pact4.unHash $ Pact4.toUntypedHash $ Pact4._cmdHash tx - --- | Initializes a checkpointer for a given chain. -initCheckpointer :: ChainwebVersion -> ChainId -> SQLiteEnv -> IO (Checkpointer GenericLogger) -initCheckpointer v cid sql = do - logLevel <- getTestLogLevel - initCheckpointerResources defaultModuleCacheLimit sql DoNotPersistIntraBlockWrites (genericLogger logLevel (testLogFn logLevel)) v cid - -pactTxFrom4To5 :: Pact4.Transaction -> Pact5.Transaction -pactTxFrom4To5 tx = - let - e = do - let json = J.encode (fmap (Text.decodeUtf8 . SBS.fromShort . Pact4.payloadBytes) tx) - cmdWithPayload <- Aeson.eitherDecode @(Pact5.Command Text) json - over _Left Pact5.renderCompactString $ Pact5.parseCommand cmdWithPayload - in - case e of - Left err -> error err - Right cmds -> cmds - -getTestLogLevel :: IO LogLevel -getTestLogLevel = do - let parseLogLevel txt = case Text.toUpper txt of - "DEBUG" -> Debug - "INFO" -> Info - "WARN" -> Warn - "ERROR" -> Error - _ -> Error - fromMaybe Error . fmap (parseLogLevel . Text.pack) <$> lookupEnv "CHAINWEB_TEST_LOG_LEVEL" - --- | Generally, we want tests to throw an exception on an Error log, but we don't want --- to throw an exception on any other level of log. -testLogFn :: LogLevel -> Text -> IO () -testLogFn ll msg = case ll of - Error -> do - error (Text.unpack msg) - _ -> do - Text.putStrLn msg - -getTestLogger :: IO GenericLogger -getTestLogger = do - logLevel <- getTestLogLevel - return $ genericLogger logLevel (testLogFn logLevel) - --- usually we don't want to check the module hash -event - :: P.Prop Text - -> P.Prop [PactValue] - -> P.Prop ModuleName - -> P.Prop (PactEvent PactValue) -event n args modName = P.checkAll - [ P.fun _peName n - , P.fun _peArgs args - , P.fun _peModule modName - ] - -coinModuleName :: ModuleName -coinModuleName = ModuleName "coin" Nothing - -successfulTx :: P.Prop (Pact5.CommandResult log err) -successfulTx = P.fun Pact5._crResult ? P.match Pact5._PactResultOk P.succeed diff --git a/test/lib/Chainweb/Test/RestAPI/Client_.hs b/test/lib/Chainweb/Test/RestAPI/Client_.hs index 9260da9d2c..02dbe58768 100644 --- a/test/lib/Chainweb/Test/RestAPI/Client_.hs +++ b/test/lib/Chainweb/Test/RestAPI/Client_.hs @@ -33,10 +33,8 @@ module Chainweb.Test.RestAPI.Client_ , headerClient' , hashesClient' , headersClient' -, blocksClient' , branchHashesClient' , branchHeadersClient' -, branchBlocksClient' ) where import Data.Functor.Identity @@ -45,15 +43,14 @@ import Servant.API.ContentTypes -- internal modules -import Chainweb.Block import Chainweb.BlockHash import Chainweb.BlockHeader import Chainweb.BlockHeaderDB import Chainweb.BlockHeaderDB.RestAPI import Chainweb.Cut.CutHashes import Chainweb.CutDB.RestAPI -import Chainweb.Payload -import Chainweb.Payload.RestAPI +import Chainweb.Pact.Payload +import Chainweb.Pact.Payload.RestAPI import Chainweb.TreeDB import Chainweb.Utils.Paging import Chainweb.Version @@ -67,24 +64,24 @@ import Chainweb.BlockHeight (BlockHeight) -- Payload API payloadGetClient' - :: ChainwebVersion - -> ChainId + :: HasVersion + => ChainId -> BlockPayloadHash -> Maybe BlockHeight -> ClientM_ PayloadData -payloadGetClient' v c = runIdentity $ do - (SomeSing (SChainwebVersion :: Sing v)) <- return $ toSing (_versionName v) +payloadGetClient' c = runIdentity $ do + (SomeSing (SChainwebVersion :: Sing v)) <- return $ toSing (_versionName implicitVersion) (SomeSing (SChainId :: Sing c)) <- return $ toSing c return $ client_ @(PayloadGetApi v c) outputsGetClient' - :: ChainwebVersion - -> ChainId + :: HasVersion + => ChainId -> BlockPayloadHash -> Maybe BlockHeight -> ClientM_ PayloadWithOutputs -outputsGetClient' v c = runIdentity $ do - (SomeSing (SChainwebVersion :: Sing v)) <- return $ toSing (_versionName v) +outputsGetClient' c = runIdentity $ do + (SomeSing (SChainwebVersion :: Sing v)) <- return $ toSing (_versionName implicitVersion) (SomeSing (SChainId :: Sing c)) <- return $ toSing c return $ client_ @(OutputsGetApi v c) @@ -92,107 +89,80 @@ outputsGetClient' v c = runIdentity $ do -- Cut API cutGetClient' - :: ChainwebVersion - -> Maybe MaxRank + :: HasVersion + => Maybe MaxRank -> ClientM_ CutHashes -cutGetClient' v = runIdentity $ do - (SomeSing (SChainwebVersion :: Sing v)) <- return $ toSing (_versionName v) +cutGetClient' = runIdentity $ do + (SomeSing (SChainwebVersion :: Sing v)) <- return $ toSing (_versionName implicitVersion) return $ client_ @(CutGetApi v) cutPutClient' - :: ChainwebVersion - -> CutHashes + :: HasVersion + => CutHashes -> ClientM_ NoContent -cutPutClient' v = runIdentity $ do - (SomeSing (SChainwebVersion :: Sing v)) <- return $ toSing (_versionName v) +cutPutClient' = runIdentity $ do + (SomeSing (SChainwebVersion :: Sing v)) <- return $ toSing (_versionName implicitVersion) return $ client_ @(CutPutApi v) -- -------------------------------------------------------------------------- -- -- BlockHeaderDB API hashesClient' - :: ChainwebVersion - -> ChainId + :: HasVersion + => ChainId -> Maybe Limit -> Maybe (NextItem BlockHash) -> Maybe MinRank -> Maybe MaxRank -> ClientM_ (Page (NextItem BlockHash) BlockHash) -hashesClient' v c = runIdentity $ do - (SomeSing (SChainwebVersion :: Sing v)) <- return $ toSing (_versionName v) +hashesClient' c = runIdentity $ do + (SomeSing (SChainwebVersion :: Sing v)) <- return $ toSing (_versionName implicitVersion) (SomeSing (SChainId :: Sing c)) <- return $ toSing c return $ client_ @(HashesApi v c) -headerClient' :: ChainwebVersion -> ChainId -> BlockHash -> ClientM_ BlockHeader -headerClient' v c = runIdentity $ do - (SomeSing (SChainwebVersion :: Sing v)) <- return $ toSing (_versionName v) +headerClient' :: HasVersion => ChainId -> BlockHash -> ClientM_ BlockHeader +headerClient' c = runIdentity $ do + (SomeSing (SChainwebVersion :: Sing v)) <- return $ toSing (_versionName implicitVersion) (SomeSing (SChainId :: Sing c)) <- return $ toSing c return $ client_ @(HeaderApi v c) headersClient' - :: ChainwebVersion - -> ChainId + :: HasVersion + => ChainId -> Maybe Limit -> Maybe (NextItem BlockHash) -> Maybe MinRank -> Maybe MaxRank -> ClientM_ (Page (NextItem BlockHash) BlockHeader) -headersClient' v c = runIdentity $ do - (SomeSing (SChainwebVersion :: Sing v)) <- return $ toSing (_versionName v) +headersClient' c = runIdentity $ do + (SomeSing (SChainwebVersion :: Sing v)) <- return $ toSing (_versionName implicitVersion) (SomeSing (SChainId :: Sing c)) <- return $ toSing c return $ client_ @(HeadersApi v c) -blocksClient' - :: ChainwebVersion - -> ChainId - -> Maybe Limit - -> Maybe (NextItem BlockHash) - -> Maybe MinRank - -> Maybe MaxRank - -> ClientM_ BlockPage -blocksClient' v c = runIdentity $ do - (SomeSing (SChainwebVersion :: Sing v)) <- return $ toSing (_versionName v) - (SomeSing (SChainId :: Sing c)) <- return $ toSing c - return $ client_ @(BlocksApi v c) - branchHashesClient' - :: ChainwebVersion - -> ChainId + :: HasVersion + => ChainId -> Maybe Limit -> Maybe (NextItem BlockHash) -> Maybe MinRank -> Maybe MaxRank -> BranchBounds BlockHeaderDb -> ClientM_ (Page (NextItem BlockHash) BlockHash) -branchHashesClient' v c = runIdentity $ do - (SomeSing (SChainwebVersion :: Sing v)) <- return $ toSing (_versionName v) +branchHashesClient' c = runIdentity $ do + (SomeSing (SChainwebVersion :: Sing v)) <- return $ toSing (_versionName implicitVersion) (SomeSing (SChainId :: Sing c)) <- return $ toSing c return $ client_ @(BranchHashesApi v c) branchHeadersClient' - :: ChainwebVersion - -> ChainId + :: HasVersion + => ChainId -> Maybe Limit -> Maybe (NextItem BlockHash) -> Maybe MinRank -> Maybe MaxRank -> BranchBounds BlockHeaderDb -> ClientM_ (Page (NextItem BlockHash) BlockHeader) -branchHeadersClient' v c = runIdentity $ do - (SomeSing (SChainwebVersion :: Sing v)) <- return $ toSing (_versionName v) +branchHeadersClient' c = runIdentity $ do + (SomeSing (SChainwebVersion :: Sing v)) <- return $ toSing (_versionName implicitVersion) (SomeSing (SChainId :: Sing c)) <- return $ toSing c return $ client_ @(BranchHeadersApi v c) - -branchBlocksClient' - :: ChainwebVersion - -> ChainId - -> Maybe Limit - -> Maybe (NextItem BlockHash) - -> Maybe MinRank - -> Maybe MaxRank - -> BranchBounds BlockHeaderDb - -> ClientM_ (Page (NextItem BlockHash) Block) -branchBlocksClient' v c = runIdentity $ do - (SomeSing (SChainwebVersion :: Sing v)) <- return $ toSing (_versionName v) - (SomeSing (SChainId :: Sing c)) <- return $ toSing c - return $ client_ @(BranchBlocksApi v c) diff --git a/test/lib/Chainweb/Test/RestAPI/Utils.hs b/test/lib/Chainweb/Test/RestAPI/Utils.hs index 0134317906..cc7e0d6302 100644 --- a/test/lib/Chainweb/Test/RestAPI/Utils.hs +++ b/test/lib/Chainweb/Test/RestAPI/Utils.hs @@ -3,6 +3,7 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NumericUnderscores #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE BangPatterns #-} module Chainweb.Test.RestAPI.Utils -- * Debugging ( debug @@ -17,7 +18,6 @@ module Chainweb.Test.RestAPI.Utils , PactTestFailure(..) , PollingExpectation(..) , local -, localTestToRetry , spv , ethSpv , sending @@ -45,26 +45,23 @@ import Servant.Client import Chainweb.BlockHeight import Chainweb.ChainId -import Chainweb.Cut.CutHashes (_cutHashes, _bhwhHeight) +import Chainweb.Cut.CutHashes (_cutHashes) import Chainweb.CutDB.RestAPI.Client import Chainweb.Pact.RestAPI.Client import Chainweb.Pact.RestAPI.EthSpv import Chainweb.Pact.Types +import Chainweb.Ranked import Chainweb.Version import Chainweb.Test.Utils -- internal pact modules import qualified Pact.JSON.Encode as J -import Pact.Types.API -import Pact.Types.Command -import Pact.Types.Hash -import qualified Pact.Core.Command.Server as Pact5 -import qualified Pact.Core.Command.Types as Pact5 -import qualified Pact.Types.API as Pact4 -import qualified Data.Aeson as Aeson -import qualified Data.Text.Lazy.Encoding as TL -import qualified Data.Text.Lazy as TL +import qualified Pact.Core.Command.Server as Pact +import qualified Pact.Core.Command.Types as Pact +import qualified Pact.Core.Hash as Pact +import qualified Pact.Core.Command.Client as Pact +import qualified Pact.Core.Errors as Pact -- ------------------------------------------------------------------ -- -- Defaults @@ -101,65 +98,43 @@ repeatUntil test action = retrying testRetryPolicy -- | Calls to /local via the pact local api client with retry -- localWithQueryParams - :: ChainwebVersion - -> ChainId + :: HasVersion + => ChainId -> ClientEnv -> Maybe LocalPreflightSimulation -> Maybe LocalSignatureVerification -> Maybe RewindDepth - -> Command Text + -> Pact.Command Text -> IO LocalResult -localWithQueryParams v sid cenv pf sv rd cmd = - recovering testRetryPolicy [h] $ \s -> do - debug - $ "requesting local cmd for " <> take 19 (show cmd) - <> " [" <> show (view rsIterNumberL s) <> "]" - - -- send a single local request and return the result - -- - runClientM (pactLocalWithQueryApiClient v sid pf sv rd cmd) cenv >>= \case - Left e -> throwM $ LocalFailure (show e) - Right t -> return t - where - h _ = Handler $ \case - LocalFailure _ -> pure True - _ -> pure False +localWithQueryParams sid cenv pf sv rd cmd = + runClientM (pactLocalApiClient sid pf sv rd cmd) cenv >>= \case + Left e -> throwM $ LocalFailure (show e) + Right t -> return t -- | Calls /local via the pact local api client with preflight -- turned off. Retries. -- local - :: ChainwebVersion - -> ChainId + :: HasVersion + => ChainId -> ClientEnv - -> Command Text - -> IO (CommandResult Hash) -local v sid cenv cmd = do + -> Pact.Command Text + -- TODO: PP. This needs to become a full PactError eventually + -> IO (Pact.CommandResult Pact.Hash Pact.PactOnChainError) +local sid cenv cmd = do Just cr <- preview _LocalResultLegacy <$> - localWithQueryParams v sid cenv Nothing Nothing Nothing cmd - Just pact4Cr <- return $ - Aeson.decode (TL.encodeUtf8 $ TL.fromStrict $ J.getJsonText cr) - pure pact4Cr - -localTestToRetry - :: ChainwebVersion - -> ChainId - -> ClientEnv - -> Command Text - -> (CommandResult Hash -> Bool) - -> IO (CommandResult Hash) -localTestToRetry v sid cenv cmd test = - repeatUntil (return . test) (local v sid cenv cmd) + localWithQueryParams sid cenv Nothing Nothing Nothing cmd + return cr -- | Request an SPV proof using exponential retry logic -- spv - :: ChainwebVersion - -> ChainId + :: HasVersion + => ChainId -> ClientEnv -> SpvRequest -> IO TransactionOutputProofB64 -spv v sid cenv r = +spv sid cenv r = recovering testRetryPolicy [h] $ \s -> do debug $ "requesting spv proof for " <> show r @@ -167,7 +142,7 @@ spv v sid cenv r = -- send a single spv request and return the result -- - runClientM (pactSpvApiClient v sid r) cenv >>= \case + runClientM (pactSpvApiClient sid r) cenv >>= \case Left e -> throwM $ SpvFailure (show e) Right t -> return t where @@ -178,12 +153,12 @@ spv v sid cenv r = -- | Request an Eth SPV proof using exponential retry logic -- ethSpv - :: ChainwebVersion - -> ChainId + :: HasVersion + => ChainId -> ClientEnv -> EthSpvRequest -> IO EthSpvResponse -ethSpv v sid cenv r = +ethSpv sid cenv r = recovering testRetryPolicy [h] $ \s -> do debug $ "requesting eth-spv proof for " <> show (_ethSpvReqTransactionHash r) @@ -191,7 +166,7 @@ ethSpv v sid cenv r = -- send a single spv request and return the result -- - runClientM (ethSpvApiClient v sid r) cenv >>= \case + runClientM (ethSpvApiClient sid r) cenv >>= \case Left e -> throwM $ SpvFailure (show e) Right t -> return t where @@ -199,27 +174,27 @@ ethSpv v sid cenv r = SpvFailure _ -> return True _ -> return False --- | Send a batch with retry logic waiting for success. +-- | Send a batch. sending - :: ChainwebVersion - -> ChainId + :: HasVersion + => ChainId -> ClientEnv - -> SubmitBatch - -> IO RequestKeys -sending v sid cenv batch = + -> Pact.SubmitBatch + -> IO Pact.RequestKeys +sending sid cenv batch = recovering testRetryPolicy [h] $ \s -> do debug - $ "sending requestkeys " <> show (_cmdHash <$> toList ss) + $ "sending requestkeys " <> show (Pact._cmdHash <$> toList ss) <> " [" <> show (view rsIterNumberL s) <> "]" -- Send and return naively -- - runClientM (pactSendApiClient v sid batch) cenv >>= \case + runClientM (pactSendApiClient sid (Pact.SendRequest batch)) cenv >>= \case Left e -> throwM $ SendFailure (show e) - Right rs -> return rs + Right (Pact.SendResponse rs) -> return rs where - ss = _sbCmds batch + ss = Pact._sbCmds batch h _ = Handler $ \case SendFailure _ -> return True @@ -231,24 +206,24 @@ data PollingExpectation = ExpectPactError | ExpectPactResult deriving Eq polling - :: ChainwebVersion - -> ChainId + :: HasVersion + => ChainId -> ClientEnv - -> RequestKeys + -> Pact.RequestKeys -> PollingExpectation - -> IO Pact4.PollResponses -polling v sid cenv rks pollingExpectation = - pollingWithDepth v sid cenv rks Nothing pollingExpectation + -> IO Pact.PollResponse +polling sid cenv rks pollingExpectation = + pollingWithDepth sid cenv rks Nothing pollingExpectation pollingWithDepth - :: ChainwebVersion - -> ChainId + :: HasVersion + => ChainId -> ClientEnv - -> RequestKeys + -> Pact.RequestKeys -> Maybe ConfirmationDepth -> PollingExpectation - -> IO Pact4.PollResponses -pollingWithDepth v sid cenv rks confirmationDepth pollingExpectation = + -> IO Pact.PollResponse +pollingWithDepth sid cenv rks confirmationDepth pollingExpectation = recovering testRetryPolicy [h] $ \s -> do debug $ "polling for requestkeys " <> show (toList rs) @@ -258,34 +233,32 @@ pollingWithDepth v sid cenv rks confirmationDepth pollingExpectation = -- by making sure results are successful and request keys -- are sane - runClientM (pactPollWithQueryApiClient v sid confirmationDepth $ Pact5.PollRequest rs) cenv >>= \case + runClientM (pactPollApiClient sid confirmationDepth $ Pact.PollRequest rs) cenv >>= \case Left e -> throwM $ PollingFailure (show e) - Right r@(Pact5.PollResponse mp) -> + Right r@(Pact.PollResponse mp) -> if all (go mp) (toList rs) then do - let pact4Resps = HM.fromList $ - [ (toPact4RequestKey rk, toPact4CommandResult cr) | (rk, cr) <- HM.toList mp ] - return $ Pact4.PollResponses pact4Resps + return $ Pact.PollResponse mp else throwM $ PollingFailure $ T.unpack $ "polling check failed: " <> J.encodeText r where h _ = Handler $ \case PollingFailure _ -> return True _ -> return False - rs = toPact5RequestKey <$> _rkRequestKeys rks + rs = Pact._rkRequestKeys rks - validate Pact5.PactResultOk{} = pollingExpectation == ExpectPactResult - validate Pact5.PactResultErr{} = pollingExpectation == ExpectPactError + validate Pact.PactResultOk{} = pollingExpectation == ExpectPactResult + validate Pact.PactResultErr{} = pollingExpectation == ExpectPactError go m rk = case m ^. at rk of - Just cr -> Pact5._crReqKey cr == rk && validate (Pact5._crResult cr) + Just cr -> Pact._crReqKey cr == rk && validate (Pact._crResult cr) Nothing -> False -getCurrentBlockHeight :: ChainwebVersion -> ClientEnv -> ChainId -> IO BlockHeight -getCurrentBlockHeight сv cenv cid = - runClientM (cutGetClient сv) cenv >>= \case +getCurrentBlockHeight :: HasVersion => ClientEnv -> ChainId -> IO BlockHeight +getCurrentBlockHeight cenv cid = + runClientM cutGetClient cenv >>= \case Left e -> throwM $ GetBlockHeightFailure $ "Failed to get cuts: " ++ show e - Right cuts -> return $ fromJust $ _bhwhHeight <$> HM.lookup cid (_cutHashes cuts) + Right cuts -> return $ fromJust $ _rankedHeight <$> HM.lookup cid (_cutHashes cuts) clientErrorStatusCode :: ClientError -> Maybe Int clientErrorStatusCode = \case diff --git a/test/lib/Chainweb/Test/TestVersions.hs b/test/lib/Chainweb/Test/TestVersions.hs index 2d702e062d..11384fcf92 100644 --- a/test/lib/Chainweb/Test/TestVersions.hs +++ b/test/lib/Chainweb/Test/TestVersions.hs @@ -6,42 +6,36 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} +{-# LANGUAGE RankNTypes #-} +{-# OPTIONS_GHC -Wno-missing-fields #-} module Chainweb.Test.TestVersions ( barebonesTestVersion - , fastForkingCpmTestVersion - , noBridgeCpmTestVersion - , slowForkingCpmTestVersion + -- , fastForkingCpmTestVersion + -- , noBridgeCpmTestVersion + -- , slowForkingCpmTestVersion , quirkedGasInstantCpmTestVersion - , quirkedGasPact5InstantCpmTestVersion , timedConsensusVersion , instantCpmTestVersion - , pact5InstantCpmTestVersion - , pact5InstantCpmTestVersionExpiryDisabled - , pact5CheckpointerTestVersion - , pact5SlowCpmTestVersion - , instantCpmTransitionTestVersion + -- , pact5InstantCpmTestVersion + -- , pact5SlowCpmTestVersion + -- , instantCpmTransitionTestVersion , pact53TransitionCpmTestVersion + , checkpointerTestVersion ) where import Control.Lens hiding (elements) -import Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as HM import qualified Data.HashSet as HS -import qualified Data.List as List import qualified Data.Set as Set -import qualified Chainweb.BlockHeader.Genesis.FastTimedCPM0Payload as TN0 -import qualified Chainweb.BlockHeader.Genesis.FastTimedCPM1to9Payload as TNN import qualified Chainweb.BlockHeader.Genesis.InstantTimedCPM0Payload as IN0 import qualified Chainweb.BlockHeader.Genesis.InstantTimedCPM1to9Payload as INN -import qualified Chainweb.BlockHeader.Genesis.Pact5InstantTimedCPM0Payload as PIN0 -import qualified Chainweb.BlockHeader.Genesis.Pact5InstantTimedCPM1to9Payload as PINN import qualified Chainweb.BlockHeader.Genesis.Pact53TransitionTimedCPM0Payload as PIT0 import qualified Chainweb.BlockHeader.Genesis.Pact53TransitionTimedCPM1to9Payload as PITN -import qualified Chainweb.BlockHeader.Genesis.QuirkedGasPact5InstantTimedCPM0Payload as QPIN0 -import qualified Chainweb.BlockHeader.Genesis.QuirkedGasPact5InstantTimedCPM1to9Payload as QPINN - -import System.IO.Unsafe +-- import qualified Chainweb.BlockHeader.Genesis.QuirkedGasPact5InstantTimedCPM0Payload as QPIN0 +-- import qualified Chainweb.BlockHeader.Genesis.QuirkedGasPact5InstantTimedCPM1to9Payload as QPINN +-- import qualified Chainweb.BlockHeader.Genesis.QuirkedGasPact5InstantTimedCPM0Payload as QPIN0 +-- import qualified Chainweb.BlockHeader.Genesis.QuirkedGasPact5InstantTimedCPM1to9Payload as QPINN -- internal modules @@ -51,24 +45,24 @@ import Chainweb.Difficulty import Chainweb.ForkState import Chainweb.Graph import Chainweb.HostAddress -import Chainweb.Pact5.InitialGasModel +import Chainweb.Pact.InitialGasModel import Chainweb.Pact.Utils import Chainweb.Time import Chainweb.Utils import Chainweb.Utils.Rule import Chainweb.Version -import Chainweb.Version.Registry import P2P.Peer -import qualified Pact.Types.Gas as P -import Chainweb.Test.Pact5.Utils (pactTxFrom4To5) - -import Pact.Types.Verifier - +import Chainweb.Pact.Payload(PayloadWithOutputs_(_payloadWithOutputsPayloadHash)) +import qualified Pact.Core.Names as Pact +import qualified Pact.Core.Gas as Pact +import qualified Data.List as L import qualified Chainweb.Pact.Transactions.CoinV3Transactions as CoinV3 import qualified Chainweb.Pact.Transactions.CoinV4Transactions as CoinV4 import qualified Chainweb.Pact.Transactions.CoinV5Transactions as CoinV5 import qualified Chainweb.Pact.Transactions.CoinV6Transactions as CoinV6 +import qualified Chainweb.BlockHeader.Genesis.FastTimedCPM0Payload as TN0 +import qualified Chainweb.BlockHeader.Genesis.FastTimedCPM1to9Payload as TNN import qualified Chainweb.Pact.Transactions.MainnetKADTransactions as MNKAD import qualified Chainweb.Pact.Transactions.OtherTransactions as Other @@ -92,95 +86,30 @@ testBootstrapPeerInfos = } } -type VersionBuilder = ChainwebVersion -> ChainwebVersion - --- | Executes a `VersionBuilder` to build a `ChainwebVersion`, by taking its --- fixed point. Additionally registers it in the global version registry. -buildTestVersion :: VersionBuilder -> ChainwebVersion -buildTestVersion f = - unsafePerformIO (v <$ registerVersion v) & versionName .~ v ^. versionName - where - v = f v -{-# noinline buildTestVersion #-} - --- | All testing `ChainwebVersion`s *must* have unique names and *must* be --- included in this list to be assigned a version code, and also registered via --- `buildTestVersion` into the global version registry. Failure to do so will --- result in runtime errors from `Chainweb.Version.Registry`. -testVersions :: [ChainwebVersionName] -testVersions = _versionName <$> concat - [ [ fastForkingCpmTestVersion (knownChainGraph g) - | g :: KnownGraph <- [minBound..maxBound] - ] - , [ slowForkingCpmTestVersion (knownChainGraph g) - | g :: KnownGraph <- [minBound..maxBound] - ] - , [ barebonesTestVersion (knownChainGraph g) - | g :: KnownGraph <- [minBound..maxBound] - ] - , [ noBridgeCpmTestVersion (knownChainGraph g) - | g :: KnownGraph <- [minBound..maxBound] - ] - , [ timedConsensusVersion forkNum (knownChainGraph g1) (knownChainGraph g2) - | g1 :: KnownGraph <- [minBound..maxBound] - , g2 :: KnownGraph <- [minBound..maxBound] - , forkNum :: ForkNumber <- [0..2] - ] - , [ quirkedGasInstantCpmTestVersion (knownChainGraph g) - | g :: KnownGraph <- [minBound..maxBound] - ] - , [ quirkedGasPact5InstantCpmTestVersion (knownChainGraph g) - | g :: KnownGraph <- [minBound..maxBound] - ] - , [ instantCpmTestVersion (knownChainGraph g) - | g :: KnownGraph <- [minBound..maxBound] - ] - , [ pact5InstantCpmTestVersion migrate (knownChainGraph g) - | g :: KnownGraph <- [minBound..maxBound] - , migrate :: Bool <- [minBound..maxBound] - ] - , [ pact5InstantCpmTestVersionExpiryDisabled (knownChainGraph g) - | g :: KnownGraph <- [minBound..maxBound] - ] - , [ pact5CheckpointerTestVersion (knownChainGraph g) - | g :: KnownGraph <- [minBound..maxBound] - ] - , [ pact5SlowCpmTestVersion (knownChainGraph g) - | g :: KnownGraph <- [minBound..maxBound] - ] - , [ instantCpmTransitionTestVersion (knownChainGraph g) - | g :: KnownGraph <- [minBound..maxBound] - ] - , [ pact53TransitionCpmTestVersion (knownChainGraph g) - | g :: KnownGraph <- [minBound..maxBound] - ] - ] - -- | Details common to all test versions thus far. --- Using this, a `ChainwebVersion`'s `versionCode` is set to the version's --- index in `testVersions`, to ensure that all test versions have unique codes --- in the global version registry in `Chainweb.Version.Registry`. -testVersionTemplate :: VersionBuilder -testVersionTemplate v = v - & versionCode .~ ChainwebVersionCode (int (fromJuste $ List.elemIndex (_versionName v) testVersions) + 0x80000000) - & versionHeaderBaseSizeBytes .~ 318 - 110 - & versionWindow .~ WindowWidth 120 - & versionMaxBlockGasLimit .~ Bottom (minBound, Just 2_000_000) - & versionSpvProofRootValidWindow .~ Bottom (minBound, Just 20) - & versionInitialGasModel .~ AllChains (Bottom (minBound, pre31GasModel)) - & versionBootstraps .~ [testBootstrapPeerInfos] - & versionVerifierPluginNames .~ AllChains (Bottom (minBound, mempty)) - & versionForkNumber .~ 0 - & versionForkVoteCastingLength .~ 20 -- very short. fork epoch is 140 blocks +testVersionTemplate :: Rule BlockHeight ChainGraph -> ChainwebVersion +testVersionTemplate gs = ChainwebVersion + { _versionCode = ChainwebVersionCode 0x80000000 + , _versionGraphs = gs + , _versionHeaderBaseSizeBytes = 318 - 110 + , _versionWindow = WindowWidth 120 + , _versionMaxBlockGasLimit = Bottom (minBound, Just 2_000_000) + , _versionBootstraps = [testBootstrapPeerInfos] + , _versionVerifierPluginNames = Bottom (minBound, mempty) <$ cids + , _versionForkNumber = 0 + , _versionForkVoteCastingLength = 20 + , _versionSpvProofRootValidWindow = Bottom (minBound, Nothing) + , _versionInitialGasModel = Bottom (minBound, post32GasModel) <$ cids + } + where cids = ChainMap $ HS.toMap $ graphChainIds $ snd $ ruleHead gs -- | A test version without Pact or PoW, with only one chain graph. barebonesTestVersion :: ChainGraph -> ChainwebVersion -barebonesTestVersion g = buildTestVersion $ \v -> - testVersionTemplate v +barebonesTestVersion g = + testVersionTemplate gs & versionWindow .~ WindowWidth 120 & versionBlockDelay .~ BlockDelay 500_000 & versionName .~ ChainwebVersionName ("test-" <> toText g) - & versionGraphs .~ Bottom (minBound, g) & versionCheats .~ VersionCheats { _disablePow = True , _fakeFirstEpochStart = True @@ -191,82 +120,102 @@ barebonesTestVersion g = buildTestVersion $ \v -> , _disablePeerValidation = True } & versionGenesis .~ VersionGenesis - { _genesisBlockPayload = AllChains emptyPayload - , _genesisBlockTarget = AllChains maxTarget - , _genesisTime = AllChains $ BlockCreationTime epoch + { _genesisBlockPayload = _payloadWithOutputsPayloadHash emptyPayload <$ cids + , _genesisBlockTarget = maxTarget <$ cids + , _genesisTime = BlockCreationTime epoch <$ cids + } + & versionForks .~ HM.fromList [ (f, ForkAtGenesis <$ cids) | f <- [minBound..maxBound] ] + & versionQuirks .~ VersionQuirks + { _quirkGasFees = HM.empty <$ cids } - & versionForks .~ HM.fromList [ (f, AllChains ForkAtGenesis) | f <- [minBound..maxBound] ] - & versionQuirks .~ noQuirks - & versionUpgrades .~ AllChains HM.empty + & versionUpgrades .~ (HM.empty <$ cids) + & versionPayloadProviderTypes .~ (MinimalProvider <$ cids) + where + gs = Bottom (minBound, g) + cids = ChainMap $ HS.toMap $ graphChainIds $ snd $ ruleHead gs -- | A test version without Pact or PoW, with a chain graph upgrade at block height 8. timedConsensusVersion :: ForkNumber -> ChainGraph -> ChainGraph -> ChainwebVersion -timedConsensusVersion forkNum g1 g2 = buildTestVersion $ \v -> v - & testVersionTemplate - & versionName .~ ChainwebVersionName - ("timedConsensus-fork" <> sshow forkNum <> "-" <> toText g1 <> "-" <> toText g2) - & versionBlockDelay .~ BlockDelay 1_000_000 - & versionWindow .~ WindowWidth 120 - & versionForks .~ tabulateHashMap (\case - SkipTxTimingValidation -> AllChains $ ForkAtBlockHeight (BlockHeight 2) - -- pact is disabled, we don't care about pact forks - _ -> AllChains ForkAtGenesis - ) - & versionQuirks .~ noQuirks - & versionUpgrades .~ AllChains HM.empty - & versionGraphs .~ (BlockHeight 8, g2) `Above` Bottom (minBound, g1) - & versionCheats .~ VersionCheats - { _disablePow = True - , _fakeFirstEpochStart = True - , _disablePact = True - } - & versionDefaults .~ VersionDefaults - { _disableMempoolSync = True - , _disablePeerValidation = True - } - & versionGenesis .~ VersionGenesis - { _genesisBlockPayload = onChains $ - (unsafeChainId 0, TN0.payloadBlock) : - [(n, TNN.payloadBlock) | n <- HS.toList (unsafeChainId 0 `HS.delete` chainIds v)] - , _genesisBlockTarget = AllChains maxTarget - , _genesisTime = AllChains $ BlockCreationTime epoch - } - & versionForkNumber .~ forkNum +timedConsensusVersion forkNum g1 g2 = + testVersionTemplate gs + & versionName .~ ChainwebVersionName ("timedConsensus-fork" <> sshow forkNum <> "-" <> toText g1 <> "-" <> toText g2) + & versionForkNumber .~ forkNum + & versionBlockDelay .~ BlockDelay 1_000_000 + & versionWindow .~ WindowWidth 120 + & versionForks .~ tabulateHashMap (\case + SkipTxTimingValidation -> ForkAtBlockHeight (BlockHeight 2) <$ cids + -- pact is disabled, we don't care about pact forks + _ -> ForkAtGenesis <$ cids + ) + & versionQuirks .~ VersionQuirks + { _quirkGasFees = HM.empty <$ cids + } + & versionUpgrades .~ (HM.empty <$ cids) + & versionCheats .~ VersionCheats + { _disablePow = True + , _fakeFirstEpochStart = True + , _disablePact = True + } + & versionDefaults .~ VersionDefaults + { _disableMempoolSync = True + , _disablePeerValidation = True + } + & versionGenesis .~ VersionGenesis + { _genesisBlockPayload = onChains $ + (unsafeChainId 0, _payloadWithOutputsPayloadHash $ IN0.payloadBlock) : + [ (n, _payloadWithOutputsPayloadHash INN.payloadBlock) + | n <- unsafeChainId 0 `L.delete` fmap fst (itoList cids) + ] + , _genesisBlockTarget = maxTarget <$ cids + , _genesisTime = BlockCreationTime epoch <$ cids + } + & versionPayloadProviderTypes .~ (MinimalProvider <$ cids) + where + gs = (BlockHeight 8, g2) `Above` Bottom (minBound, g1) + cids = ChainMap $ HS.toMap $ graphChainIds $ snd $ ruleHead gs -- | A test version without Pact or PoW. -pact5CheckpointerTestVersion :: ChainGraph -> ChainwebVersion -pact5CheckpointerTestVersion g1 = buildTestVersion $ \v -> v - & testVersionTemplate - & versionName .~ ChainwebVersionName ("pact5-checkpointertest-" <> toText g1) - & versionBlockDelay .~ BlockDelay 1_000_000 - & versionWindow .~ WindowWidth 120 - & versionForks .~ tabulateHashMap (\case - SkipTxTimingValidation -> AllChains $ ForkAtBlockHeight (BlockHeight 2) - -- pact is disabled, we don't care about pact forks - _ -> AllChains ForkAtGenesis - ) - & versionQuirks .~ noQuirks - & versionUpgrades .~ AllChains HM.empty - & versionGraphs .~ Bottom (minBound, g1) - & versionCheats .~ VersionCheats - { _disablePow = True - , _fakeFirstEpochStart = True - , _disablePact = True - } - & versionDefaults .~ VersionDefaults - { _disableMempoolSync = True - , _disablePeerValidation = True - } - & versionGenesis .~ VersionGenesis - { _genesisBlockPayload = onChains [ (n, emptyPayload) | n <- HS.toList (chainIds v) ] - , _genesisBlockTarget = AllChains maxTarget - , _genesisTime = AllChains $ BlockCreationTime epoch - } +checkpointerTestVersion :: ChainGraph -> ChainwebVersion +checkpointerTestVersion g1 = + testVersionTemplate gs + & versionName .~ ChainwebVersionName ("pact5-checkpointertest-" <> toText g1) + & versionBlockDelay .~ BlockDelay 1_000_000 + & versionWindow .~ WindowWidth 120 + & versionForks .~ tabulateHashMap (\case + SkipTxTimingValidation -> ForkAtBlockHeight (BlockHeight 2) <$ cids + -- pact is disabled, we don't care about pact forks + _ -> ForkAtGenesis <$ cids + ) + & versionQuirks .~ VersionQuirks + { _quirkGasFees = HM.empty <$ cids + } + & versionUpgrades .~ (HM.empty <$ cids) + & versionCheats .~ VersionCheats + { _disablePow = True + , _fakeFirstEpochStart = True + , _disablePact = True + } + & versionDefaults .~ VersionDefaults + { _disableMempoolSync = True + , _disablePeerValidation = True + } + & versionGenesis .~ VersionGenesis + { _genesisBlockPayload = onChains + [ (n, _payloadWithOutputsPayloadHash emptyPayload) + | n <- fst <$> itoList cids + ] + , _genesisBlockTarget = maxTarget <$ cids + , _genesisTime = BlockCreationTime epoch <$ cids + } + & versionPayloadProviderTypes .~ (PactProvider <$ cids) + where + gs = Bottom (minBound, g1) + cids = ChainMap $ HS.toMap $ graphChainIds $ snd $ ruleHead gs -- | A family of versions each with Pact enabled and PoW disabled. -cpmTestVersion :: ChainGraph -> VersionBuilder -cpmTestVersion g v = v - & testVersionTemplate +cpmTestVersion :: ChainGraph -> ChainwebVersion +cpmTestVersion g = withVersion (cpmTestVersion g) $ + testVersionTemplate gs & versionWindow .~ WindowWidth 120 & versionBlockDelay .~ BlockDelay (Micros 100_000) & versionGraphs .~ Bottom (minBound, g) @@ -281,356 +230,111 @@ cpmTestVersion g v = v } & versionGenesis .~ VersionGenesis { _genesisBlockPayload = onChains $ - (unsafeChainId 0, TN0.payloadBlock) : - [(n, TNN.payloadBlock) | n <- HS.toList (unsafeChainId 0 `HS.delete` chainIds v)] - , _genesisBlockTarget = AllChains maxTarget - , _genesisTime = AllChains $ BlockCreationTime epoch + (unsafeChainId 0, _payloadWithOutputsPayloadHash TN0.payloadBlock) : + [(n, _payloadWithOutputsPayloadHash TNN.payloadBlock) | n <- HS.toList (unsafeChainId 0 `HS.delete` cids)] + , _genesisBlockTarget = onAllChains maxTarget + , _genesisTime = onAllChains $ BlockCreationTime epoch } & versionUpgrades .~ chainZip HM.union - (indexByForkHeights v - [ (CoinV2, AllChains (pact4Upgrade Other.transactions)) - , (Pact4Coin3, AllChains (Pact4Upgrade CoinV3.transactions True)) - , (Chainweb214Pact, AllChains (Pact4Upgrade CoinV4.transactions True)) - , (Chainweb215Pact, AllChains (Pact4Upgrade CoinV5.transactions True)) - , (Chainweb223Pact, AllChains (pact4Upgrade CoinV6.transactions)) + (indexByForkHeights + [ (CoinV2, onAllChains (pact4Upgrade Other.transactions)) + , (Pact4Coin3, onAllChains (Pact4Upgrade CoinV3.transactions True)) + , (Chainweb214Pact, onAllChains (Pact4Upgrade CoinV4.transactions True)) + , (Chainweb215Pact, onAllChains (Pact4Upgrade CoinV5.transactions True)) + , (Chainweb223Pact, onAllChains (pact4Upgrade CoinV6.transactions)) ]) (onChains [(unsafeChainId 3, HM.singleton (BlockHeight 2) (Pact4Upgrade MNKAD.transactions False))]) - -slowForks :: HashMap Fork (ChainMap ForkHeight) -slowForks = tabulateHashMap \case - SlowEpoch -> AllChains ForkAtGenesis - OldTargetGuard -> AllChains ForkAtGenesis - SkipFeatureFlagValidation -> AllChains ForkAtGenesis - OldDAGuard -> AllChains ForkAtGenesis - Vuln797Fix -> AllChains ForkAtGenesis - PactBackCompat_v16 -> AllChains ForkAtGenesis - SPVBridge -> AllChains ForkAtGenesis - Pact44NewTrans -> AllChains ForkAtGenesis - Chainweb32 -> AllChains ForkAtGenesis -- Being mainly a bugfix, it's safe to do at it at genesis - CoinV2 -> AllChains $ ForkAtBlockHeight (BlockHeight 1) - SkipTxTimingValidation -> AllChains $ ForkAtBlockHeight (BlockHeight 2) - ModuleNameFix -> AllChains $ ForkAtBlockHeight (BlockHeight 2) - ModuleNameFix2 -> AllChains $ ForkAtBlockHeight (BlockHeight 2) - Pact42 -> AllChains $ ForkAtBlockHeight (BlockHeight 5) - CheckTxHash -> AllChains $ ForkAtBlockHeight (BlockHeight 7) - EnforceKeysetFormats -> AllChains $ ForkAtBlockHeight (BlockHeight 10) - PactEvents -> AllChains $ ForkAtBlockHeight (BlockHeight 10) - Pact4Coin3 -> AllChains $ ForkAtBlockHeight (BlockHeight 20) - Chainweb213Pact -> AllChains $ ForkAtBlockHeight (BlockHeight 26) - Chainweb214Pact -> AllChains $ ForkAtBlockHeight (BlockHeight 30) - Chainweb215Pact -> AllChains $ ForkAtBlockHeight (BlockHeight 35) - Chainweb216Pact -> AllChains $ ForkAtBlockHeight (BlockHeight 53) - Chainweb217Pact -> AllChains $ ForkAtBlockHeight (BlockHeight 55) - Chainweb218Pact -> AllChains $ ForkAtBlockHeight (BlockHeight 60) - Chainweb219Pact -> AllChains $ ForkAtBlockHeight (BlockHeight 71) - Chainweb220Pact -> AllChains $ ForkAtBlockHeight (BlockHeight 85) - Chainweb221Pact -> AllChains $ ForkAtBlockHeight (BlockHeight 100) - Chainweb222Pact -> AllChains $ ForkAtBlockHeight (BlockHeight 115) - Chainweb223Pact -> AllChains $ ForkAtBlockHeight (BlockHeight 120) - Chainweb224Pact -> AllChains $ ForkAtBlockHeight (BlockHeight 125) - Chainweb225Pact -> AllChains $ ForkAtBlockHeight (BlockHeight 130) - Pact5Fork -> AllChains ForkNever - Chainweb228Pact -> AllChains $ ForkAtBlockHeight (BlockHeight 145) - Chainweb230Pact -> AllChains $ ForkAtBlockHeight (BlockHeight 155) - Chainweb231Pact -> AllChains $ ForkAtBlockHeight (BlockHeight 160) - MigratePlatformShare -> AllChains $ ForkAtBlockHeight (BlockHeight 165) - Chainweb31 -> AllChains $ ForkAtBlockHeight (BlockHeight 170) - - --- | A set of fork heights which are relatively fast, but not fast enough to break anything. -fastForks :: HashMap Fork (ChainMap ForkHeight) -fastForks = tabulateHashMap $ \case - SlowEpoch -> AllChains ForkAtGenesis - OldTargetGuard -> AllChains ForkAtGenesis - SkipFeatureFlagValidation -> AllChains ForkAtGenesis - OldDAGuard -> AllChains ForkAtGenesis - Vuln797Fix -> AllChains ForkAtGenesis - PactBackCompat_v16 -> AllChains ForkAtGenesis - SPVBridge -> AllChains ForkAtGenesis - EnforceKeysetFormats -> AllChains ForkAtGenesis - CheckTxHash -> AllChains ForkAtGenesis - Pact44NewTrans -> AllChains ForkAtGenesis - Chainweb213Pact -> AllChains ForkAtGenesis - PactEvents -> AllChains ForkAtGenesis - Chainweb32 -> AllChains ForkAtGenesis -- Being mainly a bugfix, it's safe to do at it at genesis - CoinV2 -> AllChains $ ForkAtBlockHeight $ BlockHeight 1 - Pact42 -> AllChains $ ForkAtBlockHeight $ BlockHeight 1 - SkipTxTimingValidation -> AllChains $ ForkAtBlockHeight $ BlockHeight 2 - ModuleNameFix -> AllChains $ ForkAtBlockHeight $ BlockHeight 2 - ModuleNameFix2 -> AllChains $ ForkAtBlockHeight $ BlockHeight 2 - Pact4Coin3 -> AllChains $ ForkAtBlockHeight $ BlockHeight 4 - Chainweb214Pact -> AllChains $ ForkAtBlockHeight $ BlockHeight 5 - Chainweb215Pact -> AllChains $ ForkAtBlockHeight $ BlockHeight 10 - Chainweb216Pact -> AllChains $ ForkAtBlockHeight $ BlockHeight 11 - Chainweb217Pact -> AllChains $ ForkAtBlockHeight $ BlockHeight 20 - Chainweb218Pact -> AllChains $ ForkAtBlockHeight $ BlockHeight 20 - Chainweb219Pact -> AllChains $ ForkAtBlockHeight $ BlockHeight 27 - Chainweb220Pact -> AllChains $ ForkAtBlockHeight $ BlockHeight 30 - Chainweb221Pact -> AllChains $ ForkAtBlockHeight $ BlockHeight 33 - Chainweb222Pact -> AllChains $ ForkAtBlockHeight $ BlockHeight 36 - Chainweb223Pact -> AllChains $ ForkAtBlockHeight $ BlockHeight 38 - Chainweb224Pact -> AllChains $ ForkAtBlockHeight $ BlockHeight 40 - Chainweb225Pact -> AllChains $ ForkAtBlockHeight $ BlockHeight 42 - Pact5Fork -> AllChains $ ForkAtBlockHeight $ BlockHeight 46 - Chainweb228Pact -> AllChains $ ForkAtBlockHeight $ BlockHeight 48 - Chainweb230Pact -> AllChains $ ForkAtBlockHeight $ BlockHeight 52 - Chainweb231Pact -> AllChains $ ForkAtBlockHeight $ BlockHeight 54 - Chainweb31 -> AllChains $ ForkAtBlockHeight $ BlockHeight 56 - MigratePlatformShare -> AllChains ForkNever - --- | CPM version (see `cpmTestVersion`) with forks and upgrades slowly enabled. -slowForkingCpmTestVersion :: ChainGraph -> ChainwebVersion -slowForkingCpmTestVersion g = buildTestVersion $ \v -> v - & cpmTestVersion g - & versionName .~ ChainwebVersionName ("slowfork-CPM-" <> toText g) - & versionForks .~ slowForks - & versionVerifierPluginNames .~ AllChains - (Bottom (minBound, Set.fromList $ map VerifierName ["allow", "hyperlane_v3_announcement", "hyperlane_v3_message"])) - & versionQuirks .~ noQuirks + & versionPayloadProviderTypes .~ (PactProvider <$ ChainMap (HS.toMap cids)) + where + gs = Bottom (minBound, g) + cids = graphChainIds $ snd $ ruleHead gs -- | CPM version (see `cpmTestVersion`) with forks and upgrades instantly enabled, -- and with a gas fee quirk. quirkedGasInstantCpmTestVersion :: ChainGraph -> ChainwebVersion -quirkedGasInstantCpmTestVersion g = buildTestVersion $ \v -> v - & cpmTestVersion g - & versionName .~ ChainwebVersionName ("quirked-instant-CPM-" <> toText g) - & versionForks .~ tabulateHashMap (\case - Pact5Fork -> AllChains ForkNever - _ -> AllChains ForkAtGenesis) - & versionQuirks .~ VersionQuirks - { _quirkGasFees = onChain (unsafeChainId 0) - $ HM.singleton (BlockHeight 2, TxBlockIdx 0) (P.Gas 1) - } - & versionGenesis .~ VersionGenesis - { _genesisBlockPayload = onChains $ - (unsafeChainId 0, IN0.payloadBlock) : - [(n, INN.payloadBlock) | n <- HS.toList (unsafeChainId 0 `HS.delete` graphChainIds g)] - , _genesisBlockTarget = AllChains maxTarget - , _genesisTime = AllChains $ BlockCreationTime epoch - } - & versionUpgrades .~ AllChains mempty - & versionVerifierPluginNames .~ AllChains (Bottom (minBound, mempty)) - --- | CPM version (see `cpmTestVersion`) with forks and upgrades instantly enabled, --- and with a gas fee quirk. -quirkedGasPact5InstantCpmTestVersion :: ChainGraph -> ChainwebVersion -quirkedGasPact5InstantCpmTestVersion g = buildTestVersion $ \v -> v - & cpmTestVersion g +quirkedGasInstantCpmTestVersion g = + cpmTestVersion g & versionName .~ ChainwebVersionName ("quirked-pact5-instant-CPM-" <> toText g) & versionForks .~ tabulateHashMap (\case - _ -> AllChains ForkAtGenesis) + MigratePlatformShare -> ForkNever <$ cids + _ -> ForkAtGenesis <$ cids + ) & versionQuirks .~ VersionQuirks { _quirkGasFees = onChain (unsafeChainId 0) - $ HM.singleton (BlockHeight 1, TxBlockIdx 0) (P.Gas 1) + $ HM.singleton (BlockHeight 1, TxBlockIdx 0) (Pact.Gas 1) } & versionGenesis .~ VersionGenesis { _genesisBlockPayload = onChains $ - (unsafeChainId 0, QPIN0.payloadBlock) : - [(n, QPINN.payloadBlock) | n <- HS.toList (unsafeChainId 0 `HS.delete` graphChainIds g)] - , _genesisBlockTarget = AllChains maxTarget - , _genesisTime = AllChains $ BlockCreationTime epoch + (unsafeChainId 0, _payloadWithOutputsPayloadHash IN0.payloadBlock) : + [(n, _payloadWithOutputsPayloadHash INN.payloadBlock) | n <- HS.toList (unsafeChainId 0 `HS.delete` graphChainIds g)] + , _genesisBlockTarget = maxTarget <$ cids + , _genesisTime = BlockCreationTime epoch <$ cids } - & versionUpgrades .~ AllChains mempty - & versionVerifierPluginNames .~ AllChains (Bottom (minBound, mempty)) - --- | CPM version (see `cpmTestVersion`) with forks and upgrades quickly enabled. -fastForkingCpmTestVersion :: ChainGraph -> ChainwebVersion -fastForkingCpmTestVersion g = buildTestVersion $ \v -> v - & cpmTestVersion g - & versionName .~ ChainwebVersionName ("fastfork-CPM-" <> toText g) - & versionForks .~ fastForks - & versionQuirks .~ noQuirks - --- | CPM version (see `cpmTestVersion`) with forks and upgrades quickly enabled --- but with no SPV bridge. -noBridgeCpmTestVersion :: ChainGraph -> ChainwebVersion -noBridgeCpmTestVersion g = buildTestVersion $ \v -> v - & cpmTestVersion g - & versionName .~ ChainwebVersionName ("nobridge-CPM-" <> toText g) - & versionForks .~ (fastForks & at SPVBridge ?~ AllChains ForkNever) - & versionQuirks .~ noQuirks + & versionUpgrades .~ (mempty <$ cids) + & versionVerifierPluginNames .~ (Bottom (minBound, mempty) <$ cids) + where + cids = ChainMap $ HS.toMap $ graphChainIds g -- | CPM version (see `cpmTestVersion`) with forks and upgrades instantly enabled --- at genesis EXCEPT Pact 5. -instantCpmTestVersion :: ChainGraph -> ChainwebVersion -instantCpmTestVersion g = buildTestVersion $ \v -> v - & cpmTestVersion g - & versionName .~ ChainwebVersionName ("instant-CPM-" <> toText g) +-- at genesis. +instantCpmTestVersion :: Bool -> ChainGraph -> ChainwebVersion +instantCpmTestVersion migrate g = withVersion (instantCpmTestVersion migrate g) $ + cpmTestVersion g + & versionName .~ ChainwebVersionName ("instant-CPM-" <> toText g <> if migrate then "-migrate" else "") & versionForks .~ tabulateHashMap (\case - -- pact 5 is off - Pact5Fork -> AllChains ForkNever - MigratePlatformShare -> AllChains ForkNever - _ -> AllChains ForkAtGenesis - ) - & versionQuirks .~ noQuirks - & versionGenesis .~ VersionGenesis - { _genesisBlockPayload = onChains $ - (unsafeChainId 0, IN0.payloadBlock) : - [(n, INN.payloadBlock) | n <- HS.toList (unsafeChainId 0 `HS.delete` graphChainIds g)] - , _genesisBlockTarget = AllChains maxTarget - , _genesisTime = AllChains $ BlockCreationTime epoch - } - & versionUpgrades .~ AllChains mempty - & versionVerifierPluginNames .~ AllChains - (Bottom - ( minBound - , Set.fromList $ map VerifierName ["allow", "hyperlane_v3_announcement", "hyperlane_v3_message"] - ) - ) - -pact5InstantCpmTestVersion :: Bool -> ChainGraph -> ChainwebVersion -pact5InstantCpmTestVersion migrate g = buildTestVersion $ \v -> v - & cpmTestVersion g - & versionName .~ ChainwebVersionName ("instant-pact5-CPM-" <> toText g <> if migrate then "-migrate" else "") - -- Used to check gas for xChain -- - & versionInitialGasModel .~ AllChains ( (ForkAtBlockHeight 5, post32GasModel) `Above` - (ForkAtBlockHeight 4, post31GasModel) `Above` - Bottom (minBound, pre31GasModel)) - & versionForks .~ tabulateHashMap (\case - -- SPV Bridge is not in effect for Pact 5 yet. - SPVBridge -> AllChains ForkNever - MigratePlatformShare -> AllChains $ + MigratePlatformShare -> onAllChains $ if migrate then ForkAtBlockHeight 1 else ForkNever - - _ -> AllChains ForkAtGenesis - ) - & versionQuirks .~ noQuirks - & versionGenesis .~ VersionGenesis - { _genesisBlockPayload = onChains $ - (unsafeChainId 0, PIN0.payloadBlock) : - [(n, PINN.payloadBlock) | n <- HS.toList (unsafeChainId 0 `HS.delete` graphChainIds g)] - , _genesisBlockTarget = AllChains maxTarget - , _genesisTime = AllChains $ BlockCreationTime epoch - } - & versionUpgrades .~ AllChains mempty - & versionVerifierPluginNames .~ AllChains - (Bottom - ( minBound - , Set.fromList $ map VerifierName ["allow", "hyperlane_v3_announcement", "hyperlane_v3_message","signed_list"] - ) - ) - -pact5InstantCpmTestVersionExpiryDisabled :: ChainGraph -> ChainwebVersion -pact5InstantCpmTestVersionExpiryDisabled g = buildTestVersion $ \v -> v - & cpmTestVersion g - & versionName .~ ChainwebVersionName ("instant-pact5-CPM-" <> toText g <> "-expiry-disabled") - & versionForks .~ tabulateHashMap (\case - -- SPV Bridge is not in effect for Pact 5 yet. - SPVBridge -> AllChains ForkNever - MigratePlatformShare -> AllChains ForkNever - _ -> AllChains ForkAtGenesis + _ -> onAllChains ForkAtGenesis ) & versionQuirks .~ noQuirks & versionGenesis .~ VersionGenesis { _genesisBlockPayload = onChains $ - (unsafeChainId 0, PIN0.payloadBlock) : - [(n, PINN.payloadBlock) | n <- HS.toList (unsafeChainId 0 `HS.delete` graphChainIds g)] - , _genesisBlockTarget = AllChains maxTarget - , _genesisTime = AllChains $ BlockCreationTime epoch + (unsafeChainId 0, _payloadWithOutputsPayloadHash IN0.payloadBlock) : + [(n, _payloadWithOutputsPayloadHash INN.payloadBlock) | n <- HS.toList (unsafeChainId 0 `HS.delete` graphChainIds g)] + , _genesisBlockTarget = onAllChains maxTarget + , _genesisTime = onAllChains $ BlockCreationTime epoch } - & versionUpgrades .~ AllChains mempty - & versionVerifierPluginNames .~ AllChains + & versionUpgrades .~ onAllChains mempty + & versionVerifierPluginNames .~ onAllChains (Bottom ( minBound - , Set.fromList $ map VerifierName ["allow", "hyperlane_v3_announcement", "hyperlane_v3_message","signed_list"] + , Set.fromList $ map Pact.VerifierName + ["allow", "hyperlane_v3_announcement", "hyperlane_v3_message","signed_list"] ) ) - & versionSpvProofRootValidWindow .~ - ( (ForkAtBlockHeight $ BlockHeight 5, Nothing) `Above` - Bottom (minBound, Just 20) - ) pact53TransitionCpmTestVersion :: ChainGraph -> ChainwebVersion -pact53TransitionCpmTestVersion g = buildTestVersion $ \v -> v - & cpmTestVersion g +pact53TransitionCpmTestVersion g = withVersion (pact53TransitionCpmTestVersion g) $ + cpmTestVersion g & versionName .~ ChainwebVersionName ("pact53-transition-CPM-" <> toText g) & versionForks .~ tabulateHashMap (\case -- SPV Bridge is not in effect for Pact 5 yet. - SPVBridge -> AllChains ForkNever - - Chainweb230Pact -> AllChains $ ForkAtBlockHeight (BlockHeight 5) - MigratePlatformShare -> AllChains ForkNever - - _ -> AllChains ForkAtGenesis - ) - & versionQuirks .~ noQuirks - & versionGenesis .~ VersionGenesis - { _genesisBlockPayload = onChains $ - (unsafeChainId 0, PIT0.payloadBlock) : - [(n, PITN.payloadBlock) | n <- HS.toList (unsafeChainId 0 `HS.delete` graphChainIds g)] - , _genesisBlockTarget = AllChains maxTarget - , _genesisTime = AllChains $ BlockCreationTime epoch - } - & versionUpgrades .~ AllChains mempty - & versionVerifierPluginNames .~ AllChains - (Bottom - ( minBound - , Set.fromList $ map VerifierName ["allow", "hyperlane_v3_announcement", "hyperlane_v3_message"] - ) - ) - --- | CPM version (see `cpmTestVersion`) with forks and upgrades instantly enabled --- at genesis. We also have an upgrade after genesis that redeploys Coin v5 as --- a Pact 5 module. -pact5SlowCpmTestVersion :: ChainGraph -> ChainwebVersion -pact5SlowCpmTestVersion g = buildTestVersion $ \v -> v - & cpmTestVersion g - & versionName .~ ChainwebVersionName ("pact5-slow-CPM-" <> toText g) - & versionForks .~ tabulateHashMap (\case - -- genesis blocks are not ever run with Pact 5 - Pact5Fork -> onChains [ (cid, ForkAtBlockHeight (succ $ genesisBlockHeight v cid)) | cid <- HS.toList $ graphChainIds g ] - -- SPV Bridge is not in effect for Pact 5 yet. - SPVBridge -> AllChains ForkNever - _ -> AllChains ForkAtGenesis - ) - & versionQuirks .~ noQuirks - & versionGenesis .~ VersionGenesis - { _genesisBlockPayload = onChains $ - (unsafeChainId 0, IN0.payloadBlock) : - [(n, INN.payloadBlock) | n <- HS.toList (unsafeChainId 0 `HS.delete` graphChainIds g)] - , _genesisBlockTarget = AllChains maxTarget - , _genesisTime = AllChains $ BlockCreationTime epoch - } - & versionUpgrades .~ indexByForkHeights v - [ (Pact5Fork, AllChains (Pact5Upgrade (List.map pactTxFrom4To5 CoinV6.transactions))) - ] - & versionVerifierPluginNames .~ AllChains - (Bottom - ( minBound - , Set.fromList $ map VerifierName ["allow", "hyperlane_v3_announcement", "hyperlane_v3_message"] - ) - ) - --- | ChainwebVersion that transitions between Pact4 and Pact5 at block height 20. -instantCpmTransitionTestVersion :: ChainGraph -> ChainwebVersion -instantCpmTransitionTestVersion g = buildTestVersion $ \v -> v - & cpmTestVersion g - & versionName .~ ChainwebVersionName ("instant-CPM-transition-" <> toText g) - & versionForks .~ tabulateHashMap (\case - -- pact 5 is off until here - Pact5Fork -> AllChains $ ForkAtBlockHeight $ BlockHeight 20 - - -- SPV Bridge is not in effect for Pact 5 yet. - SPVBridge -> AllChains ForkNever + SPVBridge -> onAllChains ForkNever - MigratePlatformShare -> AllChains ForkNever + Chainweb230Pact -> onAllChains $ ForkAtBlockHeight (BlockHeight 5) + HashedAdjacentRecord -> onAllChains ForkNever + Chainweb231Pact -> onAllChains ForkNever + MigratePlatformShare -> onAllChains ForkNever - _ -> AllChains ForkAtGenesis + _ -> onAllChains ForkAtGenesis ) & versionQuirks .~ noQuirks & versionGenesis .~ VersionGenesis { _genesisBlockPayload = onChains $ - (unsafeChainId 0, IN0.payloadBlock) : - [(n, INN.payloadBlock) | n <- HS.toList (unsafeChainId 0 `HS.delete` graphChainIds g)] - , _genesisBlockTarget = AllChains maxTarget - , _genesisTime = AllChains $ BlockCreationTime epoch + (unsafeChainId 0, _payloadWithOutputsPayloadHash PIT0.payloadBlock) : + [ (n, _payloadWithOutputsPayloadHash PITN.payloadBlock) + | n <- HS.toList (unsafeChainId 0 `HS.delete` graphChainIds g) + ] + , _genesisBlockTarget = onAllChains maxTarget + , _genesisTime = onAllChains $ BlockCreationTime epoch } - & versionUpgrades .~ AllChains mempty - & versionVerifierPluginNames .~ AllChains + & versionUpgrades .~ onAllChains mempty + & versionVerifierPluginNames .~ onAllChains (Bottom ( minBound - , Set.fromList $ map VerifierName ["allow", "hyperlane_v3_announcement", "hyperlane_v3_message"] + , Set.fromList $ map Pact.VerifierName + ["allow", "hyperlane_v3_announcement", "hyperlane_v3_message", "signed_list"] ) ) diff --git a/test/lib/Chainweb/Test/Utils.hs b/test/lib/Chainweb/Test/Utils.hs index 2f519dba7c..eda4b03009 100644 --- a/test/lib/Chainweb/Test/Utils.hs +++ b/test/lib/Chainweb/Test/Utils.hs @@ -29,14 +29,9 @@ module Chainweb.Test.Utils , withResourceT , independentSequentialTestGroup , unsafeHeadOf +, noopLogger , TestPact5CommandResult -, toPact4RequestKey -, toPact5RequestKey -, toPact4Command -, toPact4CommandResult -, toPact5CommandResult -, pact4Poll -- * Test RocksDb , testRocksDb @@ -47,13 +42,11 @@ module Chainweb.Test.Utils , withTestBlockHeaderDb -- * SQLite Database Test Resource -, withTempSQLiteResource -, withInMemSQLiteResource +, withTempChainSqlite -- * Data Generation , toyBlockHeaderDb , toyChainId -, toyGenesis , toyVersion , genesisBlockHeaderForChain , withToyDB @@ -135,69 +128,10 @@ module Chainweb.Test.Utils , withPactDir , NodeDbDirs(..) , withTempDir +, withTempFile ) where import Control.Concurrent -import Control.Concurrent.STM -import Control.Lens -import Control.Monad -import Control.Monad.Catch (finally, bracket) -import Control.Monad.IO.Class -import Control.Monad.Trans.Resource -import Control.Retry - -import Data.Aeson (FromJSON, ToJSON) -import Data.Bifunctor hiding (second) -import qualified Data.ByteString as B -import qualified Data.ByteString.Lazy as BL -import Data.Coerce (coerce) -import Data.Foldable -import qualified Data.HashMap.Strict as HashMap -import Data.IORef -import Data.List (sortOn, isInfixOf) -import qualified Data.Text as T -import qualified Data.Text.IO as T -import Data.Tree -import qualified Data.Tree.Lens as LT -import qualified Data.Vector as V -import Data.Word - -import qualified Network.Connection as HTTP -import qualified Network.HTTP.Client as HTTP -import qualified Network.HTTP.Client.TLS as HTTP -import qualified Network.HTTP.Types as HTTP -import Network.Socket (close) -import qualified Network.TLS as HTTP -import qualified Network.Wai as W -import qualified Network.Wai.Handler.Warp as W -import Network.Wai.Handler.WarpTLS as W (runTLSSocket) - -import Numeric.Natural - -import Servant.Client (BaseUrl(..), ClientEnv, Scheme(..), mkClientEnv, runClientM) - -import System.Directory (removeDirectoryRecursive) -import System.Environment (withArgs) -import System.IO -import System.IO.Temp -import System.LogLevel -import System.Random (randomIO) - -import Test.QuickCheck.Arbitrary -import Test.QuickCheck.Gen -import Test.QuickCheck.Property (Property, (===)) -import Test.QuickCheck.Random (mkQCGen) -import Test.Tasty -import Test.Tasty.Golden -import Test.Tasty.HUnit -import Test.Tasty.QuickCheck (property, discard, (.&&.)) - -import Text.Printf (printf) - -import UnliftIO.Async - --- internal modules - import Chainweb.BlockCreationTime import Chainweb.BlockHeader import Chainweb.BlockHeaderDB @@ -206,7 +140,6 @@ import Chainweb.BlockHeight import Chainweb.BlockWeight import Chainweb.ChainId import Chainweb.Chainweb -import Chainweb.Chainweb.ChainResources import Chainweb.Chainweb.Configuration import Chainweb.Chainweb.PeerResources import Chainweb.Crypto.MerkleLog hiding (header) @@ -217,56 +150,95 @@ import Chainweb.Difficulty (targetToDifficulty) import Chainweb.Graph import Chainweb.HostAddress import Chainweb.Logger -import Chainweb.Mempool.Mempool (MempoolBackend(..), TransactionHash(..), BlockFill(..), mockBlockGasLimit) import Chainweb.MerkleUniverse import Chainweb.Miner.Config -import Chainweb.Miner.Pact import Chainweb.Pact.Backend.Types(SQLiteEnv) -import Chainweb.Pact.Backend.Utils (openSQLiteConnection, closeSQLiteConnection, chainwebPragmas) -import Chainweb.Payload.PayloadStore +import Chainweb.Pact.Backend.Utils +import Chainweb.Pact.Mempool.Mempool (TransactionHash(..), BlockFill(..), mockBlockGasLimit) +import Chainweb.Parent +import Chainweb.PayloadProvider.Pact.Configuration +import Chainweb.Ranked (Ranked(_rankedHeight)) import Chainweb.RestAPI import Chainweb.RestAPI.NetworkID -import Chainweb.Test.Pact5.Utils (getTestLogLevel) -import Chainweb.Test.P2P.Peer.BootstrapConfig - (testBootstrapCertificate, testBootstrapKey, testBootstrapPeerConfig) +import Chainweb.Scheduler (withScheduler) +import Chainweb.Storage.Table +import Chainweb.Storage.Table.RocksDB +import Chainweb.Test.P2P.Peer.BootstrapConfig (testBootstrapCertificate, testBootstrapKey, testBootstrapPeerConfig) +import Chainweb.Test.Pact.Utils (getTestLogLevel, getTestLogger) +import Chainweb.Test.TestVersions +import Chainweb.Test.Utils.APIValidation import Chainweb.Test.Utils.BlockHeader import Chainweb.Time import Chainweb.TreeDB import Chainweb.Utils import Chainweb.Utils.Serialization -import Chainweb.Test.TestVersions import Chainweb.Version import Chainweb.Version.Utils - -import Chainweb.Storage.Table -import Chainweb.Storage.Table.RocksDB - -import qualified Database.RocksDB.Internal as R - +import Control.Concurrent.STM +import Control.Lens +import Control.Monad +import Control.Monad.Catch (finally) +import Control.Monad.IO.Class +import Control.Monad.Trans.Resource +import Control.Retry +import Data.Aeson (FromJSON, ToJSON) +import Data.Bifunctor hiding (second) +import Data.ByteString qualified as B +import Data.ByteString.Lazy qualified as BL +import Data.Coerce (coerce) +import Data.Foldable +import Data.IORef +import Data.List (sortOn, isInfixOf) +import Data.Pool (Pool) +import Data.Semigroup +import Data.Text qualified as T +import Data.Text.IO qualified as T +import Data.Tree +import Data.Tree.Lens qualified as LT +import Data.Word +import Database.RocksDB.Internal qualified as R +import Network.Connection qualified as HTTP +import Network.HTTP.Client qualified as HTTP +import Network.HTTP.Client.TLS qualified as HTTP +import Network.HTTP.Types qualified as HTTP +import Network.Socket (close) +import Network.TLS qualified as HTTP +import Network.Wai qualified as W +import Network.Wai.Handler.Warp qualified as W +import Network.Wai.Handler.WarpTLS as W (runTLSSocket) import Network.X509.SelfSigned - +import Numeric.Natural import P2P.Node.Configuration -import qualified P2P.Node.PeerDB as P2P +import P2P.Node.PeerDB qualified as P2P import P2P.Peer - -import Chainweb.Test.Utils.APIValidation -import Data.Semigroup -import qualified Pact.Core.Command.Types as Pact5 -import qualified Data.Aeson as Aeson -import qualified Pact.Core.Errors as Pact5 -import qualified Pact.Types.Command as Pact4 -import qualified Pact.Core.Hash as Pact5 -import qualified Pact.Types.Hash as Pact4 -import qualified Pact.JSON.Encode as J -import qualified Pact.Types.API as Pact4 -import qualified Pact.Core.Command.Server as Pact5 +import Pact.Core.Command.Types qualified as Pact5 +import Pact.Core.Errors qualified as Pact5 +import Pact.Core.Gas qualified as Pact +import Pact.Core.Hash qualified as Pact5 +import Servant.Client (BaseUrl(..), ClientEnv, Scheme(..), mkClientEnv, runClientM) +import System.Directory (removeDirectoryRecursive, removeFile) +import System.Environment (withArgs) +import System.IO +import System.IO.Temp qualified as Temp +import System.LogLevel +import System.Random (randomIO) +import Test.QuickCheck.Arbitrary +import Test.QuickCheck.Gen +import Test.QuickCheck.Property (Property, (===)) +import Test.QuickCheck.Random (mkQCGen) +import Test.Tasty +import Test.Tasty.Golden +import Test.Tasty.HUnit +import Test.Tasty.QuickCheck (property, discard, (.&&.)) +import Text.Printf (printf) +import UnliftIO.Async -- -------------------------------------------------------------------------- -- type Step = String -> IO () withResource' :: IO a -> (IO a -> TestTree) -> TestTree -withResource' create act = withResource create (\_ -> return ()) act +withResource' create = withResource create (\_ -> return ()) -- this makes ResourceT general enough to allocate resources both for test -- groups and within tests. @@ -293,7 +265,8 @@ withResourceT rt act = -- Initialize Test BlockHeader DB testBlockHeaderDb - :: RocksDb + :: HasVersion + => RocksDb -> BlockHeader -> IO BlockHeaderDb testBlockHeaderDb rdb h = do @@ -301,7 +274,8 @@ testBlockHeaderDb rdb h = do initBlockHeaderDb (Configuration h rdb') withTestBlockHeaderDb - :: RocksDb + :: HasVersion + => RocksDb -> BlockHeader -> ResourceT IO BlockHeaderDb withTestBlockHeaderDb rdb h = @@ -325,8 +299,8 @@ withRocksResource :: ResourceT IO RocksDb withRocksResource = view _2 . snd <$> allocate create destroy where create = do - sysdir <- getCanonicalTemporaryDirectory - dir <- createTempDirectory sysdir "chainweb-rocksdb-tmp" + sysdir <- Temp.getCanonicalTemporaryDirectory + dir <- Temp.createTempDirectory sysdir "chainweb-rocksdb-tmp" opts@(R.Options' opts_ptr _ _) <- R.mkOpts modernDefaultOptions rocks <- openRocksDb dir opts_ptr return (dir, rocks, opts) @@ -338,23 +312,13 @@ withRocksResource = view _2 . snd <$> allocate create destroy -- -------------------------------------------------------------------------- -- -- SQLite DB Test Resource --- | This function doesn't delete the database file after use. --- --- You should use 'withTempSQLiteResource' or 'withInMemSQLiteResource' instead. --- -withSQLiteResource - :: String - -> ResourceT IO SQLiteEnv -withSQLiteResource file = snd <$> allocate - (openSQLiteConnection file chainwebPragmas) - closeSQLiteConnection - --- | Open a temporary file-backed SQLite database. -withTempSQLiteResource :: ResourceT IO SQLiteEnv -withTempSQLiteResource = withSQLiteResource "" - -withInMemSQLiteResource :: ResourceT IO SQLiteEnv -withInMemSQLiteResource = withSQLiteResource ":memory:" +-- | Open a temporary file-backed SQLite database, and return a writable +-- connection and a read-only pool of connections. +withTempChainSqlite :: ChainId -> ResourceT IO (SQLiteEnv, Pool SQLiteEnv) +withTempChainSqlite cid = do + logger <- liftIO $ getTestLogger + fp <- withTempDir "sqlite-tmp" + (,) <$> withSqliteDb cid logger fp False <*> withReadSqlitePool cid fp -- -------------------------------------------------------------------------- -- -- Toy Values @@ -366,42 +330,41 @@ toyVersion :: ChainwebVersion toyVersion = barebonesTestVersion singletonChainGraph toyChainId :: ChainId -toyChainId = someChainId toyVersion - -toyGenesis :: ChainId -> BlockHeader -toyGenesis cid = genesisBlockHeader toyVersion cid +toyChainId = withVersion toyVersion someChainId -- | Initialize an length-1 `BlockHeaderDb` for testing purposes. -- -- Borrowed from TrivialSync.hs -- -toyBlockHeaderDb :: RocksDb -> ChainId -> IO (BlockHeader, BlockHeaderDb) +toyBlockHeaderDb :: HasVersion => RocksDb -> ChainId -> IO (BlockHeader, BlockHeaderDb) toyBlockHeaderDb db cid = (g,) <$> testBlockHeaderDb db g where - g = toyGenesis cid + g = genesisBlockHeader cid -- | Given a function that accepts a Genesis Block and -- an initialized `BlockHeaderDb`, perform some action -- and cleanly close the DB. -- -withToyDB :: RocksDb -> ChainId -> ResourceT IO (BlockHeader, BlockHeaderDb) +withToyDB :: HasVersion => RocksDb -> ChainId -> ResourceT IO (BlockHeader, BlockHeaderDb) withToyDB db cid = snd <$> allocate (toyBlockHeaderDb db cid) (closeBlockHeaderDb . snd) mockBlockFill :: BlockFill mockBlockFill = BlockFill mockBlockGasLimit mempty 0 +noopLogger :: GenericLogger +noopLogger = genericLogger Quiet (\_ -> return ()) + -- -------------------------------------------------------------------------- -- -- BlockHeaderDb Generation genesisBlockHeaderForChain :: MonadThrow m - => HasChainwebVersion v - => v - -> Word32 + => HasVersion + => Word32 -> m BlockHeader -genesisBlockHeaderForChain v i - = genesisBlockHeader (_chainwebVersion v) <$> mkChainId v maxBound i +genesisBlockHeaderForChain i + = genesisBlockHeader <$> mkChainId maxBound i -- | Populate a `TreeDb` with /n/ generated `BlockHeader`s. -- @@ -409,21 +372,21 @@ genesisBlockHeaderForChain v i -- includes the nonce. They payloads can be recovered using -- 'testBlockPayload_'. -- -insertN :: Int -> BlockHeader -> BlockHeaderDb -> IO () +insertN :: HasVersion => Int -> BlockHeader -> BlockHeaderDb -> IO () insertN n g db = traverse_ (unsafeInsertBlockHeaderDb db) bhs where - bhs = take n $ testBlockHeaders $ ParentHeader g + bhs = take n $ testBlockHeaders $ Parent g -- | Payload hashes are generated using 'testBlockPayloadFromParent_', which -- includes the nonce. They payloads can be recovered using -- 'testBlockPayload_'. -- -insertN_ :: Nonce -> Natural -> BlockHeader -> BlockHeaderDb -> IO [BlockHeader] +insertN_ :: HasVersion => Nonce -> Natural -> BlockHeader -> BlockHeaderDb -> IO [BlockHeader] insertN_ s n g db = do traverse_ (unsafeInsertBlockHeaderDb db) bhs return bhs where - bhs = take (int n) $ testBlockHeadersWithNonce s $ ParentHeader g + bhs = take (int n) $ testBlockHeadersWithNonce s $ Parent g -- | Useful for terminal-based debugging. A @Tree BlockHeader@ can be obtained -- from any `TreeDb` via `toTree`. @@ -454,7 +417,7 @@ treeLeaves = toListOf . deep $ filtered (null . subForest) . LT.root newtype SparseTree = SparseTree { _sparseTree :: Tree BlockHeader } deriving (Show) instance Arbitrary SparseTree where - arbitrary = SparseTree <$> tree toyVersion Randomly + arbitrary = SparseTree <$> withVersion toyVersion tree Randomly -- | A specification for how the trunk of the `SparseTree` should grow. -- @@ -464,67 +427,63 @@ data Growth = Randomly | AtMost BlockHeight deriving (Eq, Ord, Show) -- The values of the tree constitute a legal chain, i.e. block heights start -- from 0 and increment, parent hashes propagate properly, etc. -- -tree :: ChainwebVersion -> Growth -> Gen (Tree BlockHeader) -tree v g = do - h <- genesis v +tree :: HasVersion => Growth -> Gen (Tree BlockHeader) +tree g = do + h <- genesis Node h <$> forest g h -- | Generate a sane, legal genesis block for 'Test' chainweb instance -- -genesis :: ChainwebVersion -> Gen BlockHeader -genesis v = either (error . sshow) return $ genesisBlockHeaderForChain v 0 +genesis :: HasVersion => Gen BlockHeader +genesis = either (error . sshow) return $ genesisBlockHeaderForChain 0 -forest :: Growth -> BlockHeader -> Gen (Forest BlockHeader) +forest :: HasVersion => Growth -> BlockHeader -> Gen (Forest BlockHeader) forest Randomly h = randomTrunk h forest g@(AtMost n) h | n < view blockHeight h = pure [] | otherwise = fixedTrunk g h -fixedTrunk :: Growth -> BlockHeader -> Gen (Forest BlockHeader) +fixedTrunk :: HasVersion => Growth -> BlockHeader -> Gen (Forest BlockHeader) fixedTrunk g h = frequency [ (1, sequenceA [fork h, trunk g h]) , (5, sequenceA [trunk g h]) ] -randomTrunk :: BlockHeader -> Gen (Forest BlockHeader) +randomTrunk :: HasVersion => BlockHeader -> Gen (Forest BlockHeader) randomTrunk h = frequency [ (2, pure []) , (4, sequenceA [fork h, trunk Randomly h]) , (18, sequenceA [trunk Randomly h]) ] -fork :: BlockHeader -> Gen (Tree BlockHeader) +fork :: HasVersion => BlockHeader -> Gen (Tree BlockHeader) fork h = do next <- header h Node next <$> frequency [ (1, pure []), (1, sequenceA [fork next]) ] -trunk :: Growth -> BlockHeader -> Gen (Tree BlockHeader) +trunk :: HasVersion => Growth -> BlockHeader -> Gen (Tree BlockHeader) trunk g h = do next <- header h Node next <$> forest g next -- | Generate some new `BlockHeader` based on a parent. -- --- Adjacent headers are ignored, which means that the resultting header is --- valid only in a singleton Chainweb. --- -header :: BlockHeader -> Gen BlockHeader +header :: HasVersion => BlockHeader -> Gen BlockHeader header p = do nonce <- Nonce <$> chooseAny return . fromLog @ChainwebMerkleHashAlgorithm . newMerkleLog - $ newForkState mempty (ParentHeader p) (view blockForkNumber p) + $ newForkState mempty (Parent p) (view blockForkNumber p) :+: t' - :+: view blockHash p + :+: Parent (view blockHash p) :+: target - :+: casKey (testBlockPayloadFromParent (ParentHeader p)) + :+: casKey (testBlockPayloadFromParent (Parent p)) :+: _chainId p :+: BlockWeight (targetToDifficulty target) + view blockWeight p :+: succ (view blockHeight p) - :+: _versionCode v - :+: epochStart (ParentHeader p) mempty t' + :+: _versionCode implicitVersion + :+: epochStart (Parent p) mempty t' :+: nonce :+: MerkleLogBody mempty where BlockCreationTime t = view blockCreationTime p - target = powTarget (ParentHeader p) mempty t' - v = _chainwebVersion p + target = powTarget (Parent p) mempty t' t' = BlockCreationTime (scaleTimeSpan (10 :: Int) second `add` t) -- | get arbitrary value for seed. @@ -541,15 +500,15 @@ petersen = petersenChainGraph singleton :: ChainGraph singleton = singletonChainGraph -testBlockHeaderDbs :: RocksDb -> ChainwebVersion -> IO [(ChainId, BlockHeaderDb)] -testBlockHeaderDbs rdb v = mapM toEntry $ toList $ chainIds v +testBlockHeaderDbs :: HasVersion => RocksDb -> IO (ChainMap BlockHeaderDb) +testBlockHeaderDbs rdb = tabulateChainsM toEntry where toEntry c = do - d <- testBlockHeaderDb rdb (genesisBlockHeader v c) - return (c, d) + testBlockHeaderDb rdb (genesisBlockHeader c) linearBlockHeaderDbs - :: Natural + :: HasVersion + => Natural -> [(ChainId, BlockHeaderDb)] -> IO [(ChainId, BlockHeaderDb)] linearBlockHeaderDbs n dbs = do @@ -558,19 +517,20 @@ linearBlockHeaderDbs n dbs = do where populateDb (_, db) = do gbh0 <- root db - traverse_ (unsafeInsertBlockHeaderDb db) . take (int n) . testBlockHeaders $ ParentHeader gbh0 + traverse_ (unsafeInsertBlockHeaderDb db) . take (int n) . testBlockHeaders $ Parent gbh0 starBlockHeaderDbs - :: Natural - -> [(ChainId, BlockHeaderDb)] - -> IO [(ChainId, BlockHeaderDb)] + :: HasVersion + => Natural + -> ChainMap BlockHeaderDb + -> IO (ChainMap BlockHeaderDb) starBlockHeaderDbs n dbs = do mapM_ populateDb dbs return dbs where - populateDb (_, db) = do + populateDb db = do gbh0 <- root db - traverse_ (\i -> unsafeInsertBlockHeaderDb db . newEntry i $ ParentHeader gbh0) [0 .. (int n-1)] + traverse_ (\i -> unsafeInsertBlockHeaderDb db . newEntry i $ Parent gbh0) [0 .. (int n-1)] newEntry i h = head $ testBlockHeadersWithNonce (Nonce i) h @@ -580,74 +540,61 @@ starBlockHeaderDbs n dbs = do testHost :: String testHost = "localhost" -data TestClientEnv t tbl = TestClientEnv +data TestClientEnv l t = TestClientEnv { _envClientEnv :: !ClientEnv - , _envCutDb :: !(Maybe (CutDb tbl)) - , _envBlockHeaderDbs :: ![(ChainId, BlockHeaderDb)] - , _envMempools :: ![(ChainId, MempoolBackend t)] - , _envPayloadDbs :: ![(ChainId, PayloadDb tbl)] + , _envCutDb :: !(Maybe (CutDb l)) + , _envBlockHeaderDbs :: !(ChainMap BlockHeaderDb) , _envPeerDbs :: ![(NetworkId, P2P.PeerDb)] - , _envVersion :: !ChainwebVersion } pattern BlockHeaderDbsTestClientEnv - :: ClientEnv - -> [(ChainId, BlockHeaderDb)] - -> ChainwebVersion - -> TestClientEnv t tbl -pattern BlockHeaderDbsTestClientEnv { _cdbEnvClientEnv, _cdbEnvBlockHeaderDbs, _cdbEnvVersion } - = TestClientEnv _cdbEnvClientEnv Nothing _cdbEnvBlockHeaderDbs [] [] [] _cdbEnvVersion + :: HasVersion + => ClientEnv + -> ChainMap BlockHeaderDb + -> TestClientEnv l t +pattern BlockHeaderDbsTestClientEnv { _cdbEnvClientEnv, _cdbEnvBlockHeaderDbs } + <- TestClientEnv _cdbEnvClientEnv Nothing _cdbEnvBlockHeaderDbs [] pattern PeerDbsTestClientEnv :: ClientEnv -> [(NetworkId, P2P.PeerDb)] - -> ChainwebVersion - -> TestClientEnv t tbl -pattern PeerDbsTestClientEnv { _pdbEnvClientEnv, _pdbEnvPeerDbs, _pdbEnvVersion } - = TestClientEnv _pdbEnvClientEnv Nothing [] [] [] _pdbEnvPeerDbs _pdbEnvVersion + -> TestClientEnv l t +pattern PeerDbsTestClientEnv { _pdbEnvClientEnv, _pdbEnvPeerDbs } + <- TestClientEnv _pdbEnvClientEnv Nothing _ _pdbEnvPeerDbs pattern PayloadTestClientEnv :: ClientEnv - -> CutDb tbl - -> [(ChainId, PayloadDb tbl)] - -> ChainwebVersion - -> TestClientEnv t tbl -pattern PayloadTestClientEnv { _pEnvClientEnv, _pEnvCutDb, _pEnvPayloadDbs, _eEnvVersion } - = TestClientEnv _pEnvClientEnv (Just _pEnvCutDb) [] [] _pEnvPayloadDbs [] _eEnvVersion + -> CutDb l + -> TestClientEnv l t +pattern PayloadTestClientEnv { _pEnvClientEnv, _pEnvCutDb } + <- TestClientEnv _pEnvClientEnv (Just _pEnvCutDb) _ [] withTestAppServer :: Bool - -> IO W.Application - -> (Int -> IO a) - -> (a -> IO b) - -> IO b -withTestAppServer tls appIO envIO userFunc = bracket start stop go - where - warpOnException _ _ = return () - start = do - app <- appIO - (port, sock) <- W.openFreePort - readyVar <- newEmptyMVar - server <- async $ do - let settings = W.setOnException warpOnException $ - W.setBeforeMainLoop (putMVar readyVar ()) W.defaultSettings - if - | tls -> do - let certBytes = testBootstrapCertificate - let keyBytes = testBootstrapKey - let tlsSettings = tlsServerSettings certBytes keyBytes - W.runTLSSocket tlsSettings settings sock app - | otherwise -> - W.runSettingsSocket settings sock app + -> W.Application + -> ResourceT IO Int +withTestAppServer tls app = do + (port, sock) <- snd <$> allocate W.openFreePort (close . snd) + readyVar <- liftIO newEmptyMVar + server <- withAsyncR $ do + let settings = + W.setOnException warpOnException $ + W.setBeforeMainLoop (putMVar readyVar ()) W.defaultSettings + if + | tls -> do + let certBytes = testBootstrapCertificate + let keyBytes = testBootstrapKey + let tlsSettings = tlsServerSettings certBytes keyBytes + W.runTLSSocket tlsSettings settings sock app + | otherwise -> + W.runSettingsSocket settings sock app + + liftIO $ link server + _ <- liftIO $ takeMVar readyVar + return port - link server - _ <- takeMVar readyVar - env <- envIO port - return (server, sock, env) - stop (server, sock, _) = do - uninterruptibleCancel server - close sock - go (_, _, env) = userFunc env + where + warpOnException _ _ = return () withTestAppServerR :: Bool @@ -680,67 +627,56 @@ withTestAppServerR tls app = view _3 . snd <$> allocate start stop data ShouldValidateSpec = ValidateSpec | DoNotValidateSpec --- TODO: catch, wrap, and forward exceptions from chainwebApplication --- withChainwebTestServer - :: ShouldValidateSpec + :: HasVersion + => ShouldValidateSpec -> Bool - -> ChainwebVersion -> W.Application -> ResourceT IO Int -withChainwebTestServer shouldValidateSpec tls v app = - view _3 . snd <$> allocate start stop +withChainwebTestServer shouldValidateSpec tls app = do + mw <- liftIO $ case shouldValidateSpec of + ValidateSpec -> mkApiValidationMiddleware + DoNotValidateSpec -> return id + let app' = mw app + (_, (port, sock)) <- allocate W.openFreePort (close . snd) + readyVar <- liftIO newEmptyMVar + _ <- withAsyncR $ do + let + settings = + W.setBeforeMainLoop (putMVar readyVar ()) $ + W.setOnExceptionResponse verboseOnExceptionResponse + W.defaultSettings + if + | tls -> do + let certBytes = testBootstrapCertificate + let keyBytes = testBootstrapKey + let tlsSettings = tlsServerSettings certBytes keyBytes + W.runTLSSocket tlsSettings settings sock app' + | otherwise -> + W.runSettingsSocket settings sock app' + + _ <- liftIO $ takeMVar readyVar + return port where verboseOnExceptionResponse exn = W.responseLBS HTTP.internalServerError500 [] ("exception: " <> sshow exn) - start = do - mw <- case shouldValidateSpec of - ValidateSpec -> mkApiValidationMiddleware v - DoNotValidateSpec -> return id - let app' = mw app - (port, sock) <- W.openFreePort - readyVar <- newEmptyMVar - server <- async $ do - let - settings = - W.setBeforeMainLoop (putMVar readyVar ()) $ - W.setOnExceptionResponse verboseOnExceptionResponse - W.defaultSettings - if - | tls -> do - let certBytes = testBootstrapCertificate - let keyBytes = testBootstrapKey - let tlsSettings = tlsServerSettings certBytes keyBytes - W.runTLSSocket tlsSettings settings sock app' - | otherwise -> - W.runSettingsSocket settings sock app' - - link server - _ <- takeMVar readyVar - return (server, sock, port) - - stop (server, sock, _) = do - uninterruptibleCancel server - close sock clientEnvWithChainwebTestServer - :: forall t tbl - . Show t + :: Show t => ToJSON t => FromJSON t - => CanReadablePayloadCas tbl + => HasVersion => ShouldValidateSpec -> Bool - -> ChainwebVersion - -> ChainwebServerDbs t tbl - -> ResourceT IO (TestClientEnv t tbl) -clientEnvWithChainwebTestServer shouldValidateSpec tls v dbs = do + -> ChainwebServerDbs l t + -> ResourceT IO (TestClientEnv l t) +clientEnvWithChainwebTestServer shouldValidateSpec tls dbs = do -- FIXME: Hashes API got removed from the P2P API. We use an application that -- includes this API for testing. We should create comprehensive tests for the -- service API and move the tests over there. -- - let app = chainwebApplicationWithHashesAndSpvApi (defaultChainwebConfiguration v) dbs - port <- withChainwebTestServer shouldValidateSpec tls v app + let app = chainwebApplicationWithHashesAndSpvApi (defaultChainwebConfiguration implicitVersion) dbs + port <- withChainwebTestServer shouldValidateSpec tls app mgrSettings <- if | tls -> liftIO $ certificateCacheManagerSettings TlsInsecure | otherwise -> return HTTP.defaultManagerSettings @@ -749,61 +685,51 @@ clientEnvWithChainwebTestServer shouldValidateSpec tls v dbs = do (mkClientEnv mgr (BaseUrl (if tls then Https else Http) testHost port "")) (_chainwebServerCutDb dbs) (_chainwebServerBlockHeaderDbs dbs) - (_chainwebServerMempools dbs) - (_chainwebServerPayloadDbs dbs) (_chainwebServerPeerDbs dbs) - v withPeerDbsServer :: Show t - => CanReadablePayloadCas tbl => ToJSON t => FromJSON t + => HasVersion => ShouldValidateSpec -> Bool - -> ChainwebVersion -> [(NetworkId, P2P.PeerDb)] - -> ResourceT IO (TestClientEnv t tbl) -withPeerDbsServer shouldValidateSpec tls v peerDbs = - clientEnvWithChainwebTestServer shouldValidateSpec tls v + -> ResourceT IO (TestClientEnv l t) +withPeerDbsServer shouldValidateSpec tls peerDbs = + clientEnvWithChainwebTestServer shouldValidateSpec tls emptyChainwebServerDbs { _chainwebServerPeerDbs = peerDbs } withPayloadServer :: Show t - => CanReadablePayloadCas tbl => ToJSON t => FromJSON t + => HasVersion => ShouldValidateSpec -> Bool - -> ChainwebVersion - -> CutDb tbl - -> [(ChainId, PayloadDb tbl)] - -> ResourceT IO (TestClientEnv t tbl) -withPayloadServer shouldValidateSpec tls v cutDb payloadDbs = - clientEnvWithChainwebTestServer shouldValidateSpec tls v + -> CutDb l + -> ResourceT IO (TestClientEnv l t) +withPayloadServer shouldValidateSpec tls cutDb = + clientEnvWithChainwebTestServer shouldValidateSpec tls emptyChainwebServerDbs - { _chainwebServerPayloadDbs = payloadDbs - , _chainwebServerCutDb = Just cutDb + { _chainwebServerCutDb = Just cutDb } withBlockHeaderDbsServer :: Show t - => CanReadablePayloadCas tbl => ToJSON t => FromJSON t + => HasVersion => ShouldValidateSpec -> Bool - -> ChainwebVersion - -> [(ChainId, BlockHeaderDb)] - -> [(ChainId, MempoolBackend t)] - -> ResourceT IO (TestClientEnv t tbl) -withBlockHeaderDbsServer shouldValidateSpec tls v chainDbs mempools = - clientEnvWithChainwebTestServer shouldValidateSpec tls v + -> ChainMap BlockHeaderDb + -> ResourceT IO (TestClientEnv l t) +withBlockHeaderDbsServer shouldValidateSpec tls chainDbs = + clientEnvWithChainwebTestServer shouldValidateSpec tls emptyChainwebServerDbs { _chainwebServerBlockHeaderDbs = chainDbs - , _chainwebServerMempools = mempools } -- -------------------------------------------------------------------------- -- @@ -976,19 +902,19 @@ data ChainwebNetwork = ChainwebNetwork withNodes_ :: Logger logger + => HasVersion => logger - -> ChainwebVersion -> (ChainwebConfiguration -> ChainwebConfiguration) -> [NodeDbDirs] -> ResourceT IO ChainwebNetwork -withNodes_ logger v confChange nodeDbDirs = do +withNodes_ logger confChange nodeDbDirs = do (p2p, service) <- start pure (ChainwebNetwork p2p service nodeDbDirs) where start :: ResourceT IO (ClientEnv, ClientEnv) start = do peerInfoVar <- liftIO newEmptyMVar - runTestNodes logger v confChange peerInfoVar nodeDbDirs + runTestNodes logger confChange peerInfoVar nodeDbDirs (i, servicePort) <- liftIO $ readMVar peerInfoVar cwEnv <- liftIO $ getClientEnv $ getCwBaseUrl Https $ _hostAddressPort $ _peerAddr i cwServiceEnv <- liftIO $ getClientEnv $ getCwBaseUrl Http servicePort @@ -1003,22 +929,22 @@ withNodes_ logger v confChange nodeDbDirs = do } withNodes - :: ChainwebVersion - -> (ChainwebConfiguration -> ChainwebConfiguration) + :: HasVersion + => (ChainwebConfiguration -> ChainwebConfiguration) -> [NodeDbDirs] -> ResourceT IO ChainwebNetwork -withNodes v confF nodeDbDirs = do +withNodes confF nodeDbDirs = do logLevel <- liftIO getTestLogLevel - withNodes_ (genericLogger logLevel T.putStrLn) v confF nodeDbDirs + withNodes_ (genericLogger logLevel T.putStrLn) confF nodeDbDirs withNodesAtLatestBehavior - :: ChainwebVersion - -> (ChainwebConfiguration -> ChainwebConfiguration) + :: HasVersion + => (ChainwebConfiguration -> ChainwebConfiguration) -> [NodeDbDirs] -> ResourceT IO ChainwebNetwork -withNodesAtLatestBehavior v conf dbDirs = do - net <- withNodes v conf dbDirs - liftIO $ awaitBlockHeight v (_getServiceClientEnv net) (latestBehaviorAt v) +withNodesAtLatestBehavior conf dbDirs = do + net <- withNodes conf dbDirs + liftIO $ awaitBlockHeight (_getServiceClientEnv net) latestBehaviorAt return net -- | Network initialization takes some time. Within my ghci session it took @@ -1026,17 +952,17 @@ withNodesAtLatestBehavior v conf dbDirs = do -- blocks were mined almost instantaneously. -- awaitBlockHeight - :: ChainwebVersion - -> ClientEnv + :: HasVersion + => ClientEnv -> BlockHeight -> IO () -awaitBlockHeight v cenv i = do +awaitBlockHeight cenv i = do result <- retrying testRetryPolicy checkRetry - $ const $ runClientM (cutGetClient v) cenv + $ const $ runClientM cutGetClient cenv case result of Left e -> throwM e Right x - | all (\bh -> _bhwhHeight bh >= i) (_cutHashes x) -> return () + | all (\bh -> _rankedHeight bh >= i) (_cutHashes x) -> return () | otherwise -> error $ "retries exhausted: waiting for cut height " <> sshow i <> " but only got " <> sshow (_cutHashesHeight x) @@ -1044,23 +970,21 @@ awaitBlockHeight v cenv i = do checkRetry _ (Left _) = return True checkRetry _ (Right c) - = return $ any (\bh -> _bhwhHeight bh < i) (_cutHashes c) + = return $ any (\bh -> _rankedHeight bh < i) (_cutHashes c) -withAsyncR :: IO a -> ResourceT IO (Async a) -withAsyncR action = snd <$> allocate (async action) uninterruptibleCancel - -runTestNodes :: Logger logger +runTestNodes + :: Logger logger + => HasVersion => logger - -> ChainwebVersion -> (ChainwebConfiguration -> ChainwebConfiguration) -> MVar (PeerInfo, Port) -> [NodeDbDirs] -- ^ A Map from Node Id to (Pact DB Dir, Backups Dir). -- The index is just the position in the list. -> ResourceT IO () -runTestNodes logger ver confChange portMVar nodesDbDirs = do +runTestNodes logger confChange portMVar nodesDbDirs = do forConcurrently_ (zip [0 ..] nodesDbDirs) $ \(nid, NodeDbDirs {..}) -> do - let baseConf = confChange $ config ver (int (length nodesDbDirs)) + let baseConf = confChange $ config implicitVersion (int (length nodesDbDirs)) conf <- liftIO $ if nid == 0 then return $ bootstrapConfig baseConf else setBootstrapPeerInfo <$> (fst <$> readMVar portMVar) <*> pure baseConf @@ -1077,6 +1001,7 @@ runTestNodes logger ver confChange portMVar nodesDbDirs = do node :: Logger logger + => HasVersion => RocksDb -> logger -> TVar NowServing @@ -1090,27 +1015,32 @@ node -- ^ Unique Node Id. The node id 0 is used for the bootstrap node -> IO () node rdb rawLogger nowServingRef peerInfoVar conf pactDbDir backupDir nid = do - withChainweb conf logger rdb pactDbDir backupDir False $ \case - StartedChainweb cw -> do - -- If this is the bootstrap node we extract the port number and publish via an MVar. - when (nid == 0) $ do - let bootStrapInfo = view (chainwebPeer . peerResPeer . peerInfo) cw - bootStrapPort = view (chainwebServiceSocket . _1) cw - putMVar peerInfoVar (bootStrapInfo, bootStrapPort) - - poisonDeadBeef cw - runChainweb cw (atomically . modifyTVar' nowServingRef) `finally` do - logFunctionText logger Info "write sample data" - logFunctionText logger Info "shutdown node" - return () - Replayed _ _ -> error "node: should not be a replay" + runResourceT $ do + sched <- withScheduler (logFunctionText logger) 2 + liftIO $ withChainweb conf logger sched rdb pactDbDir backupDir $ \case + StartedChainweb cw -> do + -- If this is the bootstrap node we extract the port number and publish via an MVar. + when (nid == 0) $ do + let bootStrapInfo = view (chainwebPeer . peerResPeer . peerInfo) cw + bootStrapPort = view (chainwebServiceSocket . _1) cw + putMVar peerInfoVar (bootStrapInfo, bootStrapPort) + + -- poisonDeadBeef cw + runChainweb cw (atomically . modifyTVar' nowServingRef) `finally` do + logFunctionText logger Info "write sample data" + logFunctionText logger Info "shutdown node" + return () + RewoundToCut _ -> error "node: should not be a replay" where logger = addLabel ("node", sshow nid) rawLogger - poisonDeadBeef cw = mapM_ poison crs - where - crs = map snd $ HashMap.toList $ view chainwebChains cw - poison cr = mempoolAddToBadList (view chainResMempool cr) (V.singleton deadbeef) + -- poisonDeadBeef cw = mapM_ poison crs + -- where + -- crs :: [ChainResources logger] + -- crs = map snd $ HashMap.toList $ view chainwebChains cw + + -- poison :: ChainResources logger -> IO () + -- poison cr = mempoolAddToBadList (view chainResMempool cr) (V.singleton deadbeef) data NodeDbDirs = NodeDbDirs { nodePactDbDir :: FilePath @@ -1121,12 +1051,18 @@ data NodeDbDirs = NodeDbDirs withPactDir :: Word -> ResourceT IO FilePath withPactDir nid = withTempDir $ "pactdb-dir-" ++ show nid +withTempFile :: FilePath -> ResourceT IO FilePath +withTempFile template = snd <$> allocate create destroy + where + create = Temp.emptySystemTempFile template + destroy = removeFile + withTempDir :: FilePath -> ResourceT IO FilePath withTempDir template = snd <$> allocate create destroy where create = do - targetDir <- getCanonicalTemporaryDirectory - createTempDirectory targetDir template + targetDir <- Temp.getCanonicalTemporaryDirectory + Temp.createTempDirectory targetDir template destroy = removeDirectoryRecursive withNodeDbDirs :: RocksDb -> Word -> ResourceT IO [NodeDbDirs] @@ -1153,15 +1089,19 @@ config ver n = defaultChainwebConfiguration ver & set (configP2p . p2pConfigMaxSessionCount) 4 & set (configP2p . p2pConfigSessionTimeout) 60 & set (configMining . miningInNode) miner - & set configReintroTxs True - & set configBlockGasLimit 1_000_000 + & set + ( configPayloadProviders + . payloadProviderConfigPact + . traversed + . pactConfigBlockGasLimit + ) + (Pact.GasLimit $ Pact.Gas 1_000_000) & set (configMining . miningCoordination . coordinationEnabled) True & set (configServiceApi . serviceApiConfigPort) 0 & set (configServiceApi . serviceApiConfigInterface) interface where miner = NodeMiningConfig { _nodeMiningEnabled = True - , _nodeMiner = noMiner , _nodeTestMiners = MinerCount n } @@ -1180,7 +1120,7 @@ setBootstrapPeerInfo bootPeerInfo = host :: Hostname -- host = unsafeHostnameFromText "::1" -host = unsafeHostnameFromText "localhost" +host = unsafeHostnameFromText "127.0.0.1" interface :: W.HostPreference -- interface = "::1" @@ -1196,7 +1136,7 @@ getClientEnv url = flip mkClientEnv url <$> HTTP.newTlsManagerWith mgrSettings -- | Backoff up to a constant 250ms, limiting to ~40s -- (actually saw a test have to wait > 22s) testRetryPolicy :: RetryPolicy -testRetryPolicy = stepped <> limitRetries 150 +testRetryPolicy = stepped <> limitRetries 10 where stepped = retryPolicy $ \rs -> case rsIterNumber rs of 0 -> Just 20_000 @@ -1219,34 +1159,3 @@ unsafeHeadOf :: HasCallStack => Getting (Endo a) s a -> s -> a unsafeHeadOf l s = s ^?! l type TestPact5CommandResult = Pact5.CommandResult Pact5.Hash Pact5.PactOnChainError - -toPact4RequestKey :: Pact5.RequestKey -> Pact4.RequestKey -toPact4RequestKey = \case - Pact5.RequestKey (Pact5.Hash bytes) -> Pact4.RequestKey (Pact4.Hash bytes) - -toPact5RequestKey :: Pact4.RequestKey -> Pact5.RequestKey -toPact5RequestKey = \case - Pact4.RequestKey (Pact4.Hash bytes) -> Pact5.RequestKey (Pact5.Hash bytes) - -toPact4Command :: Pact5.Command T.Text -> Pact4.Command T.Text -toPact4Command cmd4 = case Aeson.eitherDecodeStrictText (J.encodeText cmd4) of - Left err -> error $ "toPact4Command: decode failed: " ++ err - Right cmd5 -> cmd5 - -toPact4CommandResult :: () - => TestPact5CommandResult - -> Pact4.CommandResult Pact4.Hash -toPact4CommandResult cr5 = - case Aeson.eitherDecodeStrictText (J.encodeText cr5) of - Left err -> error $ "toPact5CommandResult: decode failed: " ++ err - Right cr4 -> cr4 - -toPact5CommandResult :: () - => Pact4.CommandResult Pact4.Hash - -> TestPact5CommandResult -toPact5CommandResult cr4 = case Aeson.eitherDecodeStrictText (J.encodeText cr4) of - Left err -> error $ "toPact5CommandResult: decode failed: " ++ err - Right cr5 -> cr5 - -pact4Poll :: Pact4.Poll -> Pact5.PollRequest -pact4Poll (Pact4.Poll rks) = Pact5.PollRequest $ toPact5RequestKey <$> rks diff --git a/test/lib/Chainweb/Test/Utils/APIValidation.hs b/test/lib/Chainweb/Test/Utils/APIValidation.hs index 10e8d53c94..efb43d023a 100644 --- a/test/lib/Chainweb/Test/Utils/APIValidation.hs +++ b/test/lib/Chainweb/Test/Utils/APIValidation.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE ImportQualifiedPost #-} {-# LANGUAGE NumericUnderscores #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -15,36 +15,26 @@ module Chainweb.Test.Utils.APIValidation ) where import Control.Exception (Exception, evaluate) +import Chainweb.Utils +import Chainweb.Version import Control.Monad - -import qualified Data.ByteString.Char8 as B8 -import qualified Data.ByteString.Lazy as BL +import Data.ByteString.Char8 qualified as B8 +import Data.ByteString.Lazy qualified as BL import Data.Foldable -import qualified Data.HashSet as HashSet +import Data.HashSet qualified as HashSet import Data.IORef -import qualified Data.Map as Map -import qualified Data.Text.Encoding as T -import Data.Typeable -import qualified Data.Yaml as Yaml - +import Data.Map qualified as Map +import Data.Text.Encoding qualified as T +import Data.Yaml qualified as Yaml import GHC.Stack - -import qualified Network.HTTP.Client as HTTP +import Network.HTTP.Client qualified as HTTP import Network.HTTP.Types -import qualified Network.Wai as W +import Network.Wai qualified as W import Network.Wai.Middleware.OpenApi(OpenApi) -import qualified Network.Wai.Middleware.Validation as WV - +import Network.Wai.Middleware.Validation qualified as WV import System.IO.Unsafe(unsafePerformIO) - import Text.Show.Pretty --- internal modules - -import Chainweb.ChainId -import Chainweb.Utils -import Chainweb.Version - -- -------------------------------------------------------------------------- -- -- Validation Exception @@ -53,7 +43,7 @@ data ValidationException = ValidationException , vResp :: (ResponseHeaders, Status, BL.ByteString) , vErr :: WV.TopLevelError } - deriving (Show, Typeable) + deriving (Show) instance Exception ValidationException @@ -77,13 +67,13 @@ pactOpenApiSpec = unsafePerformIO $ do -- -------------------------------------------------------------------------- -- -- API Validation Middleware -mkApiValidationMiddleware :: HasCallStack => ChainwebVersion -> IO W.Middleware -mkApiValidationMiddleware v = do +mkApiValidationMiddleware :: (HasCallStack, HasVersion) => IO W.Middleware +mkApiValidationMiddleware = do coverageRef <- newIORef $ WV.CoverageMap Map.empty _ <- evaluate chainwebOpenApiSpec _ <- evaluate pactOpenApiSpec return $ WV.mkValidator coverageRef (WV.Log lg (const (return ()))) findPath - where + where lg (_, req) (respBody, resp) err = do let ex = ValidationException req (W.responseHeaders resp, W.responseStatus resp, respBody) err error $ "Chainweb.Test.Utils.APIValidation.mkApValidationMiddleware: validation error. " <> ppShow ex @@ -91,11 +81,14 @@ mkApiValidationMiddleware v = do [ case B8.split '/' path of ("" : "chainweb" : "0.0" : rawVersion : "chain" : rawChainId : "pact" : "api" : "v1" : rest) -> do let reqVersion = T.decodeUtf8 rawVersion - guard (reqVersion == getChainwebVersionName (_versionName v)) - reqChainId <- chainIdFromText (T.decodeUtf8 rawChainId) - guard (HashSet.member reqChainId (chainIds v)) + guard (reqVersion == getChainwebVersionName (_versionName implicitVersion)) + reqChainId <- fromTextM (T.decodeUtf8 rawChainId) + guard (HashSet.member reqChainId chainIds) return (B8.intercalate "/" ("":rest), pactOpenApiSpec) _ -> Nothing - , (,chainwebOpenApiSpec) <$> B8.stripPrefix (T.encodeUtf8 $ "/chainweb/0.0/" <> getChainwebVersionName (_versionName v)) path + , (,chainwebOpenApiSpec) <$> + B8.stripPrefix + (T.encodeUtf8 $ "/chainweb/0.0/" <> getChainwebVersionName (_versionName implicitVersion)) + path , Just (path,chainwebOpenApiSpec) ] diff --git a/test/lib/Chainweb/Test/Utils/BlockHeader.hs b/test/lib/Chainweb/Test/Utils/BlockHeader.hs index 575617d6b0..57b0519b61 100644 --- a/test/lib/Chainweb/Test/Utils/BlockHeader.hs +++ b/test/lib/Chainweb/Test/Utils/BlockHeader.hs @@ -40,7 +40,8 @@ import Chainweb.BlockCreationTime import Chainweb.BlockHash import Chainweb.BlockHeader import Chainweb.ChainValue -import Chainweb.Payload +import Chainweb.Parent +import Chainweb.Pact.Payload import Chainweb.Time import Chainweb.Utils import Chainweb.Version @@ -66,9 +67,9 @@ testPayload n = newPayloadWithOutputs -- Payloads that are created with this function match respective payloads -- that are created with 'testBlockPayload'. -- -testBlockPayloadFromParent :: ParentHeader -> PayloadWithOutputs -testBlockPayloadFromParent (ParentHeader b) = testPayload $ B8.intercalate "," - [ sshow (_chainwebVersion b) +testBlockPayloadFromParent :: HasVersion => Parent BlockHeader -> PayloadWithOutputs +testBlockPayloadFromParent (Parent b) = testPayload $ B8.intercalate "," + [ sshow implicitVersion , sshow (view blockHeight b + 1) ] @@ -78,9 +79,9 @@ testBlockPayloadFromParent (ParentHeader b) = testPayload $ B8.intercalate "," -- Payloads that are created with this function match respective payloads -- that are created with 'testBlockPayloadFromParent'. -- -testBlockPayload :: BlockHeader -> PayloadWithOutputs +testBlockPayload :: HasVersion => BlockHeader -> PayloadWithOutputs testBlockPayload b = testPayload $ B8.intercalate "," - [ sshow (_chainwebVersion b) + [ sshow implicitVersion , sshow (view blockHeight b) ] @@ -91,9 +92,9 @@ testBlockPayload b = testPayload $ B8.intercalate "," -- that are created with 'testBlockPayload_', assuming that the same nonce is -- used. -- -testBlockPayloadFromParent_ :: Nonce -> ParentHeader -> PayloadWithOutputs -testBlockPayloadFromParent_ n (ParentHeader b) = testPayload $ B8.intercalate "," - [ sshow (_chainwebVersion b) +testBlockPayloadFromParent_ :: HasVersion => Nonce -> Parent BlockHeader -> PayloadWithOutputs +testBlockPayloadFromParent_ n (Parent b) = testPayload $ B8.intercalate "," + [ sshow implicitVersion , sshow (view blockHeight b + 1) , sshow n ] @@ -104,9 +105,9 @@ testBlockPayloadFromParent_ n (ParentHeader b) = testPayload $ B8.intercalate ", -- that are created with 'testBlockPayloadFromParent_', assuming that the same -- nonce is used. -- -testBlockPayload_ :: BlockHeader -> PayloadWithOutputs +testBlockPayload_ :: HasVersion => BlockHeader -> PayloadWithOutputs testBlockPayload_ b = testPayload $ B8.intercalate "," - [ sshow (_chainwebVersion b) + [ sshow implicitVersion , sshow (view blockHeight b) , sshow (view blockNonce b) ] @@ -117,27 +118,28 @@ testBlockPayload_ b = testPayload $ B8.intercalate "," testGetNewAdjacentParentHeaders :: HasCallStack => Applicative m - => ChainwebVersion - -> (ChainValue BlockHash -> m BlockHeader) + => HasVersion + => (ChainValue BlockHash -> m BlockHeader) -> BlockHashRecord - -> m (HM.HashMap ChainId (Either BlockHash ParentHeader)) -testGetNewAdjacentParentHeaders v hdb = itraverse select . _getBlockHashRecord + -> m (HM.HashMap ChainId (Either (Parent BlockHash) (Parent BlockHeader))) +testGetNewAdjacentParentHeaders hdb = itraverse select . _getBlockHashRecord where select cid h - | h == genesisParentBlockHash v cid = pure $ Left h - | otherwise = Right . ParentHeader <$> hdb (ChainValue cid h) + | h == genesisParentBlockHash cid = pure $ Left $ h + | otherwise = Right . Parent <$> hdb (ChainValue cid (unwrapParent h)) testBlockHeader - :: HM.HashMap ChainId ParentHeader + :: HasVersion + => HM.HashMap ChainId (Parent BlockHeader) -- ^ Adjacent parent hashes -> Nonce -- ^ Randomness to affect the block hash. It is also included into -- the payload - -> ParentHeader + -> Parent BlockHeader -- ^ parent block header -> BlockHeader -testBlockHeader adj nonce p@(ParentHeader b) = - newBlockHeader (_versionForkNumber $ _chainwebVersion b) adj payload nonce (BlockCreationTime $ add second t) p +testBlockHeader adj nonce p@(Parent b) = + newBlockHeader (view blockForkNumber b) adj payload nonce (BlockCreationTime $ add second t) p where payload = _payloadWithOutputsPayloadHash $ testBlockPayloadFromParent_ nonce p BlockCreationTime t = view blockCreationTime b @@ -147,17 +149,17 @@ testBlockHeader adj nonce p@(ParentHeader b) = -- -- Should only be used for testing purposes. -- -testBlockHeaders :: ParentHeader -> [BlockHeader] -testBlockHeaders (ParentHeader p) = L.unfoldr (Just . (id &&& id) . f) p +testBlockHeaders :: HasVersion => Parent BlockHeader -> [BlockHeader] +testBlockHeaders (Parent p) = L.unfoldr (Just . (id &&& id) . f) p where - f b = testBlockHeader mempty (view blockNonce b) $ ParentHeader b + f b = testBlockHeader mempty (view blockNonce b) $ Parent b -- | Given a `BlockHeader` of some initial parent, generate an infinite stream -- of `BlockHeader`s which form a legal chain. -- -- Should only be used for testing purposes. -- -testBlockHeadersWithNonce :: Nonce -> ParentHeader -> [BlockHeader] -testBlockHeadersWithNonce n (ParentHeader p) = L.unfoldr (Just . (id &&& id) . f) p +testBlockHeadersWithNonce :: HasVersion => Nonce -> Parent BlockHeader -> [BlockHeader] +testBlockHeadersWithNonce n (Parent p) = L.unfoldr (Just . (id &&& id) . f) p where - f b = testBlockHeader mempty n $ ParentHeader b + f b = testBlockHeader mempty n $ Parent b diff --git a/test/lib/Chainweb/Test/Utils/TestHeader.hs b/test/lib/Chainweb/Test/Utils/TestHeader.hs index d1736512d2..2a8b474b5b 100644 --- a/test/lib/Chainweb/Test/Utils/TestHeader.hs +++ b/test/lib/Chainweb/Test/Utils/TestHeader.hs @@ -58,6 +58,7 @@ import Chainweb.BlockCreationTime import Chainweb.BlockHeader import Chainweb.BlockHeight import Chainweb.ChainValue +import Chainweb.Parent import Chainweb.Test.Orphans.Internal import Chainweb.Version import Chainweb.Utils @@ -69,27 +70,17 @@ import Chainweb.Storage.Table data TestHeader = TestHeader { _testHeaderHdr :: !BlockHeader - , _testHeaderParent :: !ParentHeader - , _testHeaderAdjs :: ![ParentHeader] + , _testHeaderParent :: !(Parent BlockHeader) + , _testHeaderAdjs :: ![Parent BlockHeader] } - deriving (Eq, Ord, Generic) - -instance Show TestHeader where - show (TestHeader h p a) = T.unpack $ encodeToText $ object [ - "header" .= ExtendedObjectEncoded h, - "parent" .= ExtendedObjectEncoded (_parentHeader p), - "adjacents" .= fmap (ExtendedObjectEncoded . _parentHeader) a - ] + deriving (Show, Eq, Ord, Generic) makeLenses ''TestHeader instance HasChainId TestHeader where _chainId = _chainId . _testHeaderHdr -instance HasChainwebVersion TestHeader where - _chainwebVersion = _chainwebVersion . _testHeaderHdr - -instance HasChainGraph TestHeader where +instance HasVersion => HasChainGraph TestHeader where _chainGraph = _chainGraph . _testHeaderHdr instance (k ~ CasKeyType BlockHeader) => ReadableTable TestHeader k BlockHeader where @@ -99,24 +90,24 @@ testHeaderLookup :: TestHeader -> BlockHash -> Maybe BlockHeader testHeaderLookup testHdr x = lookup x tbl where h = _testHeaderHdr testHdr - p = _parentHeader $ _testHeaderParent testHdr + p = unwrapParent $ _testHeaderParent testHdr a = _testHeaderAdjs testHdr tbl = (view blockHash h, h) : (view blockHash p, p) - : fmap (\(ParentHeader b) -> (view blockHash b, b)) a + : fmap (\(Parent b) -> (view blockHash b, b)) a instance FromJSON TestHeader where parseJSON = withObject "TestHeader" $ \o -> TestHeader <$> o .: "header" - <*> (ParentHeader <$> o .: "parent") - <*> (fmap ParentHeader <$> o .: "adjacents") + <*> (Parent <$> o .: "parent") + <*> (fmap Parent <$> o .: "adjacents") instance ToJSON TestHeader where toJSON o = object [ "header" .= _testHeaderHdr o - , "parent" .= _parentHeader (_testHeaderParent o) - , "adjacents" .= fmap _parentHeader (_testHeaderAdjs o) + , "parent" .= unwrapParent (_testHeaderParent o) + , "adjacents" .= fmap unwrapParent (_testHeaderAdjs o) ] -- | An unsafe convenience functions for hard coding test headers in the code @@ -137,34 +128,34 @@ testHeader v = case fromJSON (object v) of -- This construction will satisfy all block header valdiation properties except -- for POW. -- -arbitraryTestHeader :: ChainwebVersion -> ChainId -> Gen TestHeader -arbitraryTestHeader v cid = do - h <- chooseEnum (genesisHeight v cid, maxBound `div` 2) - arbitraryTestHeaderHeight v cid h +arbitraryTestHeader :: HasVersion => ChainId -> Gen TestHeader +arbitraryTestHeader cid = do + h <- chooseEnum (genesisHeight cid, maxBound `div` 2) + arbitraryTestHeaderHeight cid h arbitraryTestHeaderHeight - :: ChainwebVersion - -> ChainId + :: HasVersion + => ChainId -> BlockHeight -> Gen TestHeader -arbitraryTestHeaderHeight v cid h = do - parent <- ParentHeader <$> arbitraryBlockHeaderVersionHeightChain v h cid +arbitraryTestHeaderHeight cid h = do + parent <- Parent <$> arbitraryBlockHeaderVersionHeightChain h cid trace "a" $ return () -- TODO: support graph changes in arbitary? as <- fmap HM.fromList - $ traverse (\c -> (c,) <$> arbitraryBlockHeaderVersionHeightChain v h c) + $ traverse (\c -> (c,) <$> arbitraryBlockHeaderVersionHeightChain h c) $ toList - $ adjacentChainIds (chainGraphAt v h) cid + $ adjacentChainIds (chainGraphAt h) cid nonce <- arbitrary payloadHash <- arbitrary let pt = maximum $ _bct . view blockCreationTime - <$> HM.insert cid (_parentHeader parent) as + <$> HM.insert cid (unwrapParent parent) as t <- BlockCreationTime <$> chooseEnum (pt, maxBound) return $ TestHeader - { _testHeaderHdr = newBlockHeader (_versionForkNumber v) (ParentHeader <$> as) payloadHash nonce t parent + { _testHeaderHdr = newBlockHeader (view (_Parent . blockForkNumber) parent) (Parent <$> as) payloadHash nonce t parent , _testHeaderParent = parent - , _testHeaderAdjs = toList $ ParentHeader <$> as + , _testHeaderAdjs = toList $ Parent <$> as } -- -------------------------------------------------------------------------- -- @@ -183,21 +174,20 @@ testHeaderChainLookup h x = pure $! testHeaderLookup h $ _chainValueValue x -- Genesis Test Headers genesisTestHeaders - :: HasChainwebVersion v - => v -> [TestHeader] -genesisTestHeaders v = genesisTestHeader v <$> toList (chainIds v) + :: HasVersion + => [TestHeader] +genesisTestHeaders = genesisTestHeader <$> toList chainIds genesisTestHeader - :: HasChainwebVersion v + :: HasVersion => HasChainId c - => v - -> c + => c -> TestHeader -genesisTestHeader v cid = TestHeader +genesisTestHeader cid = TestHeader { _testHeaderHdr = gen - , _testHeaderParent = ParentHeader gen - , _testHeaderAdjs = ParentHeader . genesisBlockHeader (_chainwebVersion v) + , _testHeaderParent = Parent gen + , _testHeaderAdjs = Parent . genesisBlockHeader <$> toList (adjacentChainIds (_chainGraph gen) cid) } where - gen = genesisBlockHeader (_chainwebVersion v) (_chainId cid) + gen = genesisBlockHeader (_chainId cid) diff --git a/test/multinode/MultiNodeNetworkTests.hs b/test/multinode/MultiNodeNetworkTests.hs index 583aac0271..a041a93337 100644 --- a/test/multinode/MultiNodeNetworkTests.hs +++ b/test/multinode/MultiNodeNetworkTests.hs @@ -1,4 +1,5 @@ {-# LANGUAGE DataKinds #-} +{-# LANGUAGE NumericUnderscores #-} {-# LANGUAGE OverloadedStrings #-} -- | @@ -13,6 +14,7 @@ module Main ( main ) where import Chainweb.Graph +import Chainweb.Difficulty (BlockDelay(..)) import Chainweb.Storage.Table.RocksDB import Chainweb.Test.TestVersions import Chainweb.Test.Utils @@ -21,6 +23,7 @@ import System.LogLevel import Test.Tasty import Test.Tasty.HUnit import qualified Chainweb.Test.MultiNode +import Chainweb.Version (withVersion, _versionBlockDelay) main :: IO () main = defaultMain suite @@ -31,45 +34,26 @@ loglevel = Warn -- note that because these tests run in parallel they must all use distinct rocksdb and sqlite dirs. suite :: TestTree suite = independentSequentialTestGroup "MultiNodeNetworkTests" - [ testGroup "parallel fork voting tests" - -- use very few nodes, so we can have higher concurrency; which is good, because they're long - [ testCaseSteps "Fork Vote - Succeed Unanimous" $ \step -> - withTempRocksDb "fork-vote-succeed-unanimous-rocks" $ \rdb -> - withSystemTempDirectory "fork-vote-succeed-unanimous-pact" $ \pactDbDir -> - Chainweb.Test.MultiNode.forkVoteTestSucceedUnanimous loglevel rdb pactDbDir step - , testCaseSteps "Fork Vote - Fail Unanimous" $ \step -> - withTempRocksDb "fork-vote-fail-unanimous-rocks" $ \rdb -> - withSystemTempDirectory "fork-vote-fail-unanimous-pact" $ \pactDbDir -> - Chainweb.Test.MultiNode.forkVoteTestFailUnanimous loglevel rdb pactDbDir step - , testCaseSteps "Fork Vote - Succeed Twice Unanimous" $ \step -> - withTempRocksDb "fork-vote-succeed-twice-unanimous-rocks" $ \rdb -> - withSystemTempDirectory "fork-vote-succeed-twice-pact" $ \pactDbDir -> - Chainweb.Test.MultiNode.forkVoteTestSucceedTwiceUnanimous loglevel rdb pactDbDir step - , testCaseSteps "Fork Vote - Succeed 4/5ths Majority" $ \step -> - withTempRocksDb "fork-vote-succeed-four-fifths-majority-rocks" $ \rdb -> - withSystemTempDirectory "fork-vote-succeed-four-fifths-majority-pact" $ \pactDbDir -> - Chainweb.Test.MultiNode.forkVoteTestSucceedFourFifths loglevel rdb pactDbDir step - , testCaseSteps "Fork Vote - Fail 4/5ths Majority" $ \step -> - withTempRocksDb "fork-vote-fail-four-fifths-majority-rocks" $ \rdb -> - withSystemTempDirectory "fork-vote-fail-four-fifths-majority-pact" $ \pactDbDir -> - Chainweb.Test.MultiNode.forkVoteTestFailFourFifths loglevel rdb pactDbDir step - ] - , independentSequentialTestGroup "sequential tests" - [ testCaseSteps "ConsensusNetwork - TimedConsensus - 10 nodes - 30 seconds" $ \step -> - withTempRocksDb "multinode-tests-timedconsensus-petersen-twenty-rocks" $ \rdb -> - withSystemTempDirectory "multinode-tests-timedconsensus-petersen-twenty-pact" $ \pactDbDir -> - Chainweb.Test.MultiNode.efficiencyTest loglevel (timedConsensusVersion 0 petersenChainGraph twentyChainGraph) 10 30 rdb pactDbDir step - , testCaseSteps "ConsensusNetwork - FastTimedCPM singleChainGraph - 10 nodes - 30 seconds" $ \step -> - withTempRocksDb "multinode-tests-fasttimedcpm-single-rocks" $ \rdb -> - withSystemTempDirectory "multinode-tests-fasttimedcpm-single-pact" $ \pactDbDir -> - Chainweb.Test.MultiNode.efficiencyTest loglevel (fastForkingCpmTestVersion singletonChainGraph) 10 30 rdb pactDbDir step - , testCaseSteps "Replay - FastTimedCPM - 6 nodes" $ \step -> - withTempRocksDb "replay-test-fasttimedcpm-pair-rocks" $ \rdb -> - withSystemTempDirectory "replay-test-fasttimedcpm-pair-pact" $ \pactDbDir -> - Chainweb.Test.MultiNode.replayTest loglevel (fastForkingCpmTestVersion pairChainGraph) 6 rdb pactDbDir step - , testCaseSteps "Replay - TransitionTimedCPM - 6 nodes" $ \step -> - withTempRocksDb "replay-test-transitiontimedcpm-pair-rocks" $ \rdb -> - withSystemTempDirectory "replay-test-transitiontimedcpm-pair-pact" $ \pactDbDir -> - Chainweb.Test.MultiNode.replayTest loglevel (instantCpmTransitionTestVersion pairChainGraph) 1 rdb pactDbDir step - ] + [ testCaseSteps "ConsensusNetwork - TimedConsensus - 10 nodes - 30 seconds" $ \step -> + withTempRocksDb "multinode-tests-timedconsensus-petersen-twenty-rocks" $ \rdb -> + withSystemTempDirectory "multinode-tests-timedconsensus-petersen-twenty-pact" $ \pactDbDir -> + withVersion ((timedConsensusVersion 0 petersenChainGraph twentyChainGraph) + { _versionBlockDelay = BlockDelay 5_000_000 }) $ + Chainweb.Test.MultiNode.test loglevel 10 30 rdb pactDbDir step + , testCaseSteps "ConsensusNetwork - TimedConsensus - 10 nodes - 30 seconds - d4k4 upgrade" $ \step -> + withTempRocksDb "multinode-tests-timedconsensus-twenty-d4k4-rocks" $ \rdb -> + withSystemTempDirectory "multinode-tests-timedconsensus-twenty-d4k4-pact" $ \pactDbDir -> + withVersion ((timedConsensusVersion 0 twentyChainGraph d4k4ChainGraph) + { _versionBlockDelay = BlockDelay 5_000_000 }) $ + Chainweb.Test.MultiNode.test loglevel 4 100 rdb pactDbDir step + , testCaseSteps "ConsensusNetwork - InstantTimedCPM singleChainGraph - 10 nodes - 30 seconds" $ \step -> + withTempRocksDb "multinode-tests-instantcpm-single-rocks" $ \rdb -> + withSystemTempDirectory "multinode-tests-instantcpm-single-pact" $ \pactDbDir -> + withVersion (instantCpmTestVersion False singletonChainGraph) $ + Chainweb.Test.MultiNode.test loglevel 10 30 rdb pactDbDir step + , testCaseSteps "Replay - InstantTimedCPM - 6 nodes" $ \step -> + withTempRocksDb "replay-test-instantcpm-pair-rocks" $ \rdb -> + withSystemTempDirectory "replay-test-instantcpm-pair-pact" $ \pactDbDir -> + withVersion (instantCpmTestVersion False pairChainGraph) $ + Chainweb.Test.MultiNode.replayTest loglevel 6 rdb pactDbDir step ] diff --git a/test/unit/Chainweb/Test/BlockHeader/Validation.hs b/test/unit/Chainweb/Test/BlockHeader/Validation.hs index 2ac3beb67e..2786f2e7e5 100644 --- a/test/unit/Chainweb/Test/BlockHeader/Validation.hs +++ b/test/unit/Chainweb/Test/BlockHeader/Validation.hs @@ -28,6 +28,7 @@ import Chainweb.BlockHeight import Chainweb.Difficulty import Chainweb.ForkState import Chainweb.Graph hiding (AdjacentChainMismatch) +import Chainweb.Parent import Chainweb.Test.Orphans.Internal () import Chainweb.Test.TestVersions import Chainweb.Test.Utils.TestHeader @@ -62,35 +63,15 @@ tests :: TestTree tests = testGroup "Chainweb.Test.Blockheader.Validation" [ prop_validateMainnet , prop_validateTestnet04 - , prop_fail_validate - , prop_forkstate_validate + , withVersion mainnet prop_fail_validate , prop_da_validate - , prop_legacy_da_validate - , prop_forkVotesReset (barebonesTestVersion petersenChainGraph) 0 - , prop_forkVotesReset (barebonesTestVersion petersenChainGraph) (int (forkEpochLength (barebonesTestVersion petersenChainGraph))) - , testProperty "validate arbitrary test header" prop_validateArbitrary - , testProperty "validate arbitrary test header for mainnet" $ prop_validateArbitrary Mainnet01 - , testProperty "validate arbitrary test header for testnet04" $ prop_validateArbitrary Testnet04 - , testProperty "validate arbitrary test header for devnet" $ prop_validateArbitrary RecapDevelopment + , withVersion mainnet prop_legacy_da_validate + , testProperty "validate arbitrary test header" $ \v -> withVersion v prop_validateArbitrary + , testProperty "validate arbitrary test header for mainnet" $ withVersion Mainnet01 $ prop_validateArbitrary + , testProperty "validate arbitrary test header for testnet04" $ withVersion Testnet04 $ prop_validateArbitrary + , testProperty "validate arbitrary test header for devnet" $ withVersion RecapDevelopment $ prop_validateArbitrary ] --- -------------------------------------------------------------------------- -- --- Rules are not trivial --- --- There is an input for which the rule fails. --- - -prop_forkVotesReset :: ChainwebVersion -> BlockHeight -> TestTree -prop_forkVotesReset v h = testCase ("Invalid fork votes fail validation for " <> sshow v) $ do - hdr <- (blockHeight .~ h) - . (blockForkVotes .~ fromJuste (decode "2")) - . (blockChainwebVersion .~ _versionCode v) - <$> generate arbitrary - let r = prop_block_forkVotesReset hdr - assertBool - ("fork votes validation succeeded unexpectedly: " <> sshow hdr) - (not r) - -- -------------------------------------------------------------------------- -- -- Rules are sound -- @@ -112,16 +93,16 @@ prop_forkVotesReset v h = testCase ("Invalid fork votes fail validation for " <> -- * New minded blocks prop_validateMainnet :: TestTree -prop_validateMainnet = prop_validateHeaders "validate Mainnet01 BlockHeaders" mainnet01Headers +prop_validateMainnet = withVersion mainnet $ prop_validateHeaders "validate Mainnet01 BlockHeaders" mainnet01Headers prop_validateTestnet04 :: TestTree -prop_validateTestnet04 = prop_validateHeaders "validate Testnet04 BlockHeaders" testnet04Headers +prop_validateTestnet04 = withVersion testnet04 $ prop_validateHeaders "validate Testnet04 BlockHeaders" testnet04Headers -prop_validateHeaders :: String -> [TestHeader] -> TestTree +prop_validateHeaders :: HasVersion => String -> [TestHeader] -> TestTree prop_validateHeaders msg hdrs = testGroup msg $ do [ prop_validateHeader ("header " <> show @Int i) h | h <- hdrs | i <- [0..] ] -prop_validateHeader :: String -> TestHeader -> TestTree +prop_validateHeader :: HasVersion => String -> TestHeader -> TestTree prop_validateHeader msg h = testCase msg $ do now <- getCurrentTimeIntegral case validateBlockHeaderM now (testHeaderChainLookup h) (_testHeaderHdr h) of @@ -139,19 +120,19 @@ prop_validateHeader msg h = testCase msg $ do -- would have to be valid. -- -prop_fail_validate :: TestTree +prop_fail_validate :: HasVersion => TestTree prop_fail_validate = validate_cases "validate invalid BlockHeaders" validationFailures prop_forkstate_validate :: TestTree -prop_forkstate_validate = validate_cases "fork state validation" forkValidation +prop_forkstate_validate = withVersion Mainnet01 $ validate_cases "fork state validation" forkValidation prop_da_validate :: TestTree -prop_da_validate = validate_cases "difficulty adjustment validation" daValidation +prop_da_validate = withVersion recapDevnet $ validate_cases "difficulty adjustment validation" daValidation -prop_legacy_da_validate :: TestTree +prop_legacy_da_validate :: HasVersion => TestTree prop_legacy_da_validate = validate_cases "legacy difficulty adjustment validation" legacyDaValidation -validate_cases :: HasCallStack => String -> [(TestHeader, [ValidationFailureType])] -> TestTree +validate_cases :: HasVersion => String -> [(TestHeader, [ValidationFailureType])] -> TestTree validate_cases msg testCases = testCase msg $ do now <- getCurrentTimeIntegral traverse_ (f now) $ zip [0 :: Int ..] testCases @@ -172,14 +153,12 @@ validate_cases msg testCases = testCase msg $ do <> ", epochStart: " <> sshow (view blockEpochStart $ _testHeaderHdr h) <> ", forkNumber: " <> sshow (view blockForkNumber $ _testHeaderHdr h) <> ", forkVotes: " <> sshow (view blockForkVotes $ _testHeaderHdr h) - <> ", isForkEpochStart: " <> sshow (isForkEpochStart v (view blockHeight $ _testHeaderHdr h)) - <> ", isForkCountBlock: " <> sshow (isForkCountBlock v (view blockHeight $ _testHeaderHdr h)) - <> ", parent header: " <> T.unpack (encodeToText $ ObjectEncoded $ view parentHeader $ _testHeaderParent h) - <> ", parent forkNumber: " <> sshow (view blockForkNumber $ view parentHeader $ _testHeaderParent h) - <> ", parent forkVotes: " <> sshow (view blockForkVotes $ view parentHeader $ _testHeaderParent h) + <> ", isForkEpochStart: " <> sshow (isForkEpochStart (view blockHeight $ _testHeaderHdr h)) + <> ", isForkCountBlock: " <> sshow (isForkCountBlock (view blockHeight $ _testHeaderHdr h)) + <> ", parent header: " <> T.unpack (encodeToText $ ObjectEncoded $ view _Parent $ _testHeaderParent h) + <> ", parent forkNumber: " <> sshow (view blockForkNumber $ view _Parent $ _testHeaderParent h) + <> ", parent forkVotes: " <> sshow (view blockForkVotes $ view _Parent $ _testHeaderParent h) | otherwise -> return () - where - v = view chainwebVersion h -- -------------------------------------------------------------------------- -- -- Tests for Rule Guards: @@ -194,12 +173,12 @@ validate_cases msg testCases = testCase msg $ do -- -------------------------------------------------------------------------- -- -- Validation of Arbitrary Test Headers -prop_validateArbitrary :: ChainwebVersion -> Property -prop_validateArbitrary v = - forAll (elements $ toList $ chainIds v) $ \cid -> - forAll (arbitraryTestHeader v cid) validateTestHeader +prop_validateArbitrary :: HasVersion => Property +prop_validateArbitrary = + forAll (elements $ toList chainIds) $ \cid -> + forAll (arbitraryTestHeader cid) validateTestHeader -validateTestHeader :: TestHeader -> Property +validateTestHeader :: HasVersion => TestHeader -> Property validateTestHeader h = case try val of Right (Left ValidationFailure{ _validationFailureFailures = errs }) -> verify errs Right _ -> property True @@ -224,7 +203,7 @@ validationFailures = , ( hdr & testHeaderHdr . blockHash .~ nullBlockHash , [IncorrectHash] ) - , ( hdr & testHeaderHdr . blockCreationTime .~ (view blockCreationTime . _parentHeader $ _testHeaderParent hdr) + , ( hdr & testHeaderHdr . blockCreationTime .~ (view blockCreationTime . unwrapParent $ _testHeaderParent hdr) , [IncorrectHash, IncorrectPow, CreatedBeforeParent] ) , ( hdr & testHeaderHdr . blockHash %~ messWords encodeBlockHash decodeBlockHash (flip complementBit 0) @@ -236,7 +215,7 @@ validationFailures = , ( hdr & testHeaderParent . coerced . blockHeight .~ 318359 , [IncorrectHeight, IncorrectEpoch, IncorrectTarget] ) - , ( hdr & testHeaderHdr . blockParent %~ messWords encodeBlockHash decodeBlockHash (flip complementBit 0) + , ( hdr & testHeaderHdr . blockParent %~ messWords (encodeBlockHash . unwrapParent) (Parent <$> decodeBlockHash) (flip complementBit 0) , [MissingParent] ) , ( hdr & testHeaderHdr . blockPayloadHash %~ messWords encodeBlockPayloadHash decodeBlockPayloadHash (flip complementBit 0) @@ -250,7 +229,11 @@ validationFailures = , [IncorrectHash, IncorrectPow, ChainMismatch, AdjacentChainMismatch] ) , ( hdr & testHeaderHdr . blockChainwebVersion .~ _versionCode RecapDevelopment - , [IncorrectHash, IncorrectPow, UnknownForkNumber, VersionMismatch, InvalidForkVotes, IncorrectForkNumber, CreatedBeforeParent, AdjacentChainMismatch, InvalidAdjacentVersion, InvalidForkVotes] + -- , [IncorrectHash, IncorrectPow, VersionMismatch, InvalidFeatureFlags, CreatedBeforeParent, AdjacentChainMismatch, InvalidAdjacentVersion] + -- no longer. we don't check InvalidFeatureFlags according to the version + -- in the header anymore, but in the HasVersion version. Doesn't matter + -- materially because we get a VersionMismatch error anyway. + , [IncorrectHash, IncorrectPow, VersionMismatch, InvalidAdjacentVersion] ) , ( hdr & testHeaderHdr . blockWeight .~ 10 , [IncorrectHash, IncorrectPow, IncorrectWeight] @@ -284,10 +267,10 @@ validationFailures = , ( hdr & testHeaderHdr . blockAdjacentHashes .~ BlockHashRecord mempty , [IncorrectHash, IncorrectPow, AdjacentChainMismatch] ) - , ( hdr & testHeaderAdjs . each . parentHeader . blockChainwebVersion .~ _versionCode RecapDevelopment + , ( hdr & testHeaderAdjs . each . _Parent . blockChainwebVersion .~ _versionCode RecapDevelopment , [InvalidAdjacentVersion] ) - , ( hdr & testHeaderAdjs . ix 0 . parentHeader . blockChainId .~ unsafeChainId 0 + , ( hdr & testHeaderAdjs . ix 0 . _Parent . blockChainId .~ unsafeChainId 0 , [AdjacentParentChainMismatch] ) ] @@ -317,7 +300,7 @@ validationFailures = -- Fork Validation -forkValidation :: [(TestHeader, [ValidationFailureType])] +forkValidation :: HasVersion => [(TestHeader, [ValidationFailureType])] forkValidation = -- while skipFeatureFlagValidationGuard is active (validation is trivially -- true) @@ -403,14 +386,14 @@ forkValidation = ) , ( hdr1 & p . blockForkVotes .~ addVote resetVotes - & testHeaderAdjs . ix 0 . parentHeader . blockForkVotes .~ addVote resetVotes + & testHeaderAdjs . ix 0 . _Parent . blockForkVotes .~ addVote resetVotes & h . blockForkVotes .~ addVote resetVotes `quot` 2 , [IncorrectHash, IncorrectPow] ) , ( hdr1 & p . blockForkVotes .~ addVote resetVotes - & testHeaderAdjs . ix 0 . parentHeader . blockForkVotes .~ addVote resetVotes - & testHeaderAdjs . ix 1 . parentHeader . blockForkVotes .~ addVote resetVotes + & testHeaderAdjs . ix 0 . _Parent . blockForkVotes .~ addVote resetVotes + & testHeaderAdjs . ix 1 . _Parent . blockForkVotes .~ addVote resetVotes & h . blockForkVotes .~ addVote resetVotes `quot` 2 , [ IncorrectHash , IncorrectPow @@ -453,13 +436,13 @@ forkValidation = -- test correct fork number increment at fork epoch start , ( hdr2 - & p . blockForkVotes .~ int (forkEpochLength (_chainwebVersion hdr2)) * voteStep + & p . blockForkVotes .~ int forkEpochLength * voteStep & h . blockForkVotes .~ resetVotes & h . blockForkNumber .~ view (p . blockForkNumber) hdr2 , [IncorrectForkNumber] ) , ( hdr2 - & p . blockForkVotes .~ int (forkEpochLength (_chainwebVersion hdr2)) * voteStep + & p . blockForkVotes .~ int forkEpochLength * voteStep & h . blockForkVotes .~ resetVotes & h . blockForkNumber .~ view (p . blockForkNumber) hdr2 + 1 , [IncorrectHash, IncorrectPow] @@ -494,12 +477,12 @@ forkValidation = where h, p :: Lens' TestHeader BlockHeader h = testHeaderHdr - p = testHeaderParent . parentHeader - a = testHeaderAdjs . each . parentHeader + p = testHeaderParent . _Parent + a = testHeaderAdjs . each . _Parent -- The number of block heights within an fork epoch where voting happens. -- The remaining blocks are used to count votes. - voteLength = int $ forkEpochLength (_chainwebVersion hdr2) - voteCountingLength + voteLength = int $ forkEpochLength - voteCountingLength hdr0 = mainnet01Headers !! 21 @@ -515,9 +498,9 @@ forkValidation = -- -------------------------------------------------------------------------- -- -- DA Validation -daValidation :: [(TestHeader, [ValidationFailureType])] +daValidation :: HasVersion => [(TestHeader, [ValidationFailureType])] daValidation = - -- test corret epoch transition + -- test correct epoch transition [ ( hdr, expected) -- epoch transition with wrong epoch start time @@ -558,9 +541,9 @@ daValidation = where h, p :: Lens' TestHeader BlockHeader h = testHeaderHdr - p = testHeaderParent . parentHeader + p = testHeaderParent . _Parent - a = testHeaderAdjs . each . parentHeader + a = testHeaderAdjs . each . _Parent expected = [IncorrectHash, IncorrectPow, AdjacentChainMismatch, UnknownForkNumber] @@ -584,7 +567,7 @@ daValidation = $ hdr' hdrAdjs = HM.fromList - $ (\x -> (view (parentHeader . blockChainId) x, x)) + $ (\x -> (view (_Parent . blockChainId) x, x)) <$> view testHeaderAdjs hdr' parentFork = view (p . blockForkNumber) hdr' @@ -616,7 +599,7 @@ legacyDaValidation = where h, p :: Lens' TestHeader BlockHeader h = testHeaderHdr - p = testHeaderParent . parentHeader + p = testHeaderParent . _Parent -- From mainnet height 600000 hdr = testHeader @@ -641,10 +624,7 @@ legacyDaValidation = -- 530_500. -- mainnet01Headers :: [TestHeader] -mainnet01Headers = genesisTestHeaders Mainnet01 <> - - -- 20: height 318266, skipFeatureFlagValidationGuard active, features used as - -- nonce +mainnet01Headers = withVersion Mainnet01 genesisTestHeaders <> [ testHeader [ "parent" .= t "AFHBANxHkLyt2kf7v54FAByxfFrR-pBP8iMLDNKO0SSt-ntTEh1IVT2E4mSPkq02AwACAAAAfaGIEe7a-wGT8OdEXz9RvlzJVkJgmEPmzk42bzjQOi0GAAAAjFsgdB2riCtIs0j40vovGGfcFIZmKPnxEXEekcV28eUIAAAAQcKA2py0L5t1Z1u833Z93V5N4hoKv_7-ZejC_QKTCzTtgKwxXj4Eovf97ELmo_iBruVLoK_Yann5LQIAAAAAALFMJ1gcC8oKW90MW2xY07gN10bM2-GvdC7fDvKDDwAPBwAAAJkPwMVeS7ZkAQAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAOdsEAAAAAAAFAAAAT3hhzb-eBQAAAGFSDbQAAJru7keLmw3rHfSVm9wkTHWQBBTwEPwEg8RA99vzMuj-" , "header" .= t "AEbpAIzqpiins1r8v54FAJru7keLmw3rHfSVm9wkTHWQBBTwEPwEg8RA99vzMuj-AwACAAAAy7QSAHoIeFj0JXide_co-OaEzzYWbeZhAfphXI8-IR0GAAAAa-PzO_zUmk1yLOyt2kD3iI6cehKqQ_KdK8D6qZ-X6X4IAAAA79Vw2kqbVDHm9WDzksFwxZcmx5OJJNW-ge7jVa3HiHbtgKwxXj4Eovf97ELmo_iBruVLoK_Yann5LQIAAAAAAL701u70FOrdivm6quNUsKgfi2L8zYHeyOI0j2gfP16jBwAAANz0ZdfSwLZkAQAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAOtsEAAAAAAAFAAAAT3hhzb-eBQAAAPvI7fkAAFFuYkCHZRcNl1k3-A1EZvyPxhiFKdHZwZRTqos57aiO" @@ -712,14 +692,14 @@ mainnet01Headers = genesisTestHeaders Mainnet01 <> ] testnet04Headers :: [TestHeader] -testnet04Headers = genesisTestHeaders Testnet04 +testnet04Headers = withVersion Testnet04 genesisTestHeaders -- TODO replace these by "interesting headers" form mainnet (e.g. fork block heights) -_testnet04InvalidHeaders :: [(ParentHeader, BlockHeader, [ValidationFailureType])] +_testnet04InvalidHeaders :: [(Parent BlockHeader, BlockHeader, [ValidationFailureType])] _testnet04InvalidHeaders = some where f (p, h, e) = (,,) - <$> (fmap ParentHeader . decode . wrap) p + <$> (fmap Parent . decode . wrap) p <*> (decode . wrap) h <*> pure e diff --git a/test/unit/Chainweb/Test/BlockHeaderDB.hs b/test/unit/Chainweb/Test/BlockHeaderDB.hs index 0b1222d6f2..cab9fd2579 100644 --- a/test/unit/Chainweb/Test/BlockHeaderDB.hs +++ b/test/unit/Chainweb/Test/BlockHeaderDB.hs @@ -32,9 +32,11 @@ import Chainweb.Test.Utils import Chainweb.TreeDB import Chainweb.Storage.Table.RocksDB +import Chainweb.Version (withVersion, HasVersion) tests :: RocksDb -> TestTree -tests rdb = testGroup "Unit Tests" +tests rdb = withVersion toyVersion $ + testGroup "Unit Tests" [ testGroup "Basic Interaction" [ testCase "Initialization + Shutdown" $ toyBlockHeaderDb rdb toyChainId >>= closeBlockHeaderDb . snd ] @@ -54,22 +56,21 @@ tests rdb = testGroup "Unit Tests" testGroup ] -insertItems :: RocksDb -> Assertion +insertItems :: HasVersion => RocksDb -> Assertion insertItems rdb = runResourceT $ do (g, db) <- withToyDB rdb toyChainId liftIO $ insertN 10 g db -correctHeight :: RocksDb -> Assertion +correctHeight :: HasVersion => RocksDb -> Assertion correctHeight rdb = runResourceT $ do (g, db) <- withToyDB rdb toyChainId liftIO $ maxRank db >>= \r -> r @?= 0 liftIO $ insertN 10 g db liftIO $ maxRank db >>= \r -> r @?= 10 -rankFiltering :: RocksDb -> Assertion +rankFiltering :: HasVersion => RocksDb -> Assertion rankFiltering rdb = runResourceT $ do (g, db) <- withToyDB rdb toyChainId liftIO $ insertN 100 g db l <- liftIO $ entries db Nothing Nothing (Just . MinRank $ Min 90) Nothing $ S.length_ liftIO $ l @?= 11 - diff --git a/test/unit/Chainweb/Test/BlockHeaderDB/PruneForks.hs b/test/unit/Chainweb/Test/BlockHeaderDB/PruneForks.hs index b8a886b384..8fe023c3d3 100644 --- a/test/unit/Chainweb/Test/BlockHeaderDB/PruneForks.hs +++ b/test/unit/Chainweb/Test/BlockHeaderDB/PruneForks.hs @@ -1,6 +1,10 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ImportQualifiedPost #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PartialTypeSignatures #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeFamilies #-} -- | @@ -16,41 +20,54 @@ module Chainweb.Test.BlockHeaderDB.PruneForks ( tests ) where -import Control.Lens (view, (.~)) -import Control.Monad -import Control.Monad.Catch - -import qualified Data.Text as T - -import Numeric.Natural - -import System.LogLevel -import System.Random - -import Test.Tasty -import Test.Tasty.HUnit - --- internal modules - -import Chainweb.BlockHeader.Internal +import Control.Concurrent.STM +import Chainweb.BlockHash +import Chainweb.BlockHeader import Chainweb.BlockHeader.Validation import Chainweb.BlockHeaderDB import Chainweb.BlockHeaderDB.Internal import Chainweb.BlockHeaderDB.PruneForks -import Chainweb.Chainweb.PruneChainDatabase +import Chainweb.ChainValue +import Chainweb.Core.Brief +import Chainweb.Cut (unsafeMkCut, genesisCut, Cut) +import Chainweb.Cut.Create +import Chainweb.Cut.CutHashes +import Chainweb.CutDB +import Chainweb.Graph import Chainweb.Logger -import Chainweb.Payload -import Chainweb.Payload.PayloadStore -import Chainweb.Payload.PayloadStore.RocksDB +import Chainweb.Parent +import Chainweb.PayloadProvider (ConfiguredPayloadProvider(DisabledPayloadProvider)) +import Chainweb.Ranked +import Chainweb.Storage.Table +import Chainweb.Storage.Table.RocksDB +import Chainweb.Test.CutDB (withTestCutDb) +import Chainweb.Test.Pact.Utils +import Chainweb.Test.TestVersions import Chainweb.Test.Utils import Chainweb.Test.Utils.BlockHeader +import Chainweb.TreeDB qualified as TreeDB import Chainweb.Utils import Chainweb.Version -import Chainweb.Version.RecapDevelopment - -import Chainweb.Storage.Table -import Chainweb.Storage.Table.RocksDB -import Chainweb.BlockHeight +import Chainweb.Version.Utils (avgBlockHeightAtCutHeight, chainIdsAt) +import Chainweb.WebBlockHeaderDB +import Control.Lens +import Control.Monad +import Control.Monad.Catch +import Control.Monad.IO.Class +import Control.Monad.State.Strict +import Control.Monad.Trans.Resource +import Data.HashMap.Strict qualified as HM +import Data.HashSet qualified as HS +import Data.Maybe (mapMaybe, catMaybes) +import Data.Text qualified as T +import Numeric.Natural +import PropertyMatchers qualified as P +import Streaming qualified as S +import Streaming.Prelude qualified as S +import System.LogLevel +import System.Random.Shuffle (shuffleM) +import Test.Tasty +import Test.Tasty.HUnit -- -------------------------------------------------------------------------- -- -- Utils @@ -67,46 +84,204 @@ testLogLevel = Warn -- | otherwise = return () withDbs - :: IO RocksDb - -> (RocksDb -> BlockHeaderDb -> PayloadDb RocksDbTable -> BlockHeader -> IO ()) - -> IO () -withDbs rio inner = do + :: HasVersion + => RocksDb + -> ResourceT IO (CutDb GenericLogger) +withDbs rdb = do -- create unique namespace for each test so that they so that test can -- run in parallel. - x <- randomIO :: IO Int - rdb <- rio >>= testRocksDb (sshow x) - - let pdb = newPayloadDb rdb - initializePayloadDb toyVersion pdb - bracket - (initBlockHeaderDb (Configuration h rdb)) - closeBlockHeaderDb - (\bdb -> inner rdb bdb pdb h) - where - h = toyGenesis cid + -- x <- randomIO :: IO Int + -- rdb <- rio >>= testRocksDb (sshow x) + testLogger <- liftIO getTestLogger + (_, cutDb) <- withTestCutDb rdb id 0 (onAllChains DisabledPayloadProvider) testLogger + return cutDb + +-- | Add a cut to the CutDb pipeline and wait until it becomes the current +-- cut. +-- +pushCutAndAwait :: CutDb logger -> Cut -> IO () +pushCutAndAwait cdb cut = do + let cutHashes = cutToCutHashes Nothing cut + addCutHashes cdb cutHashes + atomically $ do + curCut <- _cutStm cdb + guard (cutToCutHashes Nothing curCut == cutHashes) + +selectHighCuts :: Casify RocksDbTable CutHashes -> Int -> Maybe (CasKeyType CutHashes) -> IO ([CutHashes], CasKeyType CutHashes) +selectHighCuts cutTable candidateCount maybeMaxCutHeight = do + (highestCuts, nextCutHeight) <- withTableIterator cutTable $ \iter -> do + case maybeMaxCutHeight of + Nothing -> + iterLast iter + Just ch -> do + iterSeek iter ch + iterPrev iter + + cuts <- fmap catMaybes $ replicateM candidateCount $ do + iterValue iter >>= \case + Just r -> do + iterPrev iter + return (Just r) + Nothing -> return Nothing + nextCutHeight <- iterKey iter >>= \case + Nothing -> iterNext iter >> fromJuste <$> iterKey iter + Just ch -> return ch + return (cuts, nextCutHeight) + (,nextCutHeight) <$> shuffleM highestCuts + +findM :: Monad m => [t] -> (t -> m (Maybe a)) -> m (Maybe a) +findM (x:xs) f = do + y <- f x + case y of + Nothing -> findM xs f + Just u -> return $ Just u +findM [] _ = return Nothing + +selectNewBlockParents + :: HasVersion + => Casify RocksDbTable CutHashes + -> WebBlockHeaderDb + -> Maybe (CasKeyType CutHashes) + -> Int + -> IO CutExtension +selectNewBlockParents cutTable wbhdb maybeMaxCutHeight candCutCount = do + (candCutHashesList, newMaxCutHeight) <- selectHighCuts cutTable candCutCount maybeMaxCutHeight + shuffledChains <- shuffleM $ HS.toList $ chainIdsAt (round $ avgBlockHeightAtCutHeight $ maybe maxBound (view _1) maybeMaxCutHeight) + r <- findM candCutHashesList $ \candCutHashes -> do + candCutBlocks <- liftIO $ + iforM (candCutHashes ^. cutHashes) (lookupRankedWebBlockHeaderDb wbhdb) + let candCut = unsafeMkCut candCutBlocks + let exts = mapMaybe (getCutExtension candCut) shuffledChains + case exts of + ext:_ -> return $ Just ext + [] -> return Nothing + case r of + Just r' -> return r' + Nothing -> selectNewBlockParents cutTable wbhdb (Just newMaxCutHeight) candCutCount + +progressArbitraryFork + :: (HasVersion, MonadIO m, MonadState Nonce m) + => Casify RocksDbTable CutHashes + -> WebBlockHeaderDb + -> Int + -> m () +progressArbitraryFork cutTable wbhdb candCutCount = do + cutExt <- liftIO $ selectNewBlockParents cutTable wbhdb Nothing candCutCount + let parent = _cutExtensionParent cutExt + let bhdb = wbhdb ^?! webBlockHeaderDb . ix (parent ^. chainId) + adjsForParent <- liftIO $ iforMOf (itraversed . _Parent) + (_getBlockHashRecord $ _cutExtensionAdjacentHashes cutExt) + (\c blk -> lookupRankedWebBlockHeaderDb wbhdb c + (Ranked (view (_Parent . blockHeight) parent) blk)) + nextNonce <- get + let newBlock = testBlockHeader adjsForParent nextNonce parent + liftIO $ unsafeInsertBlockHeaderDb bhdb newBlock + newCut <- liftIO $ tryMonotonicCutExtension (_cutExtensionCut cutExt) newBlock + liftIO $ casInsert cutTable (cutToCutHashes Nothing $ fromJuste newCut) + put (succ nextNonce) + return () + +pruneTestRandom + :: HasVersion + => RocksDb + -> (Casify RocksDbTable CutHashes -> WebBlockHeaderDb -> StateT Nonce IO a) + -> IO Int +pruneTestRandom baseRdb f = runResourceT $ do + rdb <- withTestRocksDb "" baseRdb + liftIO $ do + let t = cutHashesTable rdb + wbhdb <- initWebBlockHeaderDb rdb + let lookupChainBlk (ChainValue c bhsh) = do + db <- getWebBlockHeaderDb wbhdb c + TreeDB.lookup db bhsh + let validateAllBlocks = do + void $ webEntries wbhdb Nothing Nothing $ \blks -> do + blks + & S.hoist liftIO + & S.mapM_ (\blk -> + validateAllParentsExist lookupChainBlk blk + >>= \case + Right r -> P.succeed r + Left e -> P.fail "successful validation" (e, "failed on block: " <> sshow blk) + ) + casInsert t (cutToCutHashes Nothing genesisCut) + lgr <- getTestLogger + logFunctionText lgr Info "inserting blocks..." + (_, finalNonce) <- flip runStateT (Nonce 0) $ f t wbhdb + logFunctionText lgr Info $ "final nonce " <> sshow finalNonce + logFunctionText lgr Info "validating initial blocks..." + validateAllBlocks + highestCut <- readHighestCutHeaders (logFunctionText lgr) wbhdb t + numPruned <- pruneForks lgr (unsafeMkCut highestCut) wbhdb Prune 0 + logFunctionText lgr Info "validating pruned blocks..." + validateAllBlocks + return numPruned + +pruneTestWithOnePivot :: _ +pruneTestWithOnePivot rdb = withVersion (barebonesTestVersion pairChainGraph) $ do + _ <- pruneTestRandom rdb $ \t wbhdb -> do + replicateM_ 4000 $ do + progressArbitraryFork t wbhdb 2 + replicateM_ 10 $ do + progressArbitraryFork t wbhdb 1 + return () + +pruneTestWithLotsOfPivots :: _ +pruneTestWithLotsOfPivots rdb = withVersion (barebonesTestVersion pairChainGraph) $ do + _ <- pruneTestRandom rdb $ \t wbhdb -> do + replicateM_ 4000 $ do + progressArbitraryFork t wbhdb 16 + return () + +pruneTestWithManyForks :: _ +pruneTestWithManyForks rdb = withVersion (barebonesTestVersion pairChainGraph) $ do + _ <- pruneTestRandom rdb $ \t wbhdb -> do + replicateM_ 4000 $ do + progressArbitraryFork t wbhdb 16 + return () + +pruneTestWithManyChains :: _ +pruneTestWithManyChains rdb = withVersion (barebonesTestVersion petersenChainGraph) $ do + _ <- pruneTestRandom rdb $ \t wbhdb -> do + replicateM_ 1000 $ do + progressArbitraryFork t wbhdb 14 + return () + +pruneTestWithManyManyChains :: _ +pruneTestWithManyManyChains rdb = withVersion (barebonesTestVersion d4k4ChainGraph) $ do + _ <- pruneTestRandom rdb $ \t wbhdb -> do + replicateM_ 200 $ do + progressArbitraryFork t wbhdb 1 + replicateM_ 400 $ do + progressArbitraryFork t wbhdb 140 + replicateM_ 400 $ do + progressArbitraryFork t wbhdb 1 + return () + +pruneTestSmall :: _ +pruneTestSmall rdb = withVersion (barebonesTestVersion petersenChainGraph) $ do + _ <- pruneTestRandom rdb $ \t wbhdb -> do + replicateM_ 20 $ do + progressArbitraryFork t wbhdb 1 + return () createForks - :: BlockHeaderDb - -> PayloadDb RocksDbTable + :: HasVersion + => BlockHeaderDb -> BlockHeader -> IO ([BlockHeader], [BlockHeader]) -createForks bdb pdb h = (,) - <$> insertWithPayloads bdb pdb h (Nonce 1) 10 - <*> insertWithPayloads bdb pdb h (Nonce 2) 5 +createForks bdb h = (,) + <$> insert bdb h (Nonce 1) 10 + <*> insert bdb h (Nonce 2) 5 -insertWithPayloads - :: BlockHeaderDb - -> PayloadDb RocksDbTable +insert + :: HasVersion + => BlockHeaderDb -> BlockHeader -> Nonce -> Natural -> IO [BlockHeader] -insertWithPayloads bdb pdb h n l = do - hdrs <- insertN_ n l h bdb - forM_ hdrs $ \hd -> - let payload = testBlockPayload_ hd - in addNewPayload pdb (view blockHeight hd) payload - return hdrs +insert bdb h n l = insertN_ n l h bdb cid :: ChainId cid = unsafeChainId 0 @@ -119,248 +294,155 @@ delHdr cdb k = do -- -------------------------------------------------------------------------- -- -- Test cases -tests :: TestTree -tests = withResourceT withRocksResource $ \rio -> +tests :: RocksDb -> TestTree +tests rdb = testGroup "Chainweb.BlockHeaderDb.PruneForks" - [ testCaseSteps "simple 1" (test0 rio) - , testCaseSteps "simple 2" (test1 rio) - , testCaseSteps "simple 3" (test2 rio) - , testCaseSteps "simple 5" (test3 rio) - , testCaseSteps "Skippping: max bound 1" $ test4 rio - , testCaseSteps "Skippping: depth 10" $ test5 rio - , testCaseSteps "fail on missing header 5" $ failTest rio 5 - , testCaseSteps "fail on missing header 6" $ failTest rio 6 + [ testCaseSteps "simple 1" + $ withVersion (barebonesTestVersion singletonChainGraph) + $ singleForkTest rdb 1 5 + , testCaseSteps "simple 2" + $ withVersion (barebonesTestVersion singletonChainGraph) + $ singleForkTest rdb 2 5 + , testCaseSteps "simple 3" + $ withVersion (barebonesTestVersion singletonChainGraph) + $ singleForkTest rdb 4 5 + , testCaseSteps "simple 4" + $ withVersion (barebonesTestVersion singletonChainGraph) + $ singleForkTest rdb 5 0 + , testCaseSteps "skipping: max bound 1" + $ withVersion (barebonesTestVersion singletonChainGraph) + $ singleForkTest rdb 9 0 + , testCaseSteps "skipping: depth == max block height" + $ withVersion (barebonesTestVersion singletonChainGraph) + $ singleForkTest rdb 10 0 + , testCaseSteps "fail on missing header 5" $ failTest rdb 5 + , testCaseSteps "fail on missing header 6" $ failTest rdb 6 -- failTest <= 4: succeeds because of second branch -- failTest 7: empty upper bound warning -- failTest 8: succeeds because deleted block at height 8 is above upper pruning bound - , pruneWithChecksTests rio - , failPruningChecksTests rio - , testCaseSteps "full gc" $ testFullGc rio - ] + -- , pruneWithChecksTests rdb + -- , failPruningChecksTests rdb + , testCaseSteps "full gc" $ testFullGc rdb -pruneWithChecksTests :: IO RocksDb -> TestTree -pruneWithChecksTests rio = testGroup "prune with checks" $ go <$> - [ [CheckPayloads] - , [CheckPayloadsExist] - , [CheckIntrinsic] - , [CheckInductive] - , [CheckFull] - , [minBound .. maxBound] - ] - where - go checks = testCaseSteps (sshow checks) $ testPruneWithChecks rio checks + , testCase "small" $ pruneTestSmall rdb + + , testCase "one pivot" $ pruneTestWithOnePivot rdb + + , testCase "lots of pivots" $ pruneTestWithLotsOfPivots rdb -failPruningChecksTests :: IO RocksDb -> TestTree -failPruningChecksTests rio = testGroup "fail pruning checks" - [ testCaseSteps "CheckPayloadExists" $ failPayloadCheck rio [CheckPayloadsExist] 7 - , testCaseSteps "CheckPayload" $ failPayloadCheck rio [CheckPayloads] 7 + , testCase "many forks" $ pruneTestWithManyForks rdb - -- deleted transactions from payload - -- CheckPayloadsExist succeeds for this scenario - , testCaseSteps "CheckPayload2" $ failPayloadCheck2 rio [CheckPayloads] 7 + , testCase "many chains" $ pruneTestWithManyChains rdb + , testCase "many many chains" $ pruneTestWithManyManyChains rdb - , testCaseSteps "CheckIntrinsic" $ failIntrinsicCheck rio [CheckIntrinsic] 7 - , testCaseSteps "CheckInductive" $ failIntrinsicCheck rio [CheckInductive] 7 - , testCaseSteps "CheckFull" $ failIntrinsicCheck rio [CheckFull] 7 - ] + ] + +-- pruneWithChecksTests :: IO RocksDb -> TestTree +-- pruneWithChecksTests rio = testGroup "prune with checks" $ go <$> +-- [ [CheckPayloads] +-- , [CheckPayloadsExist] +-- , [CheckIntrinsic] +-- , [CheckInductive] +-- , [CheckFull] +-- , [minBound .. maxBound] +-- ] +-- where +-- go checks = testCaseSteps (sshow checks) $ testPruneWithChecks rio checks + +-- failPruningChecksTests :: IO RocksDb -> TestTree +-- failPruningChecksTests rio = testGroup "fail pruning checks" +-- [ testCaseSteps "CheckIntrinsic" $ failIntrinsicCheck rio [CheckIntrinsic] 7 +-- , testCaseSteps "CheckInductive" $ failIntrinsicCheck rio [CheckInductive] 7 +-- , testCaseSteps "CheckFull" $ failIntrinsicCheck rio [CheckFull] 7 +-- ] singleForkTest - :: IO RocksDb - -> (String -> IO ()) + :: HasVersion + => RocksDb -> Natural -> Int - -> String + -> (String -> IO ()) -> IO () -singleForkTest rio step d expect msg = - withDbs rio $ \_rdb db pdb h -> do - (f0, f1) <- createForks db pdb h - n <- pruneForks logg db d $ \_ x -> - logg Info (sshow $ view blockHeight x) +singleForkTest rdb d expect step = runResourceT $ do + cdb <- withDbs rdb + liftIO $ do + let db = cdb ^?! cutDbBlockHeaderDb cid + let h = genesisBlockHeader cid + (f0, f1) <- createForks db h + let initialCut = unsafeMkCut (HM.singleton cid (last f0)) + pushCutAndAwait cdb initialCut + let wbhdb = view cutDbWebBlockHeaderDb cdb + n <- pruneForks logg initialCut wbhdb Prune d assertHeaders db f0 when (expect > 0) $ assertPrunedHeaders db f1 - assertEqual msg expect n + assertEqual "" expect n where - logg = logFunctionText $ genericLogger testLogLevel (step . T.unpack) + logg = genericLogger testLogLevel (step . T.unpack) -assertHeaders :: BlockHeaderDb -> [BlockHeader] -> IO () +assertHeaders :: HasVersion => BlockHeaderDb -> [BlockHeader] -> IO () assertHeaders db f = unlessM (fmap and $ mapM (tableMember db) $ view blockHash <$> f) $ assertFailure "missing block header that should not have been pruned" -assertPrunedHeaders :: BlockHeaderDb -> [BlockHeader] -> IO () +assertPrunedHeaders :: HasVersion => BlockHeaderDb -> [BlockHeader] -> IO () assertPrunedHeaders db f = - whenM (fmap or $ mapM (tableMember db) $ view blockHash <$> f) $ - assertFailure "failed to prune some block header" - -assertPayloads :: PayloadDb RocksDbTable -> [BlockHeader] -> IO () -assertPayloads db f = do - let fs = (\h -> (Just $ view blockHeight h, view blockPayloadHash h)) <$> f - unlessM (and <$> mapM (uncurry $ lookupPayloadWithHeightExists db) fs) $ - assertFailure "missing block payload that should not have been garbage collected" - --- | This can fail due to the probabilistic nature of the GC algorithms --- -assertPrunedPayloads :: PayloadDb RocksDbTable -> [BlockHeader] -> IO () -assertPrunedPayloads db f = do - let fs = (\h -> (Just $ view blockHeight h, view blockPayloadHash h)) <$> f - results <- mapM (uncurry $ lookupPayloadWithHeightExists db) fs - let remained = length (filter id results) - when (remained > 1) $ - assertFailure $ "failed to garage collect some block payloads" - <> ". " <> sshow remained <> " remaining" - <> ". Since can happen due to the probabilistic natures of the garabage collection algorithm" - <> ". But it should very rare. Try to rerun the test." - -lookupPayloadWithHeightExists - :: PayloadDb RocksDbTable - -> Maybe BlockHeight - -> BlockPayloadHash - -> IO Bool -lookupPayloadWithHeightExists db h k = lookupPayloadWithHeight db h k >>= \case - Nothing -> pure False - Just _ -> pure True + forM_ f $ \bh -> do + whenM (tableMember db (casKey bh)) $ + assertFailure $ "failed to prune some block header: " <> T.unpack (brief bh) -- -------------------------------------------------------------------------- -- -- Header Pruning Tests -test0 :: IO RocksDb -> (String -> IO ()) -> IO () -test0 rio step = singleForkTest rio step 1 5 "5 block headers pruned" - -test1 :: IO RocksDb -> (String -> IO ()) -> IO () -test1 rio step = singleForkTest rio step 2 5 "5 block headers pruned" - -test2 :: IO RocksDb -> (String -> IO ()) -> IO () -test2 rio step = singleForkTest rio step 4 5 "5 block headers pruned" - -test3 :: IO RocksDb -> (String -> IO ()) -> IO () -test3 rio step = singleForkTest rio step 5 0 "0 block headers pruned" - -test4 :: IO RocksDb -> (String -> IO ()) -> IO () -test4 rio step = singleForkTest rio step 9 0 "Skipping: max bound 1" - -test5 :: IO RocksDb -> (String -> IO ()) -> IO () -test5 rio step = singleForkTest rio step 10 0 - "Skipping: depth == max block height" - -failTest :: IO RocksDb -> Natural -> (String -> IO ()) -> IO () -failTest rio n step = withDbs rio $ \_rdb db pdb h -> do - (f0, _) <- createForks db pdb h - delHdr db $ f0 !! (int n) - try (prune db 2) >>= \case - Left (InternalInvariantViolation{}) -> return () - Right x -> assertFailure - $ "missing expected InternalInvariantViolation" - <> ". Instead pruning succeeded and deleted " - <> sshow x <> " headers" - return () +failTest :: RocksDb -> Natural -> (String -> IO ()) -> IO () +failTest rio n step = withVersion (barebonesTestVersion singletonChainGraph) $ runResourceT $ do + cdb <- withDbs rio + liftIO $ do + let db = cdb ^?! cutDbBlockHeaderDb cid + let h = genesisBlockHeader cid + (f0, _) <- createForks db h + pushCutAndAwait cdb $ unsafeMkCut (HM.singleton cid (last f0)) + delHdr db $ f0 !! int n + initialCut <- _cut cdb + let wbhdb = view cutDbWebBlockHeaderDb cdb + try (pruneForks logg initialCut wbhdb ForcePrune 2) >>= \case + Left (InternalInvariantViolation{}) -> return () + Right x -> assertFailure + $ "missing expected InternalInvariantViolation" + <> ". Instead pruning succeeded and deleted " + <> sshow x <> " headers" + return () where - prune db d = pruneForks logg db d $ \_ h -> - logg Info (sshow $ view blockHeight h) - - logg = logFunctionText $ genericLogger testLogLevel (step . T.unpack) + logg = genericLogger testLogLevel (step . T.unpack) -- -------------------------------------------------------------------------- -- -- GC Tests -testFullGc :: IO RocksDb -> (String -> IO ()) -> IO () -testFullGc rio step = withDbs rio $ \rdb db pdb h -> do - (f0, f1) <- createForks db pdb h - fullGc logger rdb toyVersion - assertHeaders db f0 - assertPrunedHeaders db f1 - assertPayloads pdb f0 - assertPrunedPayloads pdb f1 - where - logger = genericLogger testLogLevel (step . T.unpack) - -testPruneWithChecks :: IO RocksDb -> [PruningChecks] -> (String -> IO ()) -> IO () -testPruneWithChecks rio checks step = withDbs rio $ \rdb db pdb h -> do - (f0, f1) <- createForks db pdb h - pruneAllChains logger rdb toyVersion checks - assertHeaders db f0 - assertPrunedHeaders db f1 - where - logger = genericLogger testLogLevel (step . T.unpack) - --- | Remove BlockPayload from the Payload. --- -failIntrinsicCheck :: IO RocksDb -> [PruningChecks] -> Natural -> (String -> IO ()) -> IO () -failIntrinsicCheck rio checks n step = withDbs rio $ \rdb bdb pdb h -> do - (f0, _) <- createForks bdb pdb h - let b = f0 !! int n - delHdr bdb b - unsafeInsertBlockHeaderDb bdb $ b - & blockChainwebVersion .~ _versionCode RecapDevelopment - try (pruneAllChains logger rdb toyVersion checks) >>= \case - Left e - | CheckFull `elem` checks - && VersionMismatch `elem` _validationFailureFailures e - && IncorrectHash `elem` _validationFailureFailures e - && AdjacentChainMismatch `elem` _validationFailureFailures e -> return () - | CheckInductive `elem` checks - && VersionMismatch `elem` _validationFailureFailures e -> return () - | CheckIntrinsic `elem` checks - && IncorrectHash `elem` _validationFailureFailures e - && AdjacentChainMismatch `elem` _validationFailureFailures e -> return () - | otherwise -> - assertFailure $ "test failed with unexpected validation failure: " <> sshow e - Right x -> assertFailure - $ "missing expected ValidationFailure" - <> ". Instead pruning succeeded and deleted " - <> sshow x <> " headers" - return () - where - logger = genericLogger testLogLevel (step . T.unpack) - --- | Remove BlockPayload from the Payload. --- --- CheckPayloadsExist and CheckPayload fail for this scenario --- -failPayloadCheck :: IO RocksDb -> [PruningChecks] -> Natural -> (String -> IO ()) -> IO () -failPayloadCheck rio checks n step = withDbs rio $ \rdb bdb pdb h -> do - (f0, _) <- createForks bdb pdb h - let b = f0 !! int n - p <- lookupPayloadDataWithHeight pdb (Just $ view blockHeight b) (view blockPayloadHash b) >>= \case - Nothing -> assertFailure "missing payload" - Just x -> return x - deletePayload pdb (payloadDataToBlockPayload p) - - try (pruneAllChains logger rdb toyVersion checks) >>= \case - Left (MissingPayloadException{}) -> return () - Left e -> assertFailure - $ "Expected MissingPayloadException but got: " - <> sshow e - Right x -> assertFailure - $ "missing expected MissingPayloadException" - <> ". Instead pruning succeeded and deleted " - <> sshow x <> " headers" - return () +testFullGc :: RocksDb -> (String -> IO ()) -> IO () +testFullGc rdb step = withVersion (barebonesTestVersion singletonChainGraph) $ runResourceT $ do + cdb <- withDbs rdb + let db = cdb ^?! cutDbBlockHeaderDb cid + let h = genesisBlockHeader cid + liftIO $ do + (f0, f1) <- createForks db h + let initialCut = unsafeMkCut (HM.singleton cid (last f0)) + pushCutAndAwait cdb initialCut + let wbhdb = view cutDbWebBlockHeaderDb cdb + _ <- pruneForks logger initialCut wbhdb ForcePrune 0 + assertHeaders db f0 + assertPrunedHeaders db f1 where logger = genericLogger testLogLevel (step . T.unpack) --- | Remove the Transactions from the Payload. --- --- CheckPayloadsExist succeeds for this scenario. CheckPayload fails. --- -failPayloadCheck2 :: IO RocksDb -> [PruningChecks] -> Natural -> (String -> IO ()) -> IO () -failPayloadCheck2 rio checks n step = withDbs rio $ \rdb bdb pdb h -> do - (f0, _) <- createForks bdb pdb h - let b = f0 !! int n - payload <- lookupPayloadWithHeight pdb (Just $ view blockHeight b) (view blockPayloadHash b) >>= \case - Nothing -> assertFailure "missing payload" - Just x -> return x - tableDelete (_newTransactionDbBlockTransactionsTbl $ _transactionDb pdb) - (view blockHeight b, _payloadWithOutputsTransactionsHash payload) - try (pruneAllChains logger rdb toyVersion checks) >>= \case - Left (MissingPayloadException{}) -> return () - Left e -> assertFailure - $ "Expected MissingPayloadException but got: " - <> sshow e - Right x -> assertFailure - $ "missing expected MissingPayloadException" - <> ". Instead pruning succeeded and deleted " - <> sshow x <> " headers" - return () +testPruneWithChecks :: RocksDb -> (String -> IO ()) -> IO () +testPruneWithChecks rdb step = withVersion (barebonesTestVersion singletonChainGraph) $ runResourceT $ do + cdb <- withDbs rdb + let db = cdb ^?! cutDbBlockHeaderDb cid + let h = genesisBlockHeader cid + liftIO $ do + (f0, f1) <- createForks db h + -- pruneAllChains logger rdb (barebonesTestVersion singletonChainGraph) + assertHeaders db f0 + assertPrunedHeaders db f1 where logger = genericLogger testLogLevel (step . T.unpack) diff --git a/test/unit/Chainweb/Test/CutDB.hs b/test/unit/Chainweb/Test/CutDB.hs index d1fa8aa936..fb3288fe05 100644 --- a/test/unit/Chainweb/Test/CutDB.hs +++ b/test/unit/Chainweb/Test/CutDB.hs @@ -1,12 +1,11 @@ {-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE BangPatterns #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ImportQualifiedPost #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NumericUnderscores #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeFamilies #-} -- | @@ -18,77 +17,69 @@ -- module Chainweb.Test.CutDB ( withTestCutDb -, extendTestCutDb -, syncPact +-- , extendTestCutDb , withTestCutDbWithoutPact , withTestPayloadResource , awaitCut , awaitBlockHeight -, extendAwait +-- , extendAwait , randomTransaction , randomBlockHeader -, fakePact +-- , fakePact , tests ) where -import Control.Concurrent.Async -import Control.Concurrent.STM as STM -import Control.Lens hiding (elements) -import Control.Monad -import Control.Monad.Catch -import Control.Monad.Trans.Resource - -import Data.Foldable -import Data.Function -import qualified Data.HashMap.Strict as HM -import Data.Semigroup -import qualified Data.Vector as V - -import GHC.Stack - -import qualified Network.HTTP.Client as HTTP - -import Numeric.Natural - -import qualified Streaming.Prelude as S - -import Test.QuickCheck -import Test.Tasty - --- internal modules - +import Chainweb.Chainweb.Configuration (defaultPayloadProviderConfig, defaultServiceApiConfig) import Chainweb.BlockHeader import Chainweb.BlockHeight import Chainweb.ChainId +import Chainweb.Chainweb.ChainResources (withPayloadProviderResources, providerResPayloadProvider) import Chainweb.Cut import Chainweb.Cut.CutHashes -import Chainweb.Graph -import Chainweb.Test.Cut import Chainweb.CutDB import Chainweb.CutDB.RestAPI.Server -import Chainweb.Miner.Pact +import Chainweb.Graph +import Chainweb.Logger +import Chainweb.Pact.Payload +import Chainweb.Pact.Payload.PayloadStore import Chainweb.Pact.Types -import Chainweb.Payload -import Chainweb.Payload.PayloadStore -import Chainweb.Payload.PayloadStore.RocksDB +import Chainweb.PayloadProvider +import Chainweb.Scheduler (withScheduler) +import Chainweb.Storage.Table +import Chainweb.Storage.Table.RocksDB import Chainweb.Sync.WebBlockHeaderStore +import Chainweb.Test.Cut import Chainweb.Test.Orphans.Internal () +import Chainweb.Test.Pact.Utils (getTestLogger) import Chainweb.Test.Sync.WebBlockHeaderStore -import Chainweb.Test.Utils hiding (awaitBlockHeight) import Chainweb.Test.TestVersions (barebonesTestVersion) +import Chainweb.Test.Utils hiding (awaitBlockHeight) import Chainweb.Time import Chainweb.TreeDB (MaxRank(..)) import Chainweb.Utils import Chainweb.Version import Chainweb.Version.Utils import Chainweb.WebBlockHeaderDB -import Chainweb.WebPactExecutionService - -import Chainweb.Storage.Table -import Chainweb.Storage.Table.RocksDB -import Data.LogMessage +import Control.Concurrent.Async +import Control.Concurrent.STM as STM +import Control.Lens hiding (elements) +import Control.Monad +import Control.Monad.Catch +import Control.Monad.IO.Class +import Control.Monad.Trans.Resource +import Data.Foldable +import Data.Function +import Data.HashMap.Strict qualified as HM +import Data.HashSet qualified as HS +import Data.Semigroup import Data.TaskMap - +import Data.Vector qualified as V +import GHC.Stack +import Network.HTTP.Client qualified as HTTP +import Streaming.Prelude qualified as S +import System.LogLevel +import Test.QuickCheck +import Test.Tasty import Test.Tasty.HUnit -- -------------------------------------------------------------------------- -- @@ -105,16 +96,16 @@ cutFetchTimeout = 3_000_000 -- inserted. -- withTestCutDb - :: forall a - . HasCallStack + :: HasCallStack + => HasVersion + => Logger logger => RocksDb - -> ChainwebVersion -- ^ the chainweb version -> (CutDbParams -> CutDbParams) -- ^ any alterations to the CutDB's configuration -> Int -- ^ number of blocks in the chainweb in addition to the genesis blocks - -> (WebBlockHeaderDb -> PayloadDb RocksDbTable -> IO WebPactExecutionService) + -> ChainMap ConfiguredPayloadProvider -- ^ a pact execution service. -- -- When transaction don't matter you can use 'fakePact' from this module. @@ -123,70 +114,69 @@ withTestCutDb -- service that can be given a transaction generator, that allows to -- create blocks with a well-defined set of test transactions. -- - -> LogFunction - -- ^ a logg function (use @\_ _ -> return ()@ turn of logging) - -> (forall tbl . CanReadablePayloadCas tbl => Casify RocksDbTable CutHashes -> CutDb tbl -> IO a) - -> IO a -withTestCutDb rdb v conf n pactIO logfun f = do - rocksDb <- testRocksDb "withTestCutDb" rdb - let payloadDb = newPayloadDb rocksDb - cutHashesDb = cutHashesTable rocksDb - initializePayloadDb v payloadDb - webDb <- initWebBlockHeaderDb rocksDb v - mgr <- HTTP.newManager HTTP.defaultManagerSettings - pact <- pactIO webDb payloadDb - withLocalWebBlockHeaderStore mgr webDb $ \headerStore -> - withLocalPayloadStore mgr payloadDb pact $ \payloadStore -> - withCutDb (conf $ defaultCutDbParams v cutFetchTimeout) logfun headerStore payloadStore cutHashesDb $ \cutDb -> do - foldM_ (\c _ -> view _1 <$> mine defaultMiner pact cutDb c) (genesisCut v) [1..n] - f cutHashesDb cutDb - --- | Adds the requested number of new blocks to the given 'CutDb'. --- --- It is assumed that the 'WebPactExecutionService' is synced with the 'CutDb'. --- This can be done by calling 'syncPact'. The 'WebPactExecutionService' that --- was used to generate the given CutDb is already synced. --- --- If the 'WebPactExecutionService' is not synced with the 'CutDb', this --- function will result in an exception @PactInternalError --- "InMemoryCheckpointer: Restore not found"@. --- -extendTestCutDb - :: CanReadablePayloadCas tbl - => CutDb tbl - -> WebPactExecutionService - -> Natural - -> S.Stream (S.Of (Cut, ChainId, PayloadWithOutputs)) IO () -extendTestCutDb cutDb pact n = S.scanM - (\(c, _, _) _ -> mine defaultMiner pact cutDb c) - (mine defaultMiner pact cutDb =<< _cut cutDb) - return - (S.each [0..n-1]) - --- | Synchronize the a 'WebPactExecutionService' with a 'CutDb' by replaying all --- transactions of the payloads of all blocks in the 'CutDb'. --- -syncPact - :: CanReadablePayloadCas tbl - => CutDb tbl - -> WebPactExecutionService - -> IO () -syncPact cutDb pact = - void $ webEntries bhdb $ \s -> s - & S.filter ((/= 0) . view blockHeight) - & S.mapM_ (\h -> payload h >>= _webPactValidateBlock pact h . CheckablePayload) - where - bhdb = view cutDbWebBlockHeaderDb cutDb - pdb = view cutDbPayloadDb cutDb - payload h = lookupPayloadWithHeight pdb (Just $ view blockHeight h) (view blockPayloadHash h) >>= \case - Nothing -> error $ "Corrupted database: failed to load payload data for block header " <> sshow h - Just p -> return $ payloadWithOutputsToPayloadData p + -> logger + -> ResourceT IO (Casify RocksDbTable CutHashes, CutDb logger) +withTestCutDb rdb conf n providers logger = do + rocksDb <- liftIO $ testRocksDb "withTestCutDb" rdb + let cutHashesDb = cutHashesTable rocksDb + webDb <- liftIO $ initWebBlockHeaderDb rocksDb + mgr <- liftIO $ HTTP.newManager HTTP.defaultManagerSettings + headerStore <- withLocalWebBlockHeaderStore logger mgr webDb + Right cutDb <- withCutDb (conf $ defaultCutDbParams cutFetchTimeout) logger headerStore providers cutHashesDb + liftIO $ synchronizeProviders webDb genesisCut + + liftIO $ logFunctionText logger Debug "GOING TO MINE AT THE START" + liftIO $ foldM_ (\c _ -> view _1 <$> mine logger cutDb c) genesisCut [1..n] + return (cutHashesDb, cutDb) + where + synchronizeProviders :: WebBlockHeaderDb -> Cut -> IO () + synchronizeProviders wbh c = do + let startHeaders = HM.union + (_cutHeaders c) + (imap (\cid () -> genesisBlockHeader cid) (HS.toMap chainIds)) + mapConcurrently_ syncOne startHeaders + where + syncOne hdr = forM_ (providers ^? atChain (_chainId hdr)) $ \case + ConfiguredPayloadProvider provider -> do + finfo <- forkInfoForHeader wbh hdr Nothing Nothing True + r <- syncToBlock provider Nothing finfo `catch` \(e :: SomeException) -> do + throwM e + unless (r == _forkInfoTargetState finfo) $ do + error "Chainweb.Test.CutDB.synchronizeProviders: unexpected result state" + logFunctionText logger Debug $ "payload provider synced, on chain: " <> toText (_chainId hdr) + -- FIXME + DisabledPayloadProvider -> do + logFunctionText logger Debug $ + "payload provider disabled, not synced, on chain: " <> toText (_chainId hdr) + + +-- -- | Adds the requested number of new blocks to the given 'CutDb'. +-- -- +-- -- It is assumed that the 'WebPactExecutionService' is synced with the 'CutDb'. +-- -- This can be done by calling 'syncPact'. The 'WebPactExecutionService' that +-- -- was used to generate the given CutDb is already synced. +-- -- +-- -- If the 'WebPactExecutionService' is not synced with the 'CutDb', this +-- -- function will result in an exception @PactInternalError +-- -- "InMemoryCheckpointer: Restore not found"@. +-- -- +-- extendTestCutDb +-- :: CanReadablePayloadCas tbl +-- => CutDb +-- -> WebPactExecutionService +-- -> Natural +-- -> S.Stream (S.Of (Cut, ChainId, PayloadWithOutputs)) IO () +-- extendTestCutDb cutDb pact n = S.scanM +-- (\(c, _, _) _ -> mine defaultMiner pact cutDb c) +-- (mine defaultMiner pact cutDb =<< _cut cutDb) +-- return +-- (S.each [0..n-1]) -- | Atomically await for a 'CutDb' instance to synchronize cuts according to some -- predicate for a given 'Cut' and the results of '_cutStm'. -- awaitCut - :: CutDb tbl + :: CutDb l -> (Cut -> Bool) -> IO Cut awaitCut cdb k = atomically $ do @@ -194,42 +184,42 @@ awaitCut cdb k = atomically $ do STM.check $ k c pure c --- | Extend the cut db until either a cut that meets some condition is --- encountered or the given number of cuts is mined. In the former case just the --- cut that fullfills the condition is returned. In the latter case 'Nothing' is --- returned. --- --- Note that the this function may skip over some cuts when waiting for a cut that satisfies the predicate. --- So, for instance, instead of checking for a particular cut height, one should --- check for a cut height that is larger or equal than the expected height. --- -extendAwait - :: CanReadablePayloadCas tbl - => CutDb tbl - -> WebPactExecutionService - -> Natural - -> (Cut -> Bool) - -> IO (Maybe Cut) -extendAwait cdb pact i p = race gen (awaitCut cdb p) >>= \case - Left _ -> return Nothing - Right c -> return (Just c) - where - gen = S.foldM_ checkCut (return 0) return - $ S.map (view (_1 . cutHeight)) - $ extendTestCutDb cdb pact i - - checkCut prev cur = do - unless (prev < cur) $ throwM $ InternalInvariantViolation $ unexpectedMsg - "New cut is not larger than the previous one. This is bug in Chainweb.Test.CutDB" - (Expected prev) - (Actual cur) - return cur +-- -- | Extend the cut db until either a cut that meets some condition is +-- -- encountered or the given number of cuts is mined. In the former case just the +-- -- cut that fullfills the condition is returned. In the latter case 'Nothing' is +-- -- returned. +-- -- +-- -- Note that the this function may skip over some cuts when waiting for a cut that satisfies the predicate. +-- -- So, for instance, instead of checking for a particular cut height, one should +-- -- check for a cut height that is larger or equal than the expected height. +-- -- +-- extendAwait +-- :: CanReadablePayloadCas tbl +-- => CutDb +-- -> WebPactExecutionService +-- -> Natural +-- -> (Cut -> Bool) +-- -> IO (Maybe Cut) +-- extendAwait cdb pact i p = race gen (awaitCut cdb p) >>= \case +-- Left _ -> return Nothing +-- Right c -> return (Just c) +-- where +-- gen = S.foldM_ checkCut (return 0) return +-- $ S.map (view (_1 . cutHeight)) +-- $ extendTestCutDb cdb pact i + +-- checkCut prev cur = do +-- unless (prev < cur) $ throwM $ InternalInvariantViolation $ unexpectedMsg +-- "New cut is not larger than the previous one. This is bug in Chainweb.Test.CutDB" +-- (Expected prev) +-- (Actual cur) +-- return cur -- | Wait for the cutdb to synchronize on a given blockheight for a given chain -- id -- awaitBlockHeight - :: CutDb tbl + :: CutDb l -> BlockHeight -> ChainId -> IO Cut @@ -244,116 +234,94 @@ awaitBlockHeight cdb bh cid = atomically $ do -- important. -- withTestCutDbWithoutPact - :: forall a - . HasCallStack + :: HasCallStack + => HasVersion + => Logger logger => RocksDb - -> ChainwebVersion -- ^ the chainweb version -> (CutDbParams -> CutDbParams) -- ^ any alterations to the CutDB's configuration -> Int -- ^ number of blocks in the chainweb in addition to the genesis blocks - -> LogFunction - -- ^ a logg function (use @\_ _ -> return ()@ turn of logging) - -> (forall tbl . CanReadablePayloadCas tbl => Casify RocksDbTable CutHashes -> CutDb tbl -> IO a) - -> IO a -withTestCutDbWithoutPact rdb v conf n = - withTestCutDb rdb v conf n (const $ const $ return fakePact) + -> logger + -> ResourceT IO (Casify RocksDbTable CutHashes, CutDb logger) +withTestCutDbWithoutPact rdb conf n = + withTestCutDb rdb conf n (onAllChains DisabledPayloadProvider) -- | A version of withTestCutDb that can be used as a Tasty TestTree resource. -- withTestPayloadResource - :: RocksDb - -> ChainwebVersion + :: HasVersion + => Logger logger + => RocksDb -> Int - -> LogFunction - -> ResourceT IO (CutDb RocksDbTable) -withTestPayloadResource rdb v n logfun - = view _3 . snd <$> allocate start stopTestPayload + -> logger + -> ResourceT IO (CutDb logger) +withTestPayloadResource rdb n logger + = view _2 . snd <$> allocate start stopTestPayload where - start = startTestPayload rdb v logfun n + start = startTestPayload rdb logger n -- -------------------------------------------------------------------------- -- -- Internal Utils for mocking up the backends startTestPayload - :: RocksDb - -> ChainwebVersion - -> LogFunction + :: HasVersion + => Logger logger + => RocksDb + -> logger -> Int - -> IO (Async (), Async (), CutDb RocksDbTable) -startTestPayload rdb v logfun n = do + -> IO (Async (), CutDb logger) +startTestPayload rdb logger n = do rocksDb <- testRocksDb "startTestPayload" rdb - let payloadDb = newPayloadDb rocksDb - cutHashesDb = cutHashesTable rocksDb - initializePayloadDb v payloadDb - webDb <- initWebBlockHeaderDb rocksDb v + let cutHashesDb = cutHashesTable rocksDb + webDb <- initWebBlockHeaderDb rocksDb mgr <- HTTP.newManager HTTP.defaultManagerSettings - (pserver, pstore) <- startLocalPayloadStore mgr payloadDb - (hserver, hstore) <- startLocalWebBlockHeaderStore mgr webDb - cutDb <- startCutDb (defaultCutDbParams v cutFetchTimeout) logfun hstore pstore cutHashesDb - foldM_ (\c _ -> view _1 <$> mine defaultMiner fakePact cutDb c) (genesisCut v) [0..n] - return (pserver, hserver, cutDb) - - -stopTestPayload :: (Async (), Async (), CutDb tbl) -> IO () -stopTestPayload (pserver, hserver, cutDb) = do + (hserver, hstore) <- startLocalWebBlockHeaderStore logger mgr webDb + let disabledPayloadProviders = onAllChains DisabledPayloadProvider + Right cutDb <- startCutDb (defaultCutDbParams cutFetchTimeout) logger hstore disabledPayloadProviders cutHashesDb + foldM_ (\c _ -> view _1 <$> mine logger cutDb c) genesisCut [0..n] + return (hserver, cutDb) + +stopTestPayload :: (Async (), CutDb logger) -> IO () +stopTestPayload (hserver, cutDb) = do stopCutDb cutDb cancel hserver - cancel pserver withLocalWebBlockHeaderStore - :: HTTP.Manager + :: Logger logger + => logger + -> HTTP.Manager -> WebBlockHeaderDb - -> (WebBlockHeaderStore -> IO a) - -> IO a -withLocalWebBlockHeaderStore mgr webDb inner = withNoopQueueServer $ \queue -> do - mem <- new - inner $ WebBlockHeaderStore webDb mem queue (\_ _ -> return ()) mgr + -> ResourceT IO (WebBlockHeaderStore logger) +withLocalWebBlockHeaderStore logger mgr webDb = do + queue <- withNoopQueueServer + mem <- liftIO new + return $ WebBlockHeaderStore webDb mem queue logger mgr startLocalWebBlockHeaderStore - :: HTTP.Manager + :: Logger logger + => logger + -> HTTP.Manager -> WebBlockHeaderDb - -> IO (Async (), WebBlockHeaderStore) -startLocalWebBlockHeaderStore mgr webDb = do - (server, queue) <- startNoopQueueServer - mem <- new - return (server, WebBlockHeaderStore webDb mem queue (\_ _ -> return ()) mgr) - -withLocalPayloadStore - :: HTTP.Manager - -> PayloadDb tbl - -> WebPactExecutionService - -> (WebBlockPayloadStore tbl -> IO a) - -> IO a -withLocalPayloadStore mgr payloadDb pact inner = withNoopQueueServer $ \queue -> do - mem <- new - inner $ WebBlockPayloadStore payloadDb mem queue (\_ _ -> return ()) mgr pact - -startLocalPayloadStore - :: HTTP.Manager - -> PayloadDb tbl - -> IO (Async (), WebBlockPayloadStore tbl) -startLocalPayloadStore mgr payloadDb = do + -> IO (Async (), WebBlockHeaderStore logger) +startLocalWebBlockHeaderStore logger mgr webDb = do (server, queue) <- startNoopQueueServer mem <- new - return $ (server, WebBlockPayloadStore payloadDb mem queue (\_ _ -> return ()) mgr fakePact) + return (server, WebBlockHeaderStore webDb mem queue logger mgr) -- | Build a linear chainweb (no forks, assuming single threaded use of the -- cutDb). No POW or poison delay is applied. Block times are real times. -- mine :: HasCallStack - => CanReadablePayloadCas tbl - => Miner - -- ^ The miner. For testing you may use 'defaultMiner'. - -> WebPactExecutionService - -- ^ only the new-block generator is used. For testing you may use - -- 'fakePact'. - -> CutDb tbl + => HasVersion + => Logger logger + => logger + -> CutDb logger -> Cut - -> IO (Cut, ChainId, PayloadWithOutputs) -mine miner pact cutDb c = do + -> IO (Cut, ChainId, NewPayload) +mine logger cutDb c = do -- Pick a chain that isn't blocked. With that mining is guaranteed to -- succeed if @@ -362,12 +330,15 @@ mine miner pact cutDb c = do -- - the chainweb is in a consistent state, -- - the pact execution service is synced with the cutdb, and -- - the transaction generator produces valid blocks. + logFunctionText logger Debug "going to mine" cid <- getRandomUnblockedChain c + logFunctionText logger Debug "got unblocked chain" - tryMineForChain miner pact cutDb c cid >>= \case + tryMineForChain cutDb c cid >>= \case Left _ -> throwM $ InternalInvariantViolation "Failed to create new cut. This is a bug in Chainweb.Test.CutDB or one of it's users" Right x -> do + logFunctionText logger Debug "awaiting cut with block" void $ awaitCut cutDb $ ((<=) `on` _cutHeight) (view _1 x) return x @@ -385,41 +356,38 @@ getRandomUnblockedChain c = do isUnblocked h = let bh = view blockHeight h cid = view blockChainId h - in all (>= bh) $ fmap (view blockHeight) $ toList $ cutAdjs c cid + in all ((>= bh) . view blockHeight) $ cutAdjs c cid -- | Build a linear chainweb (no forks). No POW or poison delay is applied. -- Block times are real times. -- tryMineForChain - :: forall tbl - . HasCallStack - => CanReadablePayloadCas tbl - => Miner + :: HasCallStack + => HasVersion -- ^ The miner. For testing you may use 'defaultMiner'. -- miner. - -> WebPactExecutionService - -- ^ only the new-block generator is used. For testing you may use - -- 'fakePact'. - -> CutDb tbl + => CutDb l -> Cut -> ChainId - -> IO (Either MineFailure (Cut, ChainId, PayloadWithOutputs)) -tryMineForChain miner webPact cutDb c cid = do - newBlock <- throwIfNoHistory =<< _webPactNewBlock webPact cid miner NewBlockFill parent - let outputs = newBlockToPayloadWithOutputs newBlock - let payloadHash = _payloadWithOutputsPayloadHash outputs + -> IO (Either MineFailure (Cut, ChainId, NewPayload)) +tryMineForChain cutDb c cid = do + newPayload <- case view cutDbPayloadProviders cutDb ^?! atChain cid of + ConfiguredPayloadProvider p -> latestPayloadIO p + DisabledPayloadProvider -> error "missing payload provider, cannot mine for chain" + let payloadHash = _newPayloadBlockPayloadHash newPayload t <- getCurrentTimeIntegral x <- testMineWithPayloadHash wdb (Nonce 0) t payloadHash cid c case x of Right (T2 h c') -> do addCutHashes cutDb (cutToCutHashes Nothing c') - { _cutHashesHeaders = HM.singleton (view blockHash h) h - , _cutHashesPayloads = HM.singleton (view blockPayloadHash h) (payloadWithOutputsToPayloadData outputs) + { _cutHashesHeaders = + HM.singleton (view blockHash h) h + , _cutHashesPayloads = + HM.singleton (view blockPayloadHash h) (fromJuste $ _newPayloadEncodedPayloadData newPayload) } - return $ Right (c', cid, outputs) + return $ Right (c', cid, newPayload) Left e -> return $ Left e where - parent = ParentHeader $ c ^?! ixg cid -- parent to mine on wdb = view cutDbWebBlockHeaderDb cutDb -- | picks a random block header from a web chain. The result header is @@ -429,11 +397,12 @@ tryMineForChain miner webPact cutDb c cid = do -- randomBlockHeader :: HasCallStack - => CutDb tbl + => HasVersion + => CutDb l -> IO BlockHeader randomBlockHeader cutDb = do curCut <- _cut cutDb - allBlockHeaders <- webEntries (view cutDbWebBlockHeaderDb cutDb) $ \s -> s + allBlockHeaders <- webEntries (view cutDbWebBlockHeaderDb cutDb) Nothing Nothing $ \s -> s & S.filter (checkHeight curCut) & S.toList_ generate $ elements allBlockHeaders @@ -446,10 +415,12 @@ randomBlockHeader cutDb = do -- randomTransaction :: HasCallStack + => HasVersion => CanReadablePayloadCas tbl - => CutDb tbl + => PayloadDb tbl + -> CutDb l -> IO (BlockHeader, Int, Transaction, TransactionOutput) -randomTransaction cutDb = do +randomTransaction payloadDb cutDb = do bh <- randomBlockHeader cutDb Just pd <- lookupPayloadDataWithHeight payloadDb (Just $ view blockHeight bh) (view blockPayloadHash bh) let pay = BlockPayload @@ -473,8 +444,6 @@ randomTransaction cutDb = do , _blockTransactions btxs V.! txIx , _blockOutputs outs V.! txIx ) - where - payloadDb = view cutDbPayloadDb cutDb -- | FAKE pact execution service. -- @@ -483,34 +452,34 @@ randomTransaction cutDb = do -- * The generated outputs are just the transaction bytes themself. -- * The coinbase is 'noCoinbase' -- -fakePact :: WebPactExecutionService -fakePact = WebPactExecutionService $ PactExecutionService - { _pactValidateBlock = - \_ p -> do - let d = checkablePayloadToPayloadData p - return - $ payloadWithOutputs d coinbase - $ getFakeOutput <$> view payloadDataTransactions d - , _pactNewBlock = \_ _ _ ph -> do - payloadDat <- generate $ V.fromList . getNonEmpty <$> arbitrary - return $ Historical - $ NewBlockPayload ph - $ newPayloadWithOutputs fakeMiner coinbase - $ (\x -> (x, getFakeOutput x)) <$> payloadDat - , _pactContinueBlock = \_ -> error "Unimplemented" - - , _pactLocal = \_t -> error "Unimplemented" - , _pactLookup = \_ _ -> error "Unimplemented" - , _pactPreInsertCheck = \_ _ -> error "Unimplemented" - , _pactBlockTxHistory = \_ _ -> error "Unimplemented" - , _pactHistoricalLookup = \_ _ _ -> error "Unimplemented" - , _pactSyncToBlock = \_ -> error "Unimplemented" - , _pactReadOnlyReplay = \_ _ -> error "Unimplemented" - } - where - getFakeOutput (Transaction txBytes) = TransactionOutput txBytes - coinbase = noCoinbaseOutput - fakeMiner = MinerData "fakeMiner" +-- fakePact :: WebPactExecutionService +-- fakePact = WebPactExecutionService $ PactExecutionService +-- { _pactValidateBlock = +-- \_ p -> do +-- let d = checkablePayloadToPayloadData p +-- return +-- $ payloadWithOutputs d coinbase +-- $ getFakeOutput <$> view payloadDataTransactions d +-- , _pactNewBlock = \_ _ _ ph -> do +-- payloadDat <- generate $ V.fromList . getNonEmpty <$> arbitrary +-- return $ Historical +-- $ NewBlockPayload ph +-- $ newPayloadWithOutputs fakeMiner coinbase +-- $ (\x -> (x, getFakeOutput x)) <$> payloadDat +-- , _pactContinueBlock = \_ -> error "Unimplemented" + +-- , _pactLocal = \_t -> error "Unimplemented" +-- , _pactLookup = \_ _ -> error "Unimplemented" +-- , _pactPreInsertCheck = \_ _ -> error "Unimplemented" +-- , _pactBlockTxHistory = \_ _ -> error "Unimplemented" +-- , _pactHistoricalLookup = \_ _ _ -> error "Unimplemented" +-- , _pactSyncToBlock = \_ -> error "Unimplemented" +-- , _pactReadOnlyReplay = \_ _ -> error "Unimplemented" +-- } +-- where +-- getFakeOutput (Transaction txBytes) = TransactionOutput txBytes +-- coinbase = noCoinbaseOutput +-- fakeMiner = MinerData "fakeMiner" tests :: RocksDb -> TestTree tests rdb = testGroup "CutDB" @@ -519,39 +488,66 @@ tests rdb = testGroup "CutDB" ] testCutPruning :: RocksDb -> TestTree -testCutPruning rdb = testCase "cut pruning" $ do +testCutPruning rdb = testCase "cut pruning" $ runResourceT $ withVersion (barebonesTestVersion pairChainGraph) $ do -- initialize cut DB and mine enough to trigger pruning - let v = barebonesTestVersion pairChainGraph - withTestCutDbWithoutPact rdb v alterPruningSettings - (int $ avgCutHeightAt v minedBlockHeight) - (\_ _ -> return ()) - $ \cutHashesStore _ -> do - -- peek inside the cut DB's store to find the oldest and newest cuts - let table = unCasify cutHashesStore - Just (leastCutHeight, _, _) <- tableMinKey table - Just (mostCutHeight, _, _) <- tableMaxKey table - let fuzz = 10 :: Integer - -- we must have pruned the older cuts - assertBool "oldest cuts are too old" $ - round (avgBlockHeightAtCutHeight v leastCutHeight) >= fuzz - -- we must keep the latest cut - assertBool "newest cut is too old" $ - round (avgBlockHeightAtCutHeight v mostCutHeight) >= int minedBlockHeight - fuzz + testLogger <- liftIO getTestLogger + tmp <- withTempDir "donotuse" + sched <- withScheduler (\_ _ -> return ()) 2 + pps <- tabulateChainsM $ \cid -> view providerResPayloadProvider <$> withPayloadProviderResources + sched + testLogger + cid + defaultServiceApiConfig + Nothing + rdb + (RewindLimit 10) + False + tmp + defaultPayloadProviderConfig + (cutHashesStore, _) <- withTestCutDb rdb alterPruningSettings + (int $ avgCutHeightAt minedBlockHeight) + pps + testLogger + liftIO $ do + -- peek inside the cut DB's store to find the oldest and newest cuts + let table = unCasify cutHashesStore + Just (leastCutHeight, _, _) <- tableMinKey table + Just (mostCutHeight, _, _) <- tableMaxKey table + let fuzz = 10 :: Integer + -- we must have pruned the older cuts + assertBool "oldest cuts are too old" $ + round (avgBlockHeightAtCutHeight leastCutHeight) >= fuzz + -- we must keep the latest cut + assertBool "newest cut is too old" $ + round (avgBlockHeightAtCutHeight mostCutHeight) >= int minedBlockHeight - fuzz where alterPruningSettings = - set cutDbParamsAvgBlockHeightPruningDepth 50 . - set cutDbParamsPruningFrequency 1 + set cutDbParamsAvgBlockHeightPruningDepth 50 minedBlockHeight = 300 testCutGet :: RocksDb -> TestTree -testCutGet rdb = testCase "cut get" $ do - let v = barebonesTestVersion pairChainGraph +testCutGet rdb = testCase "cut get" $ withVersion (barebonesTestVersion pairChainGraph) $ runResourceT $ do let bh = BlockHeight 300 - let ch = avgCutHeightAt v bh + let ch = avgCutHeightAt bh let halfCh = ch `div` 2 - - withTestCutDbWithoutPact rdb v id (2 * int ch) (\_ _ -> return ()) $ \_ cutDb -> do - curHeight <- _cutHeight <$> _cut cutDb - assertGe "cut height is large enough" (Actual curHeight) (Expected $ 2 * int ch) - retCut <- cutGetHandler cutDb (Just $ MaxRank (Max $ int halfCh)) - assertLe "cut hashes are too high" (Actual (_cutHashesHeight retCut)) (Expected halfCh) + tmp <- withTempDir "donotuse" + testLogger <- liftIO getTestLogger + sched <- withScheduler (\_ _ -> return ()) 2 + + pps <- tabulateChainsM $ \cid -> view providerResPayloadProvider <$> withPayloadProviderResources + sched + (genericLogger Error (\_ -> return ())) + cid + defaultServiceApiConfig + Nothing + rdb + (RewindLimit 10) + False + tmp + defaultPayloadProviderConfig + (_, cutDb) <- withTestCutDb rdb id (2 * int ch) pps testLogger + liftIO $ do + curHeight <- _cutHeight <$> _cut cutDb + assertGe "cut height is large enough" (Actual curHeight) (Expected $ 2 * int ch) + retCut <- cutGetHandler cutDb (Just $ MaxRank (Max $ int halfCh)) + assertLe "cut hashes are too high" (Actual (_cutHashesHeight retCut)) (Expected halfCh) diff --git a/test/unit/Chainweb/Test/Mempool.hs b/test/unit/Chainweb/Test/Mempool.hs index bc2b06929d..ce078b880a 100644 --- a/test/unit/Chainweb/Test/Mempool.hs +++ b/test/unit/Chainweb/Test/Mempool.hs @@ -1,5 +1,6 @@ {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ImportQualifiedPost #-} {-# LANGUAGE NumericUnderscores #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} @@ -29,13 +30,13 @@ import Control.Monad.Trans.Except import Data.Bifunctor (bimap) import Data.Decimal (Decimal, DecimalRaw(..)) import Data.Function (on) -import qualified Data.HashSet as HashSet +import Data.HashSet qualified as HashSet import Data.IORef import Data.List (sort, sortBy) -import qualified Data.List.Ordered as OL +import Data.List.Ordered qualified as OL import Data.Ord (Down(..)) import Data.Vector (Vector) -import qualified Data.Vector as V +import Data.Vector qualified as V import GHC.Stack import Prelude hiding (lookup) import System.Timeout (timeout) @@ -44,16 +45,17 @@ import Test.QuickCheck.Monadic import Test.Tasty import Test.Tasty.HUnit import Test.Tasty.QuickCheck hiding ((.&.)) - --- internal modules - -import Pact.Parse (ParsedDecimal(..)) - +import Pact.Core.Gas.Types import Chainweb.BlockHash -import Chainweb.Mempool.Mempool +import Chainweb.Pact.Mempool.Mempool import Chainweb.Test.Utils -import qualified Chainweb.Time as Time +import Chainweb.Time qualified as Time +import Chainweb.BlockCreationTime +import Chainweb.MinerReward +import Chainweb.Parent +import Chainweb.PayloadProvider import Chainweb.Utils (T2(..)) +import Control.Lens (view) ------------------------------------------------------------------------------ -- | Several operations (reintroduce, validate, confirm) can only be performed @@ -116,13 +118,13 @@ arbitraryDecimal = do return $! Decimal places mantissa arbitraryGasPrice :: Gen GasPrice -arbitraryGasPrice = GasPrice . ParsedDecimal . abs <$> arbitraryDecimal +arbitraryGasPrice = GasPrice . abs <$> arbitraryDecimal instance Arbitrary MockTx where arbitrary = MockTx <$> chooseAny <*> arbitraryGasPrice - <*> pure (mockBlockGasLimit `div` 50_000) + <*> pure (GasLimit $ Gas $ view (_GasLimit . _Gas) mockBlockGasLimit `div` 50_000) <*> pure emptyMeta where emptyMeta = TransactionMetadata zero Time.maxTime @@ -187,7 +189,7 @@ propOverlarge (txs, overlarge0) _ mempool = runExceptT $ do insert v = mempoolInsert mempool CheckedInsert $ V.fromList v lookup = mempoolLookup mempool . V.fromList . map hash overlarge = setOverlarge overlarge0 - setOverlarge = map (\x -> x { mockGasLimit = mockBlockGasLimit + 100 }) + setOverlarge = map (\x -> x { mockGasLimit = GasLimit $ Gas $ view (_GasLimit . _Gas) mockBlockGasLimit + 100 }) propBadlistPreblock :: ([MockTx], [MockTx]) @@ -202,7 +204,8 @@ propBadlistPreblock (txs, badTxs) _ mempool = runExceptT $ do liftIO (lookup badTxs) >>= V.mapM_ lookupIsPending -- once we call mempoolGetBlock, the bad txs should be badlisted - liftIO $ void $ mempoolGetBlock mempool mockBlockFill preblockCheck 1 nullBlockHash + liftIO $ void $ mempoolGetBlock mempool mockBlockFill preblockCheck + (EvaluationCtx (Parent $ BlockCreationTime Time.epoch) (Parent nullBlockHash) (Parent 1) 0 (MinerReward 0) ()) liftIO (lookup txs) >>= V.mapM_ lookupIsPending liftIO (lookup badTxs) >>= V.mapM_ lookupIsMissing liftIO $ insert badTxs @@ -211,7 +214,7 @@ propBadlistPreblock (txs, badTxs) _ mempool = runExceptT $ do where badHashes = HashSet.fromList $ map hash badTxs - preblockCheck _ _ ts = return $ + preblockCheck _ ts = return $ V.map (\tx -> if hash tx `HashSet.member` badHashes then Left InsertErrorBadlisted else Right tx) ts @@ -246,7 +249,8 @@ propAddToBadList tx _ mempool = runExceptT $ do insert v = mempoolInsert mempool CheckedInsert $ V.fromList v lookup = mempoolLookup mempool . V.fromList . map hash getBlock = liftIO - $ V.toList <$> mempoolGetBlock mempool mockBlockFill noopMempoolPreBlockCheck 1 nullBlockHash + $ V.toList <$> mempoolGetBlock mempool mockBlockFill noopMempoolPreBlockCheck + (EvaluationCtx (Parent $ BlockCreationTime Time.epoch) (Parent nullBlockHash) (Parent 1) 0 (MinerReward 0) ()) -- TODO Does this need to be updated? propPreInsert @@ -303,7 +307,8 @@ propTrivial txs _ mempool = runExceptT $ do insert v = mempoolInsert mempool CheckedInsert $ V.fromList v lookup = mempoolLookup mempool . V.fromList . map hash - getBlock = mempoolGetBlock mempool mockBlockFill noopMempoolPreBlockCheck 0 nullBlockHash + getBlock = mempoolGetBlock mempool mockBlockFill noopMempoolPreBlockCheck + (EvaluationCtx (Parent $ BlockCreationTime Time.epoch) (Parent nullBlockHash) (Parent 0) 0 (MinerReward 0) ()) onFees x = (Down (mockGasPrice x)) diff --git a/test/unit/Chainweb/Test/Mempool/Consensus.hs b/test/unit/Chainweb/Test/Mempool/Consensus.hs index d78c5e6767..0080dc91b0 100644 --- a/test/unit/Chainweb/Test/Mempool/Consensus.hs +++ b/test/unit/Chainweb/Test/Mempool/Consensus.hs @@ -44,10 +44,10 @@ import Chainweb.BlockWeight import Chainweb.ChainId import Chainweb.Crypto.MerkleLog hiding (header) import Chainweb.Difficulty (targetToDifficulty) -import Chainweb.Mempool.Consensus -import Chainweb.Mempool.Mempool +-- import Chainweb.Pact.Mempool.Consensus +import Chainweb.Pact.Mempool.Mempool import Chainweb.MerkleUniverse -import Chainweb.Payload +import Chainweb.Pact.Payload import Chainweb.Test.Orphans.Time () import Chainweb.Test.Utils import Chainweb.Test.Utils.BlockHeader @@ -59,7 +59,7 @@ import Chainweb.Storage.Table.RocksDB import Data.LogMessage ---------------------------------------------------------------------------------------------------- -tests :: BlockHeaderDb -> BlockHeader -> TestTree +tests :: HasVersion => BlockHeaderDb -> BlockHeader -> TestTree tests db h0 = testGroup "mempool-consensus-quickcheck-tests" [ testProperty "valid-transactions-source" (prop_validTxSource db h0) , testProperty "no-orphaned-txs" (prop_noOrphanedTxs db h0) @@ -70,7 +70,8 @@ tests db h0 = testGroup "mempool-consensus-quickcheck-tests" -- | Property: All transactions returned by processFork (for re-introduction to the mempool) come from -- the old fork and are not represented in the new fork blocks prop_validTxSource - :: BlockHeaderDb + :: HasVersion + => BlockHeaderDb -> BlockHeader -> Property prop_validTxSource db genBlock = monadicIO $ do @@ -107,7 +108,8 @@ splitHsAt n x = -- marked available to re-entry into the mempool) (i.e., should be found in the Vector returned by -- processFork) prop_noOrphanedTxs - :: BlockHeaderDb + :: HasVersion + => BlockHeaderDb -> BlockHeader -> Property prop_noOrphanedTxs db genBlock = monadicIO $ do @@ -126,7 +128,8 @@ prop_noOrphanedTxs db genBlock = monadicIO $ do ---------------------------------------------------------------------------------------------------- -- Tests filtering within processFork'. prop_noOldCrap - :: BlockHeaderDb + :: HasVersion + => BlockHeaderDb -> BlockHeader -> Property prop_noOldCrap db genBlock = monadicIO $ do @@ -195,7 +198,8 @@ getTransPool = ---------------------------------------------------------------------------------------------------- -- | Generate a tree containing a fork genFork - :: BlockHeaderDb + :: HasVersion + => BlockHeaderDb -> IORef (HashMap BlockHeader (HashSet TransactionHash)) -> BlockHeader -> PropertyM IO ForkInfo @@ -225,7 +229,8 @@ takeTrans txs = do ---------------------------------------------------------------------------------------------------- genTree - :: BlockHeaderDb + :: HasVersion + => BlockHeaderDb -> IORef (HashMap BlockHeader (HashSet TransactionHash)) -> BlockHeader -> HashSet TransactionHash @@ -258,7 +263,8 @@ newNode mapRef blockTrans children = do ---------------------------------------------------------------------------------------------------- preForkTrunk - :: BlockHeaderDb + :: HasVersion + => BlockHeaderDb -> IORef (HashMap BlockHeader (HashSet TransactionHash)) -> BlockHeader -> HashSet TransactionHash @@ -286,7 +292,8 @@ frequencyM xs = do ---------------------------------------------------------------------------------------------------- fork - :: BlockHeaderDb + :: HasVersion + => BlockHeaderDb -> IORef (HashMap BlockHeader (HashSet TransactionHash)) -> BlockHeader -> HashSet TransactionHash @@ -316,7 +323,8 @@ genForkLengths = do ---------------------------------------------------------------------------------------------------- postForkTrunk - :: BlockHeaderDb + :: HasVersion + => BlockHeaderDb -> IORef (HashMap BlockHeader (HashSet TransactionHash)) -> BlockHeader -> HashSet TransactionHash @@ -339,7 +347,7 @@ postForkTrunk db mapRef h avail count = do -- TODO: does this test really has to go that low-level? Let try to refactor it use -- existing functionlity for creating a test block chain. -- -header' :: BlockHeader -> PropertyM IO BlockHeader +header' :: HasVersion => BlockHeader -> PropertyM IO BlockHeader header' h = do nonce <- Nonce <$> pick chooseAny return @@ -353,14 +361,13 @@ header' h = do :+: _chainId h :+: BlockWeight (targetToDifficulty target) + view blockWeight h :+: succ (view blockHeight h) - :+: _versionCode v + :+: _versionCode implicitVersion :+: epochStart (ParentHeader h) mempty t' :+: nonce :+: MerkleLogBody mempty where BlockCreationTime t = view blockCreationTime h target = powTarget (ParentHeader h) mempty t' - v = _chainwebVersion h t' = BlockCreationTime (scaleTimeSpan (10 :: Int) second `add` t) ---------------------------------------------------------------------------------------------------- @@ -465,6 +472,6 @@ _runGhci = withTempRocksDb "mempool-consensus-test" $ \rdb -> runResourceT $ do (h0, db) <- withToyDB rdb toyChainId - liftIO $ quickCheck (prop_validTxSource db h0) - liftIO $ quickCheck (prop_noOrphanedTxs db h0) + liftIO $ quickCheck (withVersion toyVersion $ prop_validTxSource db h0) + liftIO $ quickCheck (withVersion toyVersion $ prop_noOrphanedTxs db h0) return () diff --git a/test/unit/Chainweb/Test/Mempool/InMem.hs b/test/unit/Chainweb/Test/Mempool/InMem.hs index f1ebc2ac57..04cd68c212 100644 --- a/test/unit/Chainweb/Test/Mempool/InMem.hs +++ b/test/unit/Chainweb/Test/Mempool/InMem.hs @@ -7,9 +7,9 @@ import Control.Concurrent.MVar import qualified Data.Vector as V import Test.Tasty ------------------------------------------------------------------------------ -import qualified Chainweb.Mempool.InMem as InMem -import Chainweb.Mempool.InMemTypes (InMemConfig(..)) -import Chainweb.Mempool.Mempool +import qualified Chainweb.Pact.Mempool.InMem as InMem +import Chainweb.Pact.Mempool.InMemTypes (InMemConfig(..)) +import Chainweb.Pact.Mempool.Mempool import Chainweb.Test.Mempool (InsertCheck, MempoolWithFunc(..)) import qualified Chainweb.Test.Mempool import Chainweb.Utils (Codec(..)) @@ -23,7 +23,7 @@ tests = testGroup "Chainweb.Test.Mempool" wf :: (InsertCheck -> MempoolBackend MockTx -> IO a) -> IO a wf f = do mv <- newMVar (pure . V.map Right) - let cfg = InMemConfig txcfg mockBlockGasLimit 0 2048 Right (checkMv mv) (1024 * 10) + let cfg = InMemConfig txcfg mockBlockGasLimit (GasPrice 0) 2048 Right (checkMv mv) (1024 * 10) mp <- InMem.startInMemoryMempoolTest cfg f mv mp diff --git a/test/unit/Chainweb/Test/Mempool/RestAPI.hs b/test/unit/Chainweb/Test/Mempool/RestAPI.hs index 51ad9e6df2..32b05a8b22 100644 --- a/test/unit/Chainweb/Test/Mempool/RestAPI.hs +++ b/test/unit/Chainweb/Test/Mempool/RestAPI.hs @@ -1,44 +1,39 @@ +{-# LANGUAGE NumericUnderscores #-} +{-# LANGUAGE ImportQualifiedPost #-} + module Chainweb.Test.Mempool.RestAPI (tests) where import Control.Concurrent -import Control.Concurrent.STM -import Control.Exception - -import qualified Data.Pool as Pool -import qualified Data.Vector as V - -import qualified Network.HTTP.Client as HTTP +import Control.Monad.IO.Class +import Control.Monad.Trans.Resource +import Data.Pool qualified as Pool +import Data.Vector qualified as V +import Network.HTTP.Client qualified as HTTP import Network.Wai (Application) - import Servant.Client (BaseUrl(..), ClientEnv, Scheme(..), mkClientEnv) - import Test.Tasty - --- internal modules - import Chainweb.Chainweb.Configuration import Chainweb.Graph -import qualified Chainweb.Mempool.InMem as InMem -import Chainweb.Mempool.InMemTypes (InMemConfig(..)) -import Chainweb.Mempool.Mempool -import qualified Chainweb.Mempool.RestAPI.Client as MClient +import Chainweb.Pact.Mempool.InMem qualified as InMem +import Chainweb.Pact.Mempool.InMemTypes (InMemConfig(..)) +import Chainweb.Pact.Mempool.Mempool +import Chainweb.Pact.Mempool.RestAPI.Client qualified as MClient import Chainweb.RestAPI import Chainweb.Test.Mempool (InsertCheck, MempoolWithFunc(..)) -import qualified Chainweb.Test.Mempool -import Chainweb.Test.Utils (withTestAppServer) +import Chainweb.Test.Mempool qualified import Chainweb.Test.TestVersions -import Chainweb.Utils (Codec(..)) +import Chainweb.Test.Utils (withTestAppServer) +import Chainweb.Utils (Codec(..), withAsyncR, resourceToBracket) import Chainweb.Version import Chainweb.Version.Utils - -import Chainweb.Storage.Table.RocksDB - +import Control.Monad import Network.X509.SelfSigned ------------------------------------------------------------------------------ + tests :: TestTree tests = withResource newPool Pool.destroyAllResources $ - \poolIO -> testGroup "Chainweb.Mempool.RestAPI" + \poolIO -> testGroup "Chainweb.Pact.Mempool.RestAPI" $ Chainweb.Test.Mempool.remoteTests $ MempoolWithFunc $ withRemoteMempool poolIO @@ -47,33 +42,35 @@ data TestServer = TestServer { _tsRemoteMempool :: !(MempoolBackend MockTx) , _tsLocalMempool :: !(MempoolBackend MockTx) , _tsInsertCheck :: InsertCheck - , _tsServerThread :: !ThreadId } -newTestServer :: IO TestServer -newTestServer = mask_ $ do - checkMv <- newMVar (pure . V.map Right) - let inMemCfg = InMemConfig txcfg mockBlockGasLimit 0 2048 Right (checkMvFunc checkMv) (1024 * 10) - inmemMv <- newEmptyMVar - envMv <- newEmptyMVar - tid <- forkIOWithUnmask $ \u -> server inMemCfg inmemMv envMv u - inmem <- takeMVar inmemMv - env <- takeMVar envMv - let remoteMp0 = MClient.toMempool version chain txcfg env +newTestServer :: ResourceT IO TestServer +newTestServer = withVersion version $ do + let chain = someChainId + checkMv <- liftIO $ newMVar (pure . V.map Right) + let inMemCfg = InMemConfig txcfg mockBlockGasLimit (GasPrice 0) 2048 Right (checkMvFunc checkMv) (1024 * 10) + inmemMv <- liftIO newEmptyMVar + envMv <- liftIO newEmptyMVar + _ <- withAsyncR $ server chain inMemCfg inmemMv envMv + inmem <- liftIO $ takeMVar inmemMv + env <- liftIO $ takeMVar envMv + let remoteMp0 = MClient.toMempool chain txcfg env -- allow remoteMp to call the local mempool's getBlock (for testing) let remoteMp = remoteMp0 { mempoolGetBlock = mempoolGetBlock inmem } - return $! TestServer remoteMp inmem checkMv tid + return $! TestServer remoteMp inmem checkMv where checkMvFunc mv xs = do f <- readMVar mv f xs - server inMemCfg inmemMv envMv restore = do + server chain inMemCfg inmemMv envMv = withVersion version $ do inmem <- InMem.startInMemoryMempoolTest inMemCfg putMVar inmemMv inmem - restore $ withTestAppServer True (return $! mkApp inmem) mkEnv $ \env -> do - putMVar envMv env - atomically retry + runResourceT $ do + port <- withTestAppServer True (mkApp chain inmem) + env <- liftIO $ mkEnv port + liftIO $ putMVar envMv env + liftIO $ forever $ threadDelay 10_000_000 version :: ChainwebVersion version = barebonesTestVersion singletonChainGraph @@ -81,11 +78,8 @@ newTestServer = mask_ $ do host :: String host = "127.0.0.1" - chain :: ChainId - chain = someChainId version - - mkApp :: MempoolBackend MockTx -> Application - mkApp mp = chainwebApplication conf (serverMempools [(chain, mp)]) + mkApp :: ChainId -> MempoolBackend MockTx -> Application + mkApp chain mp = withVersion version $ chainwebApplication conf (serverMempools (onChain chain mp)) conf = defaultChainwebConfiguration version @@ -95,32 +89,31 @@ newTestServer = mask_ $ do mgr <- HTTP.newManager mgrSettings return $! mkClientEnv mgr $ BaseUrl Https host port "" -destroyTestServer :: TestServer -> IO () -destroyTestServer = killThread . _tsServerThread - -newPool :: IO (Pool.Pool TestServer) +newPool :: IO (Pool.Pool (TestServer, InternalState)) newPool = Pool.newPool $ Pool.defaultPoolConfig - newTestServer - destroyTestServer + create + destroy 10 {- ttl seconds -} 20 {- max entries -} + where + (create, destroy) = resourceToBracket newTestServer ------------------------------------------------------------------------------ serverMempools - :: [(ChainId, MempoolBackend t)] - -> ChainwebServerDbs t RocksDbTable {- ununsed -} + :: ChainMap (MempoolBackend t) + -> ChainwebServerDbs l t serverMempools mempools = emptyChainwebServerDbs { _chainwebServerMempools = mempools } withRemoteMempool - :: IO (Pool.Pool TestServer) + :: IO (Pool.Pool (TestServer, InternalState)) -> (InsertCheck -> MempoolBackend MockTx -> IO a) -> IO a withRemoteMempool poolIO userFunc = do pool <- poolIO - Pool.withResource pool $ \ts -> do + Pool.withResource pool $ \(ts, _) -> do mempoolClear $ _tsLocalMempool ts userFunc (_tsInsertCheck ts) (_tsRemoteMempool ts) diff --git a/test/unit/Chainweb/Test/Mempool/Sync.hs b/test/unit/Chainweb/Test/Mempool/Sync.hs index e6ccc27761..2a9f1ea1a5 100644 --- a/test/unit/Chainweb/Test/Mempool/Sync.hs +++ b/test/unit/Chainweb/Test/Mempool/Sync.hs @@ -20,9 +20,9 @@ import Test.QuickCheck hiding ((.&.)) import Test.QuickCheck.Monadic import Test.Tasty ------------------------------------------------------------------------------ -import Chainweb.Mempool.InMem -import Chainweb.Mempool.InMemTypes -import Chainweb.Mempool.Mempool +import Chainweb.Pact.Mempool.InMem +import Chainweb.Pact.Mempool.InMemTypes +import Chainweb.Pact.Mempool.Mempool import Chainweb.Test.Mempool (InsertCheck, MempoolWithFunc(..), lookupIsPending, mempoolProperty) import Chainweb.Utils (Codec(..)) @@ -30,14 +30,14 @@ import Chainweb.Utils (Codec(..)) tests :: TestTree -tests = testGroup "Chainweb.Mempool.sync" +tests = testGroup "Chainweb.Pact.Mempool.sync" [ mempoolProperty "Mempool.syncMempools" gen propSync $ MempoolWithFunc wf ] where wf :: (InsertCheck -> MempoolBackend MockTx -> IO a) -> IO a wf f = do mv <- newMVar (pure . V.map Right) - let cfg = InMemConfig txcfg mockBlockGasLimit 0 2048 Right (checkMv mv) (1024 * 10) + let cfg = InMemConfig txcfg mockBlockGasLimit (GasPrice 0) 2048 Right (checkMv mv) (1024 * 10) f mv =<< startInMemoryMempoolTest cfg checkMv :: MVar (t -> IO b) -> t -> IO b @@ -65,7 +65,7 @@ txcfg = TransactionConfig mockCodec hasher hashmeta mockGasPrice testInMemCfg :: InMemConfig MockTx testInMemCfg = - InMemConfig txcfg mockBlockGasLimit 0 2048 Right (pure . V.map Right) (1024 * 10) + InMemConfig txcfg mockBlockGasLimit (GasPrice 0) 2048 Right (pure . V.map Right) (1024 * 10) propSync :: (Set MockTx, Set MockTx , Set MockTx) diff --git a/test/unit/Chainweb/Test/MinerReward.hs b/test/unit/Chainweb/Test/MinerReward.hs index b69d999637..a40f73b078 100644 --- a/test/unit/Chainweb/Test/MinerReward.hs +++ b/test/unit/Chainweb/Test/MinerReward.hs @@ -74,41 +74,43 @@ prop_stuToKdaToStu :: Stu -> Property prop_stuToKdaToStu stu = kdaToStu (stuToKda stu) === stu prop_blockMinerRewardLegacyCompat :: BlockHeight -> Property -prop_blockMinerRewardLegacyCompat h - | h < maxRewardHeight - 2 = - legacyBlockMinerReward v h === minerRewardKda (blockMinerReward v h) - | h == maxRewardHeight - 1 = - legacyBlockMinerReward v h =/= minerRewardKda (blockMinerReward v h) - | h == maxRewardHeight = - legacyBlockMinerReward v h === minerRewardKda (blockMinerReward v h) - | otherwise = expectFailure - -- legacyMinerRewards is expected to throw an exception - $ legacyBlockMinerReward v h === minerRewardKda (blockMinerReward v h) +prop_blockMinerRewardLegacyCompat h = withVersion mainnet go + where + go :: HasVersion => Property + go + | h < maxRewardHeight - 2 = + legacyBlockMinerReward h === minerRewardKda (blockMinerReward h) + | h == maxRewardHeight - 1 = + legacyBlockMinerReward h =/= minerRewardKda (blockMinerReward h) + | h == maxRewardHeight = + legacyBlockMinerReward h === minerRewardKda (blockMinerReward h) + | otherwise = expectFailure + -- legacyMinerRewards is expected to throw an exception + $ legacyBlockMinerReward h === minerRewardKda (blockMinerReward h) - where - v = Mainnet01 -- 2.304523 -- test_finalMinerReward :: Assertion -test_finalMinerReward = do +test_finalMinerReward = withVersion mainnet $ do mapM_ rewardIsZero $ take 100 [maxRewardHeight..] mapM_ rewardIsZero $ take 10 [maxRewardHeight, (maxRewardHeight + 1000)..] where + rewardIsZero :: HasVersion => BlockHeight -> Assertion rewardIsZero h = assertEqual "The final miner reward is 0" (Kda 0) - (minerRewardKda (blockMinerReward Mainnet01 h)) + (minerRewardKda (blockMinerReward h)) test_minerRewardsMax :: Assertion test_minerRewardsMax = assertBool - "maximum miner reward is smaller than 1e12 * 24" - (_stu (maximum minerRewards) < 1e12 * 24) + "maximum miner reward is smaller than 1e9 * 24" + (_gstu (maximum minerRewards) < 1e9 * 24) test_minerRewardsFitWord64 :: Assertion test_minerRewardsFitWord64 = assertBool "maximum miner reward fits into Word64" - (_stu (maximum minerRewards) <= fromIntegral (maxBound @Word64)) + (_gstu (maximum minerRewards) <= fromIntegral (maxBound @Word64)) test_expectedMinerRewardsHash :: Assertion test_expectedMinerRewardsHash = assertEqual @@ -131,7 +133,7 @@ test_expectedRawMinerRewardsHash = assertEqual -- - block heights strictly larger than 125538057 -- test_blockMinerRewardLegacyCompat :: Assertion -test_blockMinerRewardLegacyCompat = do +test_blockMinerRewardLegacyCompat = withVersion mainnet $ do mapM_ rewardsMatch [0..10000] mapM_ rewardsMatch [0,1000..maxRewardHeight - 2] mapM_ rewardsMatch [maxRewardHeight - 1000 .. maxRewardHeight - 2] @@ -141,14 +143,15 @@ test_blockMinerRewardLegacyCompat = do [maxRewardHeight - 1] legacyCompatExceptions where - v = Mainnet01 + rewardsMatch :: HasVersion => BlockHeight -> Assertion rewardsMatch h = assertEqual "miner reward value matches the legacy value" - (legacyBlockMinerReward v h) - (minerRewardKda (blockMinerReward v h)) + (legacyBlockMinerReward h) + (minerRewardKda (blockMinerReward h)) + legacyCompatExceptions :: HasVersion => [BlockHeight] legacyCompatExceptions = M.keys $ M.filterWithKey - (\k _ -> legacyBlockMinerReward v k /= minerRewardKda (blockMinerReward v k)) + (\k _ -> legacyBlockMinerReward k /= minerRewardKda (blockMinerReward k)) minerRewards -- This should be a CAF and can thus not include the computation in @@ -171,13 +174,12 @@ mkLegacyMinerRewards = formatRow (!a,!b) = (BlockHeight $ int a, (_csvDecimal b)) legacyBlockMinerReward - :: ChainwebVersion - -> BlockHeight + :: HasVersion + => BlockHeight -> Kda -legacyBlockMinerReward v h = +legacyBlockMinerReward h = case M.lookupGE h legacyMinerRewards of Nothing -> error "The end of the chain has been reached" Just (_, m) -> Kda $ roundTo 8 (_kda m / n) where - !n = int . order $ chainGraphAt v h - + !n = int . order $ chainGraphAt h diff --git a/test/unit/Chainweb/Test/Mining.hs b/test/unit/Chainweb/Test/Mining.hs index e97920e8de..1bc26a99f3 100644 --- a/test/unit/Chainweb/Test/Mining.hs +++ b/test/unit/Chainweb/Test/Mining.hs @@ -17,81 +17,54 @@ module Chainweb.Test.Mining ( tests ) where -import Control.Concurrent -import Control.Concurrent.Async -import Control.Concurrent.STM.TVar -import Control.Lens - -import Data.Foldable -import qualified Data.HashMap.Strict as HM -import Data.Maybe -import qualified Data.Text as T - -import GHC.Stack - -import System.LogLevel - -import Test.Tasty -import Test.Tasty.HUnit - --- internal modules - -import Chainweb.Chainweb.MinerResources -import Chainweb.Graph -import Chainweb.Logger -import Chainweb.Miner.Config -import Chainweb.Miner.Coordinator -import Chainweb.Miner.Pact -import Chainweb.Test.CutDB hiding (tests) -import Chainweb.Test.TestVersions (barebonesTestVersion) - import Chainweb.Storage.Table.RocksDB +import Test.Tasty -- -------------------------------------------------------------------------- -- -- tests :: RocksDb -> TestTree tests rdb = testGroup "Mining" - [ testCaseSteps "Miner account names are not empty strings" (nonEmptyMiningAccount rdb) - ] + [ ] + -- testCaseSteps "Miner account names are not empty strings" (nonEmptyMiningAccount rdb) + -- ] -- -------------------------------------------------------------------------- -- -- Test Mining Coordinator -withTestCoordinator - :: HasCallStack - => RocksDb - -> (String -> IO ()) - -> Maybe MiningConfig - -- ^ Custom Mining configuration. If coordination is disabled it will be - -- set to enabled before the coordinator is initialized. - -> (forall tbl logger . Logger logger => logger -> MiningCoordination logger tbl -> IO ()) - -> IO () -withTestCoordinator rdb logg maybeConf a = do - var <- newEmptyMVar - x <- race (takeMVar var) $ - withTestCutDb rdb v id 0 (\_ _ -> return fakePact) (logFunction logger) $ \_ cdb -> - withMiningCoordination logger conf cdb $ \case - Nothing -> error "nonEmptyMiningAccount: Bug in the mining Code" - Just coord -> do - a logger coord - putMVar var () - case x of - Left () -> logFunctionText logger Info "withTestCoordinator: action finished" - Right () -> logFunctionText logger Info "withTestCoordinator: coordinator service stopped" - - where - v = barebonesTestVersion pairChainGraph - logger = genericLogger Warn (logg . T.unpack) - conf = fromMaybe defaultMining maybeConf - & miningCoordination . coordinationEnabled .~ True +-- withTestCoordinator +-- :: HasCallStack +-- => RocksDb +-- -> (String -> IO ()) +-- -> Maybe MiningConfig +-- -- ^ Custom Mining configuration. If coordination is disabled it will be +-- -- set to enabled before the coordinator is initialized. +-- -> (forall tbl logger . Logger logger => logger -> MiningCoordination logger tbl -> IO ()) +-- -> IO () +-- withTestCoordinator rdb logg maybeConf a = withVersion v $ do +-- var <- newEmptyMVar +-- x <- race (takeMVar var) $ +-- withTestCutDb rdb id 0 (\_ _ -> return fakePact) (logFunction logger) $ \_ cdb -> +-- withMiningCoordination logger conf cdb $ \case +-- Nothing -> error "nonEmptyMiningAccount: Bug in the mining Code" +-- Just coord -> do +-- a logger coord +-- putMVar var () +-- case x of +-- Left () -> logFunctionText logger Info "withTestCoordinator: action finished" +-- Right () -> logFunctionText logger Info "withTestCoordinator: coordinator service stopped" + +-- where +-- v = barebonesTestVersion pairChainGraph +-- logger = genericLogger Warn (logg . T.unpack) +-- conf = fromMaybe defaultMining maybeConf +-- & miningCoordination . coordinationEnabled .~ True -- -------------------------------------------------------------------------- -- -- Tests -nonEmptyMiningAccount :: HasCallStack => RocksDb -> (String -> IO ()) -> Assertion -nonEmptyMiningAccount rdb logg = withTestCoordinator rdb logg Nothing $ \_logger coord -> do - PrimedWork w <- readTVarIO (_coordPrimedWork coord) - forM_ (HM.keys w) $ \(MinerId k) -> - assertBool "miner account name must not be the empty string" (not (T.null k)) - +-- nonEmptyMiningAccount :: HasCallStack => RocksDb -> (String -> IO ()) -> Assertion +-- nonEmptyMiningAccount rdb logg = withTestCoordinator rdb logg Nothing $ \_logger coord -> do +-- PrimedWork w <- readTVarIO (_coordPrimedWork coord) +-- forM_ (HM.keys w) $ \(MinerId k) -> +-- assertBool "miner account name must not be the empty string" (not (T.null k)) diff --git a/test/unit/Chainweb/Test/Misc.hs b/test/unit/Chainweb/Test/Misc.hs index 67bd17b28c..2bc729f600 100644 --- a/test/unit/Chainweb/Test/Misc.hs +++ b/test/unit/Chainweb/Test/Misc.hs @@ -1,4 +1,7 @@ +{-# LANGUAGE ImportQualifiedPost #-} {-# LANGUAGE NumericUnderscores #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} -- | -- Module: Chainweb.Test.Misc @@ -10,15 +13,21 @@ -- Miscellaneous tests. -- module Chainweb.Test.Misc - ( tests - ) where +( tests +) where -import Chainweb.Payload +import Chainweb.Pact.Payload +import Chainweb.BlockHash +import Chainweb.ChainId +import Chainweb.MerkleUniverse +import Chainweb.Parent import Chainweb.Test.Orphans.Internal () - +import Chainweb.Utils +import Chainweb.Utils.Serialization import Control.Concurrent (threadDelay) import Control.Scheduler (Comp(..), scheduleWork, terminateWith, withScheduler) - +import Data.HashMap.Strict qualified as HM +import PropertyMatchers qualified as P import Test.Tasty import Test.Tasty.HUnit import Test.Tasty.QuickCheck @@ -28,15 +37,21 @@ import Test.Tasty.QuickCheck tests :: TestTree tests = testGroup "Misc. Unit Tests" [ testGroup "scheduler" - [ testCase "early termination result order" terminateOrder - ] + [ testCase "early termination result order" terminateOrder + ] , testGroup "binary encoding" - [ testProperty "BlockPayload" propPayloadBinaryEncoding - , testProperty "BlockTransactions" propBlockTransactionsEncoding - , testProperty "BlockOutputs" propBlockOutputsEncoding - , testProperty "PayloadData" propPayloadDataEncoding - , testProperty "PayloadWithOutputs" propPayloadWithOutputsEncoding - ] + [ testProperty "BlockPayload" propPayloadBinaryEncoding + , testProperty "BlockTransactions" propBlockTransactionsEncoding + , testProperty "BlockOutputs" propBlockOutputsEncoding + , testProperty "PayloadData" propPayloadDataEncoding + , testProperty "PayloadWithOutputs" propPayloadWithOutputsEncoding + ] + , testGroup "hashed adjacent block hash record" + [ testCase "smoke test" hashedAdjacentBlockHashRecordSmokeTest + -- , testCase "null padding" hashedAdjacentBlockHashRecordNullPadding + -- , testCase "truncation" hashedAdjacentBlockHashRecordTruncation + -- , testCase "bit flipping" hashedAdjacentBlockHashRecordBitFlipping + ] ] -- | Guarantee that `terminateWith` makes the scheduler's "head" return value be @@ -51,25 +66,75 @@ terminateOrder = do propPayloadBinaryEncoding :: BlockPayload -> Bool propPayloadBinaryEncoding bp - | Right x <- decodeBlockPayloads (encodeBlockPayloads bp) = x == bp - | otherwise = False + | Right x <- decodeBlockPayloads (encodeBlockPayloads bp) = x == bp + | otherwise = False propBlockTransactionsEncoding :: BlockTransactions -> Bool propBlockTransactionsEncoding bt - | Right x <- decodeBlockTransactions (encodeBlockTransactions bt) = x == bt - | otherwise = False + | Right x <- decodeBlockTransactions (encodeBlockTransactions bt) = x == bt + | otherwise = False propBlockOutputsEncoding :: BlockOutputs -> Bool propBlockOutputsEncoding bo - | Right x <- decodeBlockOutputs (encodeBlockOutputs bo) = x == bo - | otherwise = False + | Right x <- decodeBlockOutputs (encodeBlockOutputs bo) = x == bo + | otherwise = False propPayloadDataEncoding :: PayloadData -> Bool propPayloadDataEncoding pd - | Right x <- decodePayloadData (encodePayloadData pd) = x == pd - | otherwise = False + | Right x <- decodePayloadData (encodePayloadData pd) = x == pd + | otherwise = False propPayloadWithOutputsEncoding :: PayloadWithOutputs -> Bool propPayloadWithOutputsEncoding pwo - | Right x <- decodePayloadWithOutputs (encodePayloadWithOutputs pwo) = x == pwo - | otherwise = False + | Right x <- decodePayloadWithOutputs (encodePayloadWithOutputs pwo) = x == pwo + | otherwise = False + +hashedAdjacentBlockHashRecordSmokeTest :: IO () +hashedAdjacentBlockHashRecordSmokeTest = do + -- smoke test + blockHashHash <- fromTextM "rxPASJkSJKXkxmREa2iKr0j7VFbbNilgGwDsFgx05VQ" + let hashRecord = BlockHashRecord (HM.fromList [(unsafeChainId 0, Parent nullBlockHash)]) + encodeAdjacentsHash (adjacentsHash hashRecord) + & runPutS + & P.equals (runPutS $ encodeBlockHash $ BlockHash @ChainwebMerkleHashAlgorithm blockHashHash) + +-- hashedAdjacentBlockHashRecordNullPadding :: IO () +-- hashedAdjacentBlockHashRecordNullPadding = do +-- -- check that the first chain has a null block hash with a multi-chain record +-- blockHashHash <- fromText "iu7PoLnyrHgYhjsTYiQeTzLQaxAK6dHA-8xO1huRsXo" +-- convertBlockHashRecordForMining +-- (BlockHashRecord (HM.fromList [(unsafeChainId 0, nullBlockHash), (unsafeChainId 1, nullBlockHash)])) +-- & P.equals +-- ? BlockHashRecord +-- ? HM.fromList [(unsafeChainId 0, nullBlockHash), (unsafeChainId 1, BlockHash blockHashHash)] + +-- hashedAdjacentBlockHashRecordTruncation :: IO () +-- hashedAdjacentBlockHashRecordTruncation = do +-- -- check that more than 3 chains gets truncated +-- blockHashHash <- fromText "tnka1yzuG3ury0o80ccea3EiVWDwOL0pYITwsA2du7Q" +-- let nullBlockHashRecord = HM.fromList $ [(unsafeChainId cid, nullBlockHash) | cid <- [0..5]] +-- convertBlockHashRecordForMining (BlockHashRecord nullBlockHashRecord) +-- & P.equals +-- ? BlockHashRecord +-- ? HM.fromList ([(unsafeChainId cid, nullBlockHash) | cid <- [0..1]] ++ [(unsafeChainId 2, blockHashHash)]) + +-- hashedAdjacentBlockHashRecordBitFlipping :: IO () +-- hashedAdjacentBlockHashRecordBitFlipping = do +-- -- these two must be the same as previous test +-- blockHashHash <- fromText "tnka1yzuG3ury0o80ccea3EiVWDwOL0pYITwsA2du7Q" +-- let nullBlockHashRecord = HM.fromList $ [(unsafeChainId cid, nullBlockHash) | cid <- [0..5]] +-- -- check that flipping a bit relative to the previous test in *any* hash in +-- -- the record changes the output hash +-- let flippedBitNullBlockHash = +-- BlockHash $ unsafeMerkleLogHash $ BS.replicate 31 0x00 <> BS.singleton 0x01 +-- forM_ [0..5] $ \flippedCid -> do +-- let flippedRecord = +-- BlockHashRecord (HM.insert (unsafeChainId flippedCid) flippedBitNullBlockHash nullBlockHashRecord) +-- convertBlockHashRecordForMining flippedRecord +-- -- TODO: replace when property-matchers has notEquals check +-- & (\expected actual -> +-- if expected /= actual +-- then P.succeed actual +-- else P.fail "equal, should not be" actual) +-- ? BlockHashRecord +-- ? HM.fromList ([(unsafeChainId cid, nullBlockHash) | cid <- [0..1]] ++ [(unsafeChainId 2, blockHashHash)]) diff --git a/test/unit/Chainweb/Test/Pact/BlockHistoryMigrationTest.hs b/test/unit/Chainweb/Test/Pact/BlockHistoryMigrationTest.hs new file mode 100644 index 0000000000..cc714edc4a --- /dev/null +++ b/test/unit/Chainweb/Test/Pact/BlockHistoryMigrationTest.hs @@ -0,0 +1,235 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeApplications #-} + +module Chainweb.Test.Pact.BlockHistoryMigrationTest + (tests) +where + +import Chainweb.BlockHash +import Chainweb.BlockHeader +import Chainweb.BlockHeaderDB +import Chainweb.BlockHeaderDB.Internal +import Chainweb.Logger +import Chainweb.Pact.Backend.ChainwebPactDb qualified as ChainwebPactDb +import Chainweb.Pact.Backend.PactState +import Chainweb.Pact.Backend.Types +import Chainweb.Pact.Backend.Utils +import Chainweb.PayloadProvider.Pact.BlockHistoryMigration (migrateBlockHistoryTable) +import Chainweb.Storage.Table.RocksDB +import Chainweb.Test.Pact.Utils +import Chainweb.Test.Utils +import Chainweb.TreeDB +import Chainweb.Utils +import Chainweb.Utils.Serialization +import Chainweb.Version +import Chainweb.Version.Mainnet +import Control.Exception(SomeException) +import Control.Lens +import Control.Monad.IO.Class +import Control.Monad.Trans.Resource +import Data.Aeson (throwDecodeStrict') +import Data.ByteString qualified as BS +import Data.ByteString.Base64 qualified as B64 +import Data.Foldable (traverse_) +import Data.Int (Int64) +import Data.Maybe (fromJust) +import Database.SQLite3.Direct +import PropertyMatchers qualified as P +import Streaming.Prelude qualified as S +import Test.Tasty +import Test.Tasty.HUnit hiding (assert) + +cid :: ChainId +cid = unsafeChainId 1 + +createLegacyBlockHistoryTable :: SQLiteEnv -> IO () +createLegacyBlockHistoryTable sql = throwOnDbError $ + exec_ sql + "CREATE TABLE IF NOT EXISTS BlockHistory \ + \(blockheight UNSIGNED BIGINT NOT NULL, \ + \ endingtxid UNSIGNED BIGINT NOT NULL, \ + \ hash BLOB NOT NULL, \ + \ CONSTRAINT blockHeightConstraint UNIQUE (blockheight), \ + \ CONSTRAINT hashConstraint UNIQUE (hash));" + + +initSchema :: SQLiteEnv -> IO () +initSchema sql = do + ChainwebPactDb.initSchema sql -- create the BlockHistory2 table + createLegacyBlockHistoryTable sql -- create the legacy BlockHistory table + +insertGenesis :: SQLiteEnv -> IO () +insertGenesis sql = withVersion Mainnet01 $ do + -- fake txid, as we don't want to actually run genesis here. + throwOnDbError $ + exec' sql "INSERT INTO BlockHistory VALUES (?, ?, ?);" + [ SInt $ int (genesisHeight cid) + , SInt 1 + , SBlob $ runPutS $ encodeBlockHash $ view blockHash (genesisBlockHeader cid) + ] + +withSetup + :: TestName + -> (SQLiteEnv -> IO ()) + -> (HasVersion => GenericLogger -> ChainId -> SQLiteEnv -> BlockHeaderDb -> Bool -> IO ()) + -> TestTree +withSetup n setup action = withResourceT (withTempChainSqlite cid) $ \sqlIO -> do + testCase n $ do + logger <- getTestLogger + (sql, _sqlReadPool) <- sqlIO + + _ <- setup sql + + withTempRocksDb "chainweb-tests" $ \rdb -> do + withVersion Mainnet01 $ runResourceT $ do + bhdb <- withBlockHeaderDb rdb cid + liftIO $ action logger cid sql bhdb True + +tests :: HasCallStack => TestTree +tests = testGroup "BlockHistory Table Migration" + [ withSetup "test with empty BlockHistoryTable" + initSchema + $ \lf cid sdb bhdb cleanup -> do + migrateBlockHistoryTable lf cid sdb bhdb cleanup + & P.throws @SomeException P.succeed + + , withSetup "test with BlockHistoryTable that has only genesis" + (\sql -> initSchema sql >> insertGenesis sql) + $ \lf cid sdb bhdb cleanup -> do + migrateBlockHistoryTable lf cid sdb bhdb cleanup + >>= P.succeed + + , withSetup "test successful migration cleanup" + (\sql -> initSchema sql >> insertGenesis sql) + $ \lf cid sdb bhdb cleanup -> do + let qryIO = throwOnDbError $ qry sdb "SELECT 1 FROM sqlite_master WHERE type = 'table' AND name = 'BlockHistory'" [] [RInt] + [[SInt p]] <- qryIO + assertExpectation "Table should be present" (Expected 1) (Actual p) + migrateBlockHistoryTable lf cid sdb bhdb cleanup + post <- qryIO + assertExpectation "Table should not be present" (Expected []) (Actual post) + + , withSetup "test migration" + initSchema + $ \lf cid sdb bhdb _cleanup -> do + traverse_ (unsafeInsertBlockHeaderDb bhdb) blockHeaders + traverse_ (unsafeInsertEntry sdb) sqliteData + + -- Disable original table cleanup for migration verification. + migrateBlockHistoryTable lf cid sdb bhdb False + + verifyMigration sdb bhdb + + -- Re-run verification + migrateBlockHistoryTable lf cid sdb bhdb False + + verifyMigration sdb bhdb + + , withSetup "test migration with one missing row" + initSchema + $ \lf cid sdb bhdb _cleanup -> do + traverse_ (unsafeInsertBlockHeaderDb bhdb) blockHeaders + traverse_ (unsafeInsertEntry sdb) sqliteData + + -- Disable original table cleanup for migration verification. + migrateBlockHistoryTable lf cid sdb bhdb False + + verifyMigration sdb bhdb + + -- remove single row from BlockHistory2 table + let (rbh,_,_) = head sqliteData + throwOnDbError $ exec' sdb "DELETE FROM BlockHistory2 where blockheight=?" [SInt rbh] + + n <- nTableEntries sdb "BlockHistory2" + assert (n == 9) $ "BlockHistory2 should contain 9 entries, actual: " <> sshow n + + -- Re-run verification + migrateBlockHistoryTable lf cid sdb bhdb False + + verifyMigration sdb bhdb + ] + + +-- | Blockheader from mainnet01 of chain 1 +-- +-- Obtained by curl -H 'https://api.chainweb.com/chainweb/0.0/mainnet01/chain/1/header?limit=10' | jq +blockHeaders :: [BlockHeader] +blockHeaders = fromJust $ traverse throwDecodeStrict' [ + -- genesis + "\"AAAAAAAAAAAAJ41tFZYFAMhy366rCocPqnIPH492fe3J_cMShzHQwiyBVMT5RnKFAwADAAAAUsNRCUkMKQBRDVIv0JLDfDllYNg2QO0EXaWcRfMQ6g0EAAAAOu6kxMXpuwpm9uiIVhiEFHSbTdhanjHyiEh2G0EZV_wGAAAABQeojaqG63-R_1bILrd0LI6kDkS74hNBB0Bs3Y211bD__________________________________________5Apaf08O5Hgi1zH2gsox_oE6ABpi70UKojUZoVlAm8bAQAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAFAAAAACeNbRWWBQAAAAAAAAAAAGlRRahfD2xrvjGZFIW9TpOF4o4MVlGMQcYoAUIGZgxS\"", + "\"jw3vOXLHNX9X8Pf8F5YFAGlRRahfD2xrvjGZFIW9TpOF4o4MVlGMQcYoAUIGZgxSAwADAAAAtMyy7k6lrQOsGg2oXh20kOC3zudjwsaL9F5Ogx0XNBoEAAAAyeWKDE27xM45-LgdwpnVMM6E4pAoYryRrJJFgRiaKgQGAAAAOXehM2W5YuiV0iWlDGIPMdaRv721zMUbj3caJqZJNBX__________________________________________3CgdhATU9VNY_SB4Z9xQYmupqf0-0oZU5WKfk0I_SJJAQAAAAEAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAQAAAAAAAAAFAAAAACeNbRWWBQAAAAAAAAAAABwrUPRfEh4gKXiQaLRVoqUK1aDCluIWbmZQzt9lUSDV\"", + "\"NSpftriT22gDWwz9F5YFABwrUPRfEh4gKXiQaLRVoqUK1aDCluIWbmZQzt9lUSDVAwADAAAAe0GGnclF0G2-_AMlCLGjKJVgzSBj1V9dTiqtsCC-IB4EAAAAuekHplt74MFfLHPsu7cJz9HbWNb_vBY-MR1y5RRDiYsGAAAA7OcrWyX2Gk7zrwmdI6HALWBvCihE6PwaS7TELscDGCH__________________________________________7sfFm8JbPK3qCTNeRvk4tzVrddPKuqFw-tI68WMfCvbAQAAAAIAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAgAAAAAAAAAFAAAAACeNbRWWBQAAAAAAAAAAALpshckMhpgcor3YL9kXfHzYpq1iMsbjLA-2QKABndRt\"", + "\"h1RefsOyecrGlGX9F5YFALpshckMhpgcor3YL9kXfHzYpq1iMsbjLA-2QKABndRtAwADAAAAUYQRTGxyJpPIvFxR8mRa-wtGsBD9ymVwuPv9ta90DCEEAAAAhcayV2lxaq0ExtZZAKbHGptweEhk44dh3rk_6QGEff8GAAAAxu26E8QHPhi3GfZjOtisZyzMuR6E4-ekdfO-eWd06YT__________________________________________-nZJfKtvRk1CPK-MEaEfWAy0WrGA5g7b0xFyq1LykpHAQAAAAMAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAwAAAAAAAAAFAAAAACeNbRWWBQAAAAAAAAAAALO4obrG733x3raJyCjCQKWTp9IxoVDXC00thjQhnq5Z\"", + "\"ApXp4xPFfLL6MHT9F5YFALO4obrG733x3raJyCjCQKWTp9IxoVDXC00thjQhnq5ZAwADAAAAKuCNwclDosE_LMTCJPR-m8cLSTlQodWupf1c7PacZMEEAAAAlO6bNRGAwyiMdOAcDBushxBQheVa6Ra7TAd6OECzVVUGAAAAY00AQMeyYamYt6RnqEmQkAJVSt_OyNTZPA8ySAbs1c___________________________________________7Rres8j0FBEYwtUcS5UBNQumgtf0PG6j7y4VRMafRdmAQAAAAQAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAABAAAAAAAAAAFAAAAACeNbRWWBQAAAAAAAAAAAJr-V0iWi6yBDNGqEU0oJLNUrVOACJmITKsOvRz4H90R\"", + "\"0t473zHYtI-uNbf9F5YFAJr-V0iWi6yBDNGqEU0oJLNUrVOACJmITKsOvRz4H90RAwADAAAAumaN584K3DrEDxwpyuETFMsQ6ECseJVda54NIeQn8TkEAAAAv9sZzSMjqRD_uVMGoM-5kVnNqkRTYGqH6O-C7dIqXJsGAAAAcsRGLYQHN1NIYa1sXlj0eFaYwDLG7Vg3zqps05VEvGj__________________________________________5-87RGWTTcz0_voXhENxoJO6YTSH0GpwPkzCAxBCSvwAQAAAAUAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAABQAAAAAAAAAFAAAAACeNbRWWBQAAAAAAAAAAAERk0j0pZ1OduMRVwNDrexiPbxnTPTKIjwwNmsZ-gl6H\"", + "\"vhmHzX6Tuzdm--H9F5YFAERk0j0pZ1OduMRVwNDrexiPbxnTPTKIjwwNmsZ-gl6HAwADAAAA7mB5gbJFX_TnYhstzsiLBEhe0kT5nhh_JpPHfe7gMMEEAAAAxC3P3K1B1gDjwyLJPABbGt2qLuF93Y7QyiTNctqm94cGAAAA8JQk7mo7jCppLZnaHG6Doz6dOxrrKLXypB8CdzuAKHX__________________________________________65nMrh2AwrQTKIvl7YVg3ulCXikvFzPX4dVpPT9-s6cAQAAAAYAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAABgAAAAAAAAAFAAAAACeNbRWWBQAAAAAAAAAAAMpV6GV2nJeFmSVBjo7QzWvF5W2LPS9uKFUCKJfU29Qr\"", + "\"XDW_QcCklR_DbUD-F5YFAMpV6GV2nJeFmSVBjo7QzWvF5W2LPS9uKFUCKJfU29QrAwADAAAAlk-iO8laTJ5Gy-U7pE-P3EDr548IUL1sWOfZv9DGHn0EAAAAhFuMKuqHuk4fA2BOBCTvTEFrOZEs691JLXuINP3BSu4GAAAA85F8Vdy_NKXopcOdG4pcEpAw8G2Xk4wWfp29d_T5xk7__________________________________________7g-M1b3FLNbXKogETFOeA6w2xPeMWVODCbJl8PHDEGDAQAAAAcAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAABwAAAAAAAAAFAAAAACeNbRWWBQAAAAAAAAAAAF8yBC9hIAHcsIUtgH5-RFdC2-QAmkmuB93qDIlXLWBB\"", + "\"415OTHBmkcV-oJn-F5YFAF8yBC9hIAHcsIUtgH5-RFdC2-QAmkmuB93qDIlXLWBBAwADAAAAPT37vtcbWdrZUi21FIrCyeUl4rU6g4W6syR3iM-mSyUEAAAAUcfuhJG94kMymAtpftR3Vbv3dNuCCpIOaf2PZULHemwGAAAAumhex2eCzZTd9mVjd8QBug13FN2Y_65X68Guel01bLb__________________________________________9lYTtyLATglm7r7WHyqgYL3tqtOdVjaYqlv2w6JpDmmAQAAAAgAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAACAAAAAAAAAAFAAAAACeNbRWWBQAAAAAAAAAAAE8hMzYm6jX5iR2HwqCIreHN4eHJNBwlAxdUp0A4wEJ1\"", + "\"uD82CpEfylAigrn-F5YFAE8hMzYm6jX5iR2HwqCIreHN4eHJNBwlAxdUp0A4wEJ1AwADAAAAB4vWZj8UZzuvPJkCq3-_32I8pCkdePIRlYz3UIudbowEAAAAFYSAHoaThaLUdIFRcFYSkNm3xk0s7nzDMfY-wB-hp5YGAAAAwT2FOsosNkjFLH4-l-WFevFkAnJiFU-8IpGqpYb0_tr__________________________________________18PgFBxcI7IqYgDsHrSRiwWiAcrodG0YQBKFQuhxxcZAQAAAAkAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAACQAAAAAAAAAFAAAAACeNbRWWBQAAAAAAAAAAAO8gTCqlCDrGsVZkvavO_Cr6GX5y6iCcp7XvtXCSsyae\"" + ] + +unsafeInsertEntry :: SQLiteEnv -> (Int64, BS.ByteString, Int64) -> IO () +unsafeInsertEntry sql (bh, h, txid) = case B64.decode h of + Right h' -> + throwOnDbError $ exec' sql "INSERT INTO BlockHistory (blockheight, endingtxid, hash) VALUES (?, ?, ?)" + [SInt bh, SInt txid, SBlob h' ] + Left _ -> error "error decoding hash" + + +sqliteData :: [(Int64, BS.ByteString, Int64)] +sqliteData = [ + (0, "aVFFqF8PbGu+MZkUhb1Ok4XijgxWUYxBxigBQgZmDFI=", 6), + (1, "HCtQ9F8SHiApeJBotFWipQrVoMKW4hZuZlDO32VRINU=", 7), + (2, "umyFyQyGmByivdgv2Rd8fNimrWIyxuMsD7ZAoAGd1G0=", 8), + (3, "s7ihusbvffHetonIKMJApZOn0jGhUNcLTS2GNCGerlk=", 9), + (4, "mv5XSJaLrIEM0aoRTSgks1StU4AImYhMqw69HPgf3RE=", 10), + (5, "RGTSPSlnU524xFXA0Ot7GI9vGdM9MoiPDA2axn6CXoc=", 11), + (6, "ylXoZXacl4WZJUGOjtDNa8XlbYs9L24oVQIol9Tb1Cs=", 12), + (7, "XzIEL2EgAdywhS2Afn5EV0Lb5ACaSa4H3eoMiVctYEE=", 13), + (8, "TyEzNibqNfmJHYfCoIit4c3h4ck0HCUDF1SnQDjAQnU=", 14), + (9, "7yBMKqUIOsaxVmS9q878KvoZfnLqIJynte+1cJKzJp4=", 15)] + + +verifyMigration :: HasVersion => SQLiteEnv -> BlockHeaderDb -> IO () +verifyMigration sql bhdb = do + let qstmt = "SELECT A.blockheight, A.endingtxid, \ + \ B.hash AS b_hash, B.payloadhash AS b_payload_hash, \ + \ A.hash AS a_hash \ + \ FROM BlockHistory AS A INNER JOIN BlockHistory2 AS B \ + \ ON A.blockheight = B.blockheight AND A.endingtxid = B.endingtxid \ + \ ORDER BY A.blockheight, A.endingtxid" + rty = [RInt, RInt, RBlob, RBlob, RBlob] + + n <- nTableEntries sql "BlockHistory" + + _ <- qryStream sql qstmt [] rty $ \rs -> do + rs & flip S.mapM_ $ \case + [SInt a_bh, SInt a_etxid, SBlob b_hash, SBlob b_payload, SBlob a_hash] -> do + assert (a_hash == b_hash) $ + "Hash mismatch at block " ++ show a_bh ++ " / txid " ++ show a_etxid + + let rowBlockHeight = fromIntegral a_bh + rowBlockHash <- runGetS decodeBlockHash a_hash + blockHeader <- lookupRankedM bhdb rowBlockHeight rowBlockHash + let bph = view blockPayloadHash blockHeader + enc = runPutS $ encodeBlockPayloadHash bph + + assert (b_payload == enc) $ + "Payload Hash mismatch at block " ++ show a_bh ++ " / txid " ++ show a_etxid + + n2' <- nTableEntries sql "BlockHistory2" + assert (n == n2') "BlockHistory2 has the same number of rows as BlockHistory" + _ -> error "unexpected result shape" + pure () + +assert :: Bool -> String -> IO () +assert = flip assertBool + +nTableEntries :: SQLiteEnv -> Utf8 -> IO Int64 +nTableEntries sql tname = throwOnDbError $ qry_ sql ("SELECT count(*) from " <> tname) [RInt] >>= \case + [[SInt n]] -> pure n + _ -> error "unexpected row shape" diff --git a/test/unit/Chainweb/Test/Pact/CheckpointerTest.hs b/test/unit/Chainweb/Test/Pact/CheckpointerTest.hs new file mode 100644 index 0000000000..24e84fabee --- /dev/null +++ b/test/unit/Chainweb/Test/Pact/CheckpointerTest.hs @@ -0,0 +1,419 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NumericUnderscores #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuantifiedConstraints #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE ViewPatterns #-} + +module Chainweb.Test.Pact.CheckpointerTest (tests) where + +import Control.Exception (evaluate) +import Control.Exception.Safe +import Control.Lens +import Control.Monad +import Data.ByteString (ByteString) +import Data.Functor.Product +import Data.List.NonEmpty qualified as NE +import Data.Map qualified as Map +import Data.MerkleLog (MerkleNodeType (..), merkleRoot) +import Data.Text (Text) +import Data.Text qualified as T +import Data.Text.Encoding qualified as T +import Hedgehog hiding (Update) +import Hedgehog.Gen qualified as Gen +import Hedgehog.Range qualified as Range +import Pact.Core.Builtin +import Pact.Core.Evaluate (Info) +import Pact.Core.Literal +import Pact.Core.Names +import Pact.Core.PactDbRegression qualified as Pact +import Pact.Core.PactValue +import Pact.Core.Persistence +import PropertyMatchers qualified as P +import Test.Tasty +import Test.Tasty.HUnit (assertEqual, testCase) +import Test.Tasty.Hedgehog +import Chainweb.BlockHash +import Chainweb.BlockHeader +import Chainweb.ForkState (pact4ForkNumber) +import Chainweb.Graph (singletonChainGraph) +import Chainweb.MerkleLogHash +import Chainweb.MerkleUniverse (ChainwebMerkleHashAlgorithm) +import Chainweb.Pact.Backend.ChainwebPactDb qualified as ChainwebPactDb +import Chainweb.Pact.Backend.Types +import Chainweb.Pact.PactService.Checkpointer qualified as Checkpointer +import Chainweb.Pact.Types +import Chainweb.Parent +import Chainweb.PayloadProvider +import Chainweb.Test.Pact.Utils +import Chainweb.Test.TestVersions +import Chainweb.Test.Utils +import Chainweb.Utils +import Chainweb.Utils.Serialization (runGetS, runPutS) +import Chainweb.Version +import Chainweb.MinerReward +import Control.Monad.State.Strict +import Chainweb.Pact.Payload qualified as Chainweb +import Chainweb.Pact.Utils (emptyPayload) + +-- | A @DbAction f@ is a description of some action on the database together with an f-full of results for it. +type DbValue = Integer +data DbAction f + = DbRead !T.Text RowKey (f (Either Text (Maybe DbValue))) + | DbWrite WriteType !T.Text RowKey DbValue (f (Either Text ())) + | DbKeys !T.Text (f (Either Text [RowKey])) + | DbSelect !T.Text (f (Either Text [(RowKey, Integer)])) + | DbCreateTable T.Text (f (Either Text ())) + +mkTableName :: T.Text -> TableName +mkTableName n = TableName n (ModuleName "mod" Nothing) + +genDbAction :: Gen (DbAction (Const ())) +genDbAction = do + let tn = Gen.choice [pure "A", pure "B", pure "C"] + Gen.choice + [ DbRead + <$> tn + <*> Gen.choice (pure . RowKey <$> ["A", "B", "C"]) + <*> pure (Const ()) + , DbWrite + <$> genWriteType + <*> tn + <*> Gen.choice (pure . RowKey <$> ["A", "B", "C"]) + <*> fmap fromIntegral (Gen.int (Range.constant 0 5)) + <*> pure (Const ()) + , DbKeys <$> tn <*> pure (Const ()) + , DbSelect <$> tn <*> pure (Const ()) + , DbCreateTable <$> tn <*> pure (Const ()) + ] + where + genWriteType = Gen.choice $ fmap pure + [ Write + , Insert + , Update + ] + +-- a block is a list of actions +type DbBlock f = [DbAction f] + +genDbBlock :: Gen (DbBlock (Const ())) +genDbBlock = Gen.list (Range.constant 1 20) genDbAction + +genBlockHistory :: Gen [DbBlock (Const ())] +genBlockHistory = do + let create tn = DbCreateTable tn (Const ()) + blocks <- Gen.list (Range.linear 1 20) genDbBlock + -- we always start by making tables A and B to ensure the tests do something, + -- but we leave table C uncreated to leave some room for divergent table sets + return $ [create "A", create "B"] : blocks + +hoistDbAction :: (forall a. (Eq a, Show a) => f a -> g a) -> DbAction f -> DbAction g +hoistDbAction f (DbRead tn k r) = DbRead tn k (f r) +hoistDbAction f (DbWrite wt tn k v r) = DbWrite wt tn k v (f r) +hoistDbAction f (DbKeys tn ks) = DbKeys tn (f ks) +hoistDbAction f (DbSelect tn rs) = DbSelect tn (f rs) +hoistDbAction f (DbCreateTable tn es) = DbCreateTable tn (f es) + +tryShow :: IO a -> IO (Either Text a) +tryShow = handleAny (fmap Left . \case + e -> return (sshow e) + ) . fmap Right + +-- Run an empty DbAction, annotating it with its result +runDbAction :: PactDb CoreBuiltin Info -> DbAction (Const ()) -> IO (DbAction Identity) +runDbAction pactDB act = + fmap (hoistDbAction (\(Pair (Const ()) fa) -> fa)) + $ runDbAction' pactDB act + +extractInt :: RowData -> IO Integer +extractInt (RowData m) = evaluate (m ^?! ix (Field "k") . _PLiteral . _LInteger) + +-- Annotate a DbAction with its result, including any other contents it has +runDbAction' :: PactDb CoreBuiltin Info -> DbAction f -> IO (DbAction (Product f Identity)) +runDbAction' pactDB = \case + DbRead tn k v -> do + maybeValue <- tryShow $ ignoreGas noInfo $ _pdbRead pactDB (DUserTables (mkTableName tn)) k + integerValue <- (traverse . traverse) extractInt maybeValue + return $ DbRead tn k $ Pair v (Identity integerValue) + DbWrite wt tn k v s -> + fmap (DbWrite wt tn k v . Pair s . Identity) + $ tryShow $ ignoreGas noInfo + $ _pdbWrite pactDB wt (DUserTables (mkTableName tn)) k (RowData $ Map.singleton (Field "k") $ PLiteral $ LInteger v) + DbKeys tn ks -> + fmap (DbKeys tn . Pair ks . Identity) + $ tryShow $ ignoreGas noInfo $ _pdbKeys pactDB (DUserTables (mkTableName tn)) + DbSelect tn rs -> + fmap (DbSelect tn . Pair rs . Identity) + $ tryShow $ do + ks <- ignoreGas noInfo $ _pdbKeys pactDB (DUserTables (mkTableName tn)) + traverse (\k -> fmap (k,) . extractInt . fromJuste =<< ignoreGas noInfo (_pdbRead pactDB (DUserTables (mkTableName tn)) k)) ks + DbCreateTable tn s -> + fmap (DbCreateTable tn . Pair s . Identity) + $ tryShow (ignoreGas noInfo $ _pdbCreateUserTable pactDB (mkTableName tn)) + +-- craft a fake block header from txlogs, i.e. some set of writes. +-- that way, the block header changes if the write set stops agreeing. +blockHeaderFromTxLogs :: Parent RankedBlockHash -> [TxLog ByteString] -> IO (BlockHash, BlockPayloadHash) +blockHeaderFromTxLogs parent txLogs = do + fakePayloadHash <- runGetS decodeBlockPayloadHash $ + let + payloadLogMerkleTree = merkleRoot @ChainwebMerkleHashAlgorithm + [ TreeNode $ merkleRoot $ + [ InputNode (T.encodeUtf8 (_txDomain txLog)) + , InputNode (T.encodeUtf8 (_txKey txLog)) + , InputNode (_txValue txLog) + ] + | txLog <- txLogs + ] + in + runPutS $ encodeMerkleLogHash $ MerkleLogHash payloadLogMerkleTree + fakeBlockHash <- runGetS decodeBlockHash $ + let + blockLogMerkleTree = merkleRoot @ChainwebMerkleHashAlgorithm + [ TreeNode $ merkleRoot $ + [ InputNode (runPutS $ encodeBlockHash $ unwrapParent $ _rankedBlockHashHash <$> parent) + , InputNode (runPutS $ encodeBlockPayloadHash @ChainwebMerkleHashAlgorithm fakePayloadHash) + ] + ] + in + runPutS $ encodeMerkleLogHash $ MerkleLogHash blockLogMerkleTree + return (fakeBlockHash, fakePayloadHash) + +-- TODO things to test later: +-- that a tree of blocks can be explored, such that reaching any particular block gives identical results to running to that block from genesis +-- more specific regressions, like in the Pact 4 checkpointer test + +runBlocks + :: SQLiteEnv + -> Parent RankedBlockHash + -> [DbBlock (Const ())] + -> IO [(BlockCtx, (BlockHash, BlockPayloadHash), DbBlock Identity)] +runBlocks sql rootBlockCtx blks = + loop rootBlockCtx blks + where + loop parent (block:blocks) = withVersion testVer $ do + logger <- getTestLogger + fakeParentCreationTime <- Checkpointer.mkFakeParentCreationTime + (fakeBlockInfo, block', _finalBlockHandle) <- + (throwIfNoHistory =<<) $ + Checkpointer.readFrom logger cid sql fakeParentCreationTime parent $ + Checkpointer.readPact5 "unexpected pact 5" $ executeBlockTransaction parent block + let childBlockCtx = BlockCtx + { _bctxParentCreationTime = fakeParentCreationTime + , _bctxParentHash = Parent $ fst fakeBlockInfo + , _bctxParentHeight = Parent $ childBlockHeight cid parent + , _bctxParentForkNumber = pact4ForkNumber + , _bctxChainId = cid + , _bctxMinerReward = blockMinerReward (childBlockHeight cid parent) + } + let parentBlockCtx = BlockCtx + { _bctxParentCreationTime = fakeParentCreationTime + , _bctxParentHash = _rankedBlockHashHash <$> parent + , _bctxParentHeight = _rankedBlockHashHeight <$> parent + , _bctxParentForkNumber = pact4ForkNumber + , _bctxChainId = cid + , _bctxMinerReward = blockMinerReward (unwrapParent $ _rankedBlockHashHeight <$> parent) + } + _ <- Checkpointer.restoreAndSave logger cid sql (parentBlockCtx ^. to _bctxParentRankedBlockHash) + (NE.singleton $ Checkpointer.Pact5RunnableBlock $ \chainwebPactDb -> do + blockHandle <- get + (fakeBlockInfo', _blk, finalBlockHandle) <- + liftIO $ executeBlockTransaction parent block (BlockEnv parentBlockCtx chainwebPactDb) blockHandle + put finalBlockHandle + liftIO $ fakeBlockInfo' & P.equals fakeBlockInfo + return ((), fakeBlockInfo) + ) + ((parentBlockCtx, fakeBlockInfo, block') :) <$> loop (_bctxParentRankedBlockHash childBlockCtx) blocks + loop _ [] = return [] + executeBlockTransaction + :: Traversable t + => Parent RankedBlockHash + -> t (DbAction (Const ())) + -> BlockEnv + -> BlockHandle + -> IO + ((BlockHash, BlockPayloadHash), t (DbAction Identity), BlockHandle) + executeBlockTransaction parent block blockEnv blockHandle = do + ((blk', childBlockInfo), finalBlockHandle) <- flip runStateT blockHandle $ + doChainwebPactDbTransaction (_psBlockDbEnv blockEnv) Nothing $ \txdb _spv -> do + runBlk txdb parent (traverse (runDbAction txdb) block) + return (childBlockInfo, blk', finalBlockHandle) + +runBlk + :: PactDb x Info + -> Parent RankedBlockHash + -> IO r + -> IO (r, (BlockHash, BlockPayloadHash)) +runBlk txdb ph blk = do + _ <- ignoreGas noInfo $ _pdbBeginTx txdb Transactional + blk' <- blk + txLogs <- ignoreGas noInfo $ _pdbCommitTx txdb + bh <- blockHeaderFromTxLogs ph txLogs + return (blk', bh) + +-- Check that a block's result at the time it was added to the checkpointer +-- is consistent with us executing that block with `readFrom` +assertBlock :: SQLiteEnv -> BlockCtx -> (BlockHash, BlockPayloadHash) -> DbBlock Identity -> IO () +assertBlock sql blockCtx expectedBlockInfo blk = withVersion testVer $ do + fakeNewBlockCtx <- Checkpointer.mkFakeParentCreationTime + logger <- getTestLogger + hist <- Checkpointer.readFrom logger cid sql fakeNewBlockCtx (_bctxParentRankedBlockHash blockCtx) $ + Checkpointer.readPact5 "unexpected Pact 4" $ \blockEnv startHandle -> do + () <- flip evalStateT startHandle $ doChainwebPactDbTransaction (_psBlockDbEnv blockEnv) Nothing $ \txdb _spv -> do + _ <- ignoreGas noInfo $ _pdbBeginTx txdb Transactional + blk' <- forM blk (runDbAction' txdb) + txLogs <- ignoreGas noInfo $ _pdbCommitTx txdb + forM_ blk' $ \case + DbRead _d _k (Pair expected actual) -> + assertEqual "read result" expected actual + DbWrite _wt _d _k _v (Pair expected actual) -> + assertEqual "write result" expected actual + DbKeys _d (Pair expected actual) -> + assertEqual "keys result" expected actual + DbSelect _d (Pair expected actual) -> + assertEqual "select result" expected actual + DbCreateTable _tn (Pair expected actual) -> + assertEqual "create table result" expected actual + + actualBlockInfo <- + blockHeaderFromTxLogs (_bctxParentRankedBlockHash blockCtx) txLogs + assertEqual "block header" expectedBlockInfo actualBlockInfo + return () + throwIfNoHistory hist + +tests :: TestTree +tests = testGroup "Pact5 Checkpointer tests" + [ withResourceT (withTempChainSqlite cid) $ \sqlIO -> + testCase "valid PactDb before genesis" $ withVersion testVer $ do + (sql, _sqlReadPool) <- sqlIO + ChainwebPactDb.initSchema sql + Checkpointer.setConsensusState sql $ genesisConsensusState cid + logger <- getTestLogger + fakeNewBlockCtx <- Checkpointer.mkFakeParentCreationTime + () <- (throwIfNoHistory =<<) $ + Checkpointer.readFrom logger cid sql fakeNewBlockCtx genesisParentRanked + $ Checkpointer.readPact5 "unexpected Pact 4" $ \db blockHandle -> do + flip evalStateT blockHandle $ + doChainwebPactDbTransaction (_psBlockDbEnv db) Nothing $ \txdb _spv -> + Pact.runPactDbRegression txdb + return () + , withResourceT (withTempChainSqlite cid) $ \sqlIO -> + testProperty "readFrom with linear block history is valid" $ withTests 1000 $ property $ withVersion testVer $ do + blocks <- forAll genBlockHistory + (sql, _sqlReadPool) <- evalIO sqlIO + finishedBlocks <- evalIO $ do + ChainwebPactDb.initSchema sql + Checkpointer.setConsensusState sql $ genesisConsensusState cid + logger <- getTestLogger + -- extend this empty chain with the genesis block + _ <- Checkpointer.restoreAndSave logger cid sql (_evaluationCtxRankedParentHash (genesisEvalCtx cid)) + $ NE.singleton + $ Checkpointer.Pact5RunnableBlock $ \_ -> + return ((), (view blockHash (genesisBlockHeader cid), genesisBlockPayloadHash cid)) + handle @_ @SomeException + (\ex -> putStrLn (displayException ex) >> throw ex) + (runBlocks sql (Parent $ view rankedBlockHash gh) blocks) + -- run all of the generated blocks + annotateShow finishedBlocks + -- assert that using readFrom to read from a parent, then executing the same block, + -- gives the same results + evalIO $ forM_ finishedBlocks $ \(parent, blockInfo, block) -> do + assertBlock sql parent blockInfo block + , withResourceT (withTempChainSqlite cid) $ \sqlIO -> + testCase "reading doesn't duplicate keys results" $ withVersion testVer $ do + logger <- getTestLogger + (sql, _sqlReadPool) <- sqlIO + ChainwebPactDb.initSchema sql + _ <- Checkpointer.restoreAndSave logger cid sql (genesisRankedParentBlockHash cid) + $ NE.singleton + $ Checkpointer.Pact5RunnableBlock $ \_ -> + return ((), (view blockHash gh, view blockPayloadHash gh)) + let coinTable = TableName "coin-table" (ModuleName "coin" Nothing) + let domain = DUserTables coinTable + blockInfo NE.:| [] <- Checkpointer.restoreAndSave logger cid sql (Parent $ view rankedBlockHash gh) + $ NE.singleton + $ Checkpointer.Pact5RunnableBlock $ \chainwebPactDb -> + doChainwebPactDbTransaction chainwebPactDb Nothing $ \txdb _ -> do + ((), blockInfo) <- runBlk txdb (Parent (view rankedBlockHash gh)) $ do + ignoreGas noInfo $ _pdbCreateUserTable txdb + coinTable + ignoreGas noInfo $ _pdbWrite txdb Insert + domain + (RowKey "k") + (RowData $ Map.singleton (Field "f") (PString "value")) + return (NE.singleton blockInfo, blockInfo) + let rbh = RankedBlockHash (succ (gh ^. blockHeight)) (view _1 blockInfo) + _ <- Checkpointer.restoreAndSave logger cid sql + (Parent rbh) + $ NE.singleton + $ Checkpointer.Pact5RunnableBlock $ \db -> + doChainwebPactDbTransaction db Nothing $ \txdb _ -> + runBlk txdb (Parent rbh) $ do + _ <- ignoreGas noInfo $ _pdbRead txdb + domain + (RowKey "k") + keys <- ignoreGas noInfo $ _pdbKeys txdb domain + assertEqual "keys after reading" [RowKey "k"] keys + + return () + ] + where + -- note that this the evaluation ctx for the genesis header, *not* for the header *after* + genesisEvalCtx c = withVersion testVer $ EvaluationCtx + { _evaluationCtxParentCreationTime = Parent $ implicitVersion ^?! versionGenesis . genesisTime . atChain c + , _evaluationCtxParentHash = genesisParentBlockHash c + , _evaluationCtxParentHeight = Parent $ genesisHeight c + , _evaluationCtxParentForkNumber = pact4ForkNumber + -- should not be used + , _evaluationCtxMinerReward = MinerReward 0 + , _evaluationCtxPayload = ConsensusPayload + { _consensusPayloadHash = genesisBlockPayloadHash c + , _consensusPayloadData = Just $ EncodedPayloadData $ Chainweb.encodePayloadData $ + Chainweb.payloadWithOutputsToPayloadData emptyPayload + } + } + + +testVer :: ChainwebVersion +testVer = checkpointerTestVersion singletonChainGraph + +cid :: ChainId +cid = unsafeChainId 0 + +gh :: BlockHeader +gh = withVersion testVer $ genesisBlockHeader cid + +genesisParentRanked :: Parent RankedBlockHash +genesisParentRanked = withVersion testVer $ + Parent $ RankedBlockHash + (genesisHeight cid) + (unwrapParent $ genesisParentBlockHash cid) + +instance (forall a. Show a => Show (f a)) => Show (DbAction f) where + showsPrec n (DbRead tn k v) = showParen (n > 10) $ + showString "DbRead " . showsPrec 11 tn + . showString " " . showsPrec 11 k + . showString " " . showsPrec 11 v + showsPrec n (DbWrite wt tn k v r) = showParen (n > 10) $ + showString "DbWrite " . showsPrec 11 wt + . showString " " . showsPrec 11 tn + . showString " " . showsPrec 11 k + . showString " " . showsPrec 11 v + . showString " " . showsPrec 11 r + showsPrec n (DbKeys tn ks) = showParen (n > 10) $ + showString "DbKeys " . showsPrec 11 tn + . showString " " . showsPrec 11 ks + showsPrec n (DbSelect tn rs) = showParen (n > 10) $ + showString "DbSelect " . showsPrec 11 tn + . showString " " . showsPrec 11 rs + showsPrec n (DbCreateTable tn r) = showParen (n > 10) $ + showString "DbSelect " . showsPrec 11 tn + . showString " " . showsPrec 11 r diff --git a/test/unit/Chainweb/Test/Pact/CutFixture.hs b/test/unit/Chainweb/Test/Pact/CutFixture.hs new file mode 100644 index 0000000000..f760d83dce --- /dev/null +++ b/test/unit/Chainweb/Test/Pact/CutFixture.hs @@ -0,0 +1,236 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE ImplicitParams #-} +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NumericUnderscores #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PackageImports #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE ViewPatterns #-} + +-- | A fixture which provides access to the internals of a running node, with +-- multiple chains. Usually, you initialize it with `mkFixture`, insert +-- transactions into the mempool as desired, and use `advanceAllChains` to +-- trigger mining on all chains at once. +module Chainweb.Test.Pact.CutFixture + ( Fixture(..) + , HasFixture(..) + , mkFixture + , fixtureCutDb + , fixturePayloadDb + , fixtureWebBlockHeaderDb + , fixtureLogger + , fixtureMempools + , fixturePacts + , advanceAllChains + , advanceAllChains_ + , advanceToForkHeight + , withTestCutDb + ) + where + +import Chainweb.BlockHeader hiding (blockCreationTime, blockNonce) +import Chainweb.ChainId +import Chainweb.Cut +import Chainweb.Cut.CutHashes +import Chainweb.CutDB +import Chainweb.Logger +import Chainweb.Pact.Mempool.Mempool (MempoolBackend) +import Chainweb.Pact.Types +import Chainweb.Pact.Transaction qualified as Pact +import Chainweb.Pact.Payload +import Chainweb.Pact.Payload.PayloadStore +import Chainweb.Storage.Table.RocksDB +import Chainweb.Test.Cut +import Chainweb.Test.CutDB +import Chainweb.Test.Pact.Utils +import Chainweb.Test.Utils +import Chainweb.Time +import Chainweb.Utils +import Chainweb.Version +import Chainweb.Version.Utils +import Chainweb.WebBlockHeaderDB +import Control.Lens hiding (elements, only) +import Control.Monad +import Control.Monad.Catch hiding (finally) +import Control.Monad.IO.Class +import Control.Monad.Trans.Resource (ResourceT) +import Data.ByteString.Lazy qualified as LBS +import Data.Function +import Data.HashMap.Strict qualified as HashMap +import Data.HashSet qualified as HashSet +import Data.Maybe (fromMaybe) +import Data.Text qualified as Text +import Data.Vector (Vector) +import GHC.Stack +import Chainweb.Pact.PactService qualified as PactService +import Chainweb.PayloadProvider +import Chainweb.PayloadProvider.Pact + +data Fixture = Fixture + { _fixtureCutDb :: CutDb GenericLogger + , _fixturePayloadDb :: PayloadDb RocksDbTable + , _fixtureWebBlockHeaderDb :: WebBlockHeaderDb + , _fixtureLogger :: GenericLogger + , _fixturePacts :: ChainMap (ServiceEnv RocksDbTable) + , _fixtureMempools :: ChainMap (MempoolBackend Pact.Transaction) + } +makeLenses ''Fixture + +class HasFixture a where + cutFixture :: a -> IO Fixture +instance HasFixture Fixture where + cutFixture = return +instance HasFixture a => HasFixture (IO a) where + cutFixture = (>>= cutFixture) + +mkFixture + :: HasVersion + => (ChainId -> PayloadWithOutputs) + -> PactServiceConfig + -> RocksDb + -> ResourceT IO Fixture +mkFixture genesisPayloadFor pactServiceConfig baseRdb = do + logger <- liftIO getTestLogger + testRdb <- liftIO $ testRocksDb "withBlockDbs" baseRdb + (payloadDb, webBHDb) <- withBlockDbs testRdb + perChain <- fmap ChainMap $ iforM (HashSet.toMap chainIds) $ \chain () -> do + (writeSqlite, readPool) <- withTempChainSqlite chain + serviceEnv <- PactService.withPactService chain Nothing mempty logger Nothing payloadDb readPool writeSqlite pactServiceConfig (GenesisPayload $ genesisPayloadFor chain) + mempool <- withMempool logger serviceEnv + let serviceEnv' = serviceEnv { _psMempoolAccess = pactMemPoolAccess mempool logger } + return (mempool, serviceEnv') + let pacts = snd <$> perChain + let mempools = fst <$> perChain + let providers = ConfiguredPayloadProvider . PactPayloadProvider logger <$> pacts + (_, cutDb) <- withTestCutDb testRdb id 0 providers logger + let fixture = Fixture + { _fixtureCutDb = cutDb + , _fixtureLogger = logger + , _fixturePacts = pacts + , _fixturePayloadDb = payloadDb + , _fixtureWebBlockHeaderDb = webBHDb + , _fixtureMempools = mempools + } + -- we create the first block to avoid rejecting txs based on genesis + -- block creation time being from the past + _ <- liftIO $ advanceAllChains fixture + return fixture + +-- | Advance all chains by one block, filling that block with whatever is in +-- their mempools at the time. +-- +advanceAllChains + :: (HasCallStack, HasFixture a, HasVersion) + => a + -> IO (Cut, ChainMap (Vector TestPact5CommandResult)) +advanceAllChains fx = do + Fixture{..} <- cutFixture fx + latestCut <- liftIO $ _fixtureCutDb ^. cut + let blockHeights = fmap (view blockHeight) $ latestCut ^. cutMap + let latestBlockHeight = maximum blockHeights + + -- TODO: rejig this to do parallel mining. + (finalCut, perChainCommandResults) <- foldM + (\ (prevCut, !acc) cid -> do + (newCut, _minedChain, newPayload) <- + mine cid _fixtureCutDb prevCut + + pwo <- decodeNewPayload newPayload + + commandResults <- forM (_payloadWithOutputsTransactions pwo) $ \(_, txOut) -> do + decodeOrThrow' $ LBS.fromStrict $ _transactionOutputBytes txOut + + addNewPayload _fixturePayloadDb latestBlockHeight pwo + + return (newCut, (cid, commandResults) : acc) + ) + (latestCut, []) + (HashSet.toList (chainIdsAt (latestBlockHeight + 1))) + + return (finalCut, onChains perChainCommandResults) + +advanceAllChains_ + :: (HasCallStack, HasFixture a, HasVersion) + => a + -> IO () +advanceAllChains_ = void . advanceAllChains + +-- Advance to the forkheight of a fork. +-- +-- Throws an 'error' if the fork is not found in the ChainwebVersion '_versionForks', or if +-- the fork height is ever 'ForkNever' or 'ForkGenesis' on all chains. +-- +-- Does nothing if you are already at or past the the forkheight. +advanceToForkHeight :: (HasCallStack, HasFixture fx, HasVersion) => fx -> Fork -> IO () +advanceToForkHeight fx fork = do + Fixture{..} <- cutFixture fx + latestCut <- liftIO $ _fixtureCutDb ^. cut + let latestBlockHeight = latestCut ^. cutMaxHeight + + let targetHeight = fromMaybe (error "advanceToForkHeight: no fork found") $ + maximumOf (versionForks . ix fork . folded . _ForkAtBlockHeight) implicitVersion + + when (targetHeight > latestBlockHeight) $ do + replicateM_ (int (targetHeight - latestBlockHeight)) $ advanceAllChains_ fx + +-- | Build a linear chainweb (no forks, assuming single threaded use of the +-- cutDb). No POW or poison delay is applied. Block times are real times. +mine + :: HasCallStack + => HasVersion + => ChainId + -> CutDb l + -> Cut + -> IO (Cut, ChainId, NewPayload) +mine cid cutDb c = do + tryMineForChain cutDb c cid >>= \case + Left _ -> throwM $ InternalInvariantViolation + $ "Failed to create new cut on chain " <> toText cid <> "." + <> "This is a bug in Chainweb.Test.Pact.CutFixture or one of its users; check that this chain's adjacent chains aren't too far behind." + <> "\nCut: \n" + <> Text.unlines (cutToTextShort c) + Right x -> do + void $ awaitCut cutDb $ ((<=) `on` _cutHeight) (view _1 x) + return x + +-- | Build a linear chainweb (no forks). No POW or poison delay is applied. +-- Block times are real times. +-- +tryMineForChain + :: HasCallStack + => HasVersion + => CutDb l + -> Cut + -> ChainId + -> IO (Either MineFailure (Cut, ChainId, NewPayload)) +tryMineForChain cutDb c cid = do + newBlock <- case cutDb ^?! cutDbPayloadProviders . atChain cid of + ConfiguredPayloadProvider p -> waitForChangedPayload p + DisabledPayloadProvider -> error $ "missing payload provider on chain " <> show cid + let payloadHash = _newPayloadBlockPayloadHash newBlock + t <- getCurrentTimeIntegral + x <- testMineWithPayloadHash wdb (Nonce 0) t payloadHash cid c + case x of + Right (T2 h c') -> do + addCutHashes cutDb (cutToCutHashes Nothing c') + { _cutHashesHeaders = HashMap.singleton (view blockHash h) h + , _cutHashesPayloads = + HashMap.singleton (view blockPayloadHash h) (fromJuste $ _newPayloadEncodedPayloadData newBlock) + } + return $ Right (c', cid, newBlock) + Left e -> return $ Left e + where + wdb = view cutDbWebBlockHeaderDb cutDb diff --git a/test/unit/Chainweb/Test/Pact5/HyperlanePluginTests.hs b/test/unit/Chainweb/Test/Pact/HyperlanePluginTests.hs similarity index 87% rename from test/unit/Chainweb/Test/Pact5/HyperlanePluginTests.hs rename to test/unit/Chainweb/Test/Pact/HyperlanePluginTests.hs index e3b8cba08c..70b7d7905b 100644 --- a/test/unit/Chainweb/Test/Pact5/HyperlanePluginTests.hs +++ b/test/unit/Chainweb/Test/Pact/HyperlanePluginTests.hs @@ -1,6 +1,6 @@ {-# LANGUAGE ImportQualifiedPost #-} {-# LANGUAGE OverloadedStrings #-} -module Chainweb.Test.Pact5.HyperlanePluginTests (tests) where +module Chainweb.Test.Pact.HyperlanePluginTests (tests) where import Control.Lens import Control.Monad.IO.Class @@ -17,10 +17,10 @@ import Test.Tasty.HUnit (testCaseSteps) import Chainweb.Graph import Chainweb.Storage.Table.RocksDB (RocksDb) -import Chainweb.Test.Pact5.CmdBuilder -import Chainweb.Test.Pact5.CutFixture (advanceAllChains_) -import Chainweb.Test.Pact5.RemotePactTest hiding (tests) -import Chainweb.Test.Pact5.Utils +import Chainweb.Test.Pact.CmdBuilder +import Chainweb.Test.Pact.CutFixture (advanceAllChains_) +import Chainweb.Test.Pact.RemotePactTest hiding (tests) +import Chainweb.Test.Pact.Utils import Chainweb.Test.TestVersions import Chainweb.Test.Utils import Chainweb.Utils @@ -59,19 +59,19 @@ tests baseRdb = testGroup "Pact5 HyperlanePluginTests" ] v :: ChainwebVersion -v = pact5InstantCpmTestVersion False petersenChainGraph +v = instantCpmTestVersion False petersenChainGraph chain0 :: ChainId chain0 = unsafeChainId 0 hyperlaneValidatorAnnouncementTest :: RocksDb -> Step -> IO () -hyperlaneValidatorAnnouncementTest baseRdb step = runResourceT $ do - fx <- mkFixture v baseRdb +hyperlaneValidatorAnnouncementTest baseRdb step = withVersion v $ runResourceT $ do + fx <- mkFixture baseRdb liftIO $ do let pluginName = "hyperlane_v3_announcement" step "deploy contract" - deploy <- buildTextCmd v + deploy <- buildTextCmd $ set cbGasLimit (GasLimit (Gas 100000)) $ set cbRPC (mkExec' $ mconcat [ "(namespace 'free)" @@ -81,16 +81,16 @@ hyperlaneValidatorAnnouncementTest baseRdb step = runResourceT $ do , "(defun x () (with-capability (K \"storagelocation\" \"0x6c414e7a15088023e28af44ad0e1d593671e4b15\" \"kb-mailbox\") 1)))" ]) $ defaultCmd chain0 - send fx v chain0 [deploy] + send fx chain0 [deploy] advanceAllChains_ fx - poll fx v chain0 [cmdToRequestKey deploy] + poll fx chain0 [cmdToRequestKey deploy] >>= P.list [P.match _Just successfulTx] step "use successfully" let cap = CapToken (QualifiedName "K" (ModuleName "m" (Just (NamespaceName "free"))) ) [PString "storagelocation", PString "0x6c414e7a15088023e28af44ad0e1d593671e4b15", PString "kb-mailbox"] - usePlugin <- buildTextCmd v + usePlugin <- buildTextCmd $ set cbRPC (mkExec' "(free.m.x)") $ set cbVerifiers [Verifier @@ -106,18 +106,18 @@ hyperlaneValidatorAnnouncementTest baseRdb step = runResourceT $ do [SigCapability cap]] $ set cbGasLimit (GasLimit (Gas 100000)) $ defaultCmd chain0 - send fx v chain0 [usePlugin] + send fx chain0 [usePlugin] advanceAllChains_ fx - poll fx v chain0 [cmdToRequestKey usePlugin] + poll fx chain0 [cmdToRequestKey usePlugin] >>= P.list [P.match _Just ? P.checkAll [ successfulTx - , P.fun _crGas ? P.equals (Gas 16342) + , P.fun _crGas ? P.equals (Gas 16364) ] ] step "use with bad signature" - useBadSignature <- buildTextCmd v + useBadSignature <- buildTextCmd $ set cbRPC (mkExec' "(free.m.x)") $ set cbVerifiers [Verifier @@ -133,9 +133,9 @@ hyperlaneValidatorAnnouncementTest baseRdb step = runResourceT $ do [SigCapability cap]] $ set cbGasLimit (GasLimit (Gas 100000)) $ defaultCmd chain0 - send fx v chain0 [useBadSignature] + send fx chain0 [useBadSignature] advanceAllChains_ fx - poll fx v chain0 [cmdToRequestKey useBadSignature] + poll fx chain0 [cmdToRequestKey useBadSignature] >>= P.list [ P.match _Just ? P.checkAll [ P.fun _crResult ? P.match _PactResultErr ? P.checkAll @@ -147,7 +147,7 @@ hyperlaneValidatorAnnouncementTest baseRdb step = runResourceT $ do ] step "deploy with different signer" - deployDifferentSigner <- buildTextCmd v + deployDifferentSigner <- buildTextCmd $ set cbGasLimit (GasLimit (Gas 100000)) $ set cbRPC (mkExec' $ mconcat [ "(namespace 'free)" @@ -157,9 +157,9 @@ hyperlaneValidatorAnnouncementTest baseRdb step = runResourceT $ do , "(defun x () (with-capability (K \"storagelocation\" \"0x5c414e7a15088023e28af44ad0e1d593671e4b15\" \"kb-mailbox\") 1)))" ]) $ defaultCmd chain0 - send fx v chain0 [deployDifferentSigner] + send fx chain0 [deployDifferentSigner] advanceAllChains_ fx - poll fx v chain0 [cmdToRequestKey deployDifferentSigner] + poll fx chain0 [cmdToRequestKey deployDifferentSigner] >>= P.list [P.match _Just successfulTx] let capWrongSigner = @@ -168,7 +168,7 @@ hyperlaneValidatorAnnouncementTest baseRdb step = runResourceT $ do -- bad signer (same as from the previous test but the different first symbol) step "use with wrong signer" - useWrongSigner <- buildTextCmd v + useWrongSigner <- buildTextCmd $ set cbRPC (mkExec' "(free.m.x)") $ set cbVerifiers [Verifier @@ -184,14 +184,14 @@ hyperlaneValidatorAnnouncementTest baseRdb step = runResourceT $ do [SigCapability capWrongSigner]] $ set cbGasLimit (GasLimit (Gas 100000)) $ defaultCmd chain0 - send fx v chain0 [useWrongSigner] + send fx chain0 [useWrongSigner] advanceAllChains_ fx - poll fx v chain0 [cmdToRequestKey useWrongSigner] + poll fx chain0 [cmdToRequestKey useWrongSigner] >>= P.list [ P.match _Just ? P.checkAll [ P.fun _crResult ? P.match _PactResultErr ? P.checkAll [ P.fun _peType ? P.equals (ErrorType "EvalError") - , P.fun _peMsg ? P.equals "Incorrect signer. Expected: PLiteral (LString {_lString = \"0x6c414e7a15088023e28af44ad0e1d593671e4b15\"}) but got PLiteral (LString {_lString = \"0x5c414e7a15088023e28af44ad0e1d593671e4b15\"})" + , P.fun _peMsg ? P.equals "Incorrect signer. Expected: PLiteral (LString \"0x6c414e7a15088023e28af44ad0e1d593671e4b15\") but got PLiteral (LString \"0x5c414e7a15088023e28af44ad0e1d593671e4b15\")" ] , P.fun _crGas ? P.equals (Gas 100000) ] @@ -253,7 +253,7 @@ validSignature :: T.Text validSignature = "0xfabe80dd5bf4440e5e7fbc3cdf12325df9c00beb1281c5ddf12e77177046790c49f531ccebb29ba9c9664a581ed1870873850e0cf0c231b779e21f48a1d0dcea1b" -- | Deploys a contract with a valid signer -deployContractWith :: Fixture -> [T.Text] -> Integer -> IO () +deployContractWith :: HasVersion => Fixture -> [T.Text] -> Integer -> IO () deployContractWith fx signers threshold = do let deployCode = [ "(namespace 'free)" @@ -301,18 +301,18 @@ deployContractWith fx signers threshold = do , ")" , " \"succeeded\")))" ] - deployCmd <- buildTextCmd v + deployCmd <- buildTextCmd $ set cbRPC (mkExec' $ mconcat deployCode) $ set cbGasLimit (GasLimit $ Gas 70000) $ defaultCmd chain0 - send fx v chain0 [deployCmd] + send fx chain0 [deployCmd] advanceAllChains_ fx - poll fx v chain0 [cmdToRequestKey deployCmd] >>= + poll fx chain0 [cmdToRequestKey deployCmd] >>= P.list [P.match _Just ? successfulTx] -- | Calls '(free.m.x)' from 'deployContractWithValidSigner' -mkMerkleMetadataCallWithGas :: GasLimit -> B.ByteString -> [T.Text] -> [T.Text] -> Integer -> IO (Command T.Text) -mkMerkleMetadataCallWithGas gas merkleProof signatures signersText threshold = buildTextCmd v +mkMerkleMetadataCallWithGas :: HasVersion => GasLimit -> B.ByteString -> [T.Text] -> [T.Text] -> Integer -> IO (Command T.Text) +mkMerkleMetadataCallWithGas gas merkleProof signatures signersText threshold = buildTextCmd $ set cbGasLimit gas $ set cbVerifiers [Verifier @@ -343,15 +343,15 @@ mkMerkleMetadataCallWithGas gas merkleProof signatures signersText threshold = b $ CapToken (QualifiedName "K" (ModuleName "m" (Just (NamespaceName "free"))) ) [messageId, message, signers, PInteger threshold] -mkMerkleMetadataCall :: B.ByteString -> [T.Text] -> [T.Text] -> Integer -> IO (Command T.Text) +mkMerkleMetadataCall :: HasVersion => B.ByteString -> [T.Text] -> [T.Text] -> Integer -> IO (Command T.Text) mkMerkleMetadataCall = mkMerkleMetadataCallWithGas (GasLimit $ Gas 20000) -checkVerifierNotInTx :: Fixture -> T.Text -> IO () +checkVerifierNotInTx :: HasVersion => Fixture -> T.Text -> IO () checkVerifierNotInTx fx pluginName = do - cmd <- buildTextCmd v $ set cbRPC (mkExec' "(free.m.x)") $ defaultCmd chain0 - send fx v chain0 [cmd] + cmd <- buildTextCmd $ set cbRPC (mkExec' "(free.m.x)") $ defaultCmd chain0 + send fx chain0 [cmd] advanceAllChains_ fx - poll fx v chain0 [cmdToRequestKey cmd] >>= P.list + poll fx chain0 [cmdToRequestKey cmd] >>= P.list [ P.match _Just ? P.fun _crResult ? P.match _PactResultErr @@ -363,8 +363,8 @@ checkVerifierNotInTx fx pluginName = do ] hyperlaneVerifySuccess :: RocksDb -> Step -> IO () -hyperlaneVerifySuccess baseRdb step = runResourceT $ do - fx <- mkFixture v baseRdb +hyperlaneVerifySuccess baseRdb step = withVersion v $ runResourceT $ do + fx <- mkFixture baseRdb liftIO $ do let threshold = 1 step "deploy contract" @@ -372,20 +372,20 @@ hyperlaneVerifySuccess baseRdb step = runResourceT $ do checkVerifierNotInTx fx "hyperlane_v3_message" step "use verifier" cmd <- mkMerkleMetadataCall hyperlaneMerkleTreeCorrectProof [validSignature] [validSigner] threshold - send fx v chain0 [cmd] + send fx chain0 [cmd] advanceAllChains_ fx - poll fx v chain0 [cmdToRequestKey cmd] >>= P.list + poll fx chain0 [cmdToRequestKey cmd] >>= P.list [P.match _Just ? P.checkAll [ successfulTx - , P.fun _crGas ? P.equals (Gas 16398) + , P.fun _crGas ? P.equals (Gas 16420) ] ] hyperlaneVerifyMoreValidatorsSuccess :: RocksDb -> Step -> IO () -hyperlaneVerifyMoreValidatorsSuccess baseRdb step = runResourceT $ do - fx <- mkFixture v baseRdb +hyperlaneVerifyMoreValidatorsSuccess baseRdb step = withVersion v $ runResourceT $ do + fx <- mkFixture baseRdb liftIO $ do step "deploy contract" let threshold = 1 @@ -394,18 +394,18 @@ hyperlaneVerifyMoreValidatorsSuccess baseRdb step = runResourceT $ do checkVerifierNotInTx fx "hyperlane_v3_message" step "use verifier" cmd <- mkMerkleMetadataCall hyperlaneMerkleTreeCorrectProof [validSignature] signers threshold - send fx v chain0 [cmd] + send fx chain0 [cmd] advanceAllChains_ fx - poll fx v chain0 [cmdToRequestKey cmd] >>= P.list + poll fx chain0 [cmdToRequestKey cmd] >>= P.list [ P.match _Just ? P.checkAll [ successfulTx - , P.fun _crGas ? P.equals (Gas 16398) + , P.fun _crGas ? P.equals (Gas 16421) ] ] hyperlaneVerifyThresholdZeroError :: RocksDb -> Step -> IO () -hyperlaneVerifyThresholdZeroError baseRdb step = runResourceT $ do - fx <- mkFixture v baseRdb +hyperlaneVerifyThresholdZeroError baseRdb step = withVersion v $ runResourceT $ do + fx <- mkFixture baseRdb liftIO $ do step "deploy contract" let code = mconcat @@ -431,20 +431,20 @@ hyperlaneVerifyThresholdZeroError baseRdb step = runResourceT $ do , ")" , " \"succeeded\")))" ] - deployCmd <- buildTextCmd v + deployCmd <- buildTextCmd $ set cbRPC (mkExec' code) $ set cbGasLimit (GasLimit $ Gas 70000) $ defaultCmd chain0 - send fx v chain0 [deployCmd] + send fx chain0 [deployCmd] advanceAllChains_ fx - poll fx v chain0 [cmdToRequestKey deployCmd] >>= P.list + poll fx chain0 [cmdToRequestKey deployCmd] >>= P.list [ P.match _Just ? successfulTx ] checkVerifierNotInTx fx "hyperlane_v3_message" step "use verifier" cmd <- mkMerkleMetadataCall hyperlaneMerkleTreeCorrectProof [] [] 0 - send fx v chain0 [cmd] + send fx chain0 [cmd] advanceAllChains_ fx - poll fx v chain0 [cmdToRequestKey cmd] >>= P.list + poll fx chain0 [cmdToRequestKey cmd] >>= P.list [ P.match _Just ? P.checkAll [ P.fun _crResult @@ -458,8 +458,8 @@ hyperlaneVerifyThresholdZeroError baseRdb step = runResourceT $ do ] hyperlaneVerifyWrongSignersFailure :: RocksDb -> Step -> IO () -hyperlaneVerifyWrongSignersFailure baseRdb step = runResourceT $ do - fx <- mkFixture v baseRdb +hyperlaneVerifyWrongSignersFailure baseRdb step = withVersion v $ runResourceT $ do + fx <- mkFixture baseRdb liftIO $ do step "deploy contract" let threshold = 1 @@ -467,9 +467,9 @@ hyperlaneVerifyWrongSignersFailure baseRdb step = runResourceT $ do checkVerifierNotInTx fx "hyperlane_v3_message" step "use verifier" cmd <- mkMerkleMetadataCall hyperlaneMerkleTreeCorrectProof [validSignature] ["wrongSigner"] threshold - send fx v chain0 [cmd] + send fx chain0 [cmd] advanceAllChains_ fx - poll fx v chain0 [cmdToRequestKey cmd] >>= P.list + poll fx chain0 [cmdToRequestKey cmd] >>= P.list [ P.match _Just ? P.checkAll [ P.fun _crResult @@ -483,8 +483,8 @@ hyperlaneVerifyWrongSignersFailure baseRdb step = runResourceT $ do ] hyperlaneVerifyNotEnoughRecoveredSignaturesFailure :: RocksDb -> Step -> IO () -hyperlaneVerifyNotEnoughRecoveredSignaturesFailure baseRdb step = runResourceT $ do - fx <- mkFixture v baseRdb +hyperlaneVerifyNotEnoughRecoveredSignaturesFailure baseRdb step = withVersion v $ runResourceT $ do + fx <- mkFixture baseRdb liftIO $ do step "deploy contract" let threshold = 1 @@ -494,9 +494,9 @@ hyperlaneVerifyNotEnoughRecoveredSignaturesFailure baseRdb step = runResourceT $ step "use verifier" cmd <- mkMerkleMetadataCall hyperlaneMerkleTreeCorrectProof [] ["wrongSigner"] threshold - send fx v chain0 [cmd] + send fx chain0 [cmd] advanceAllChains_ fx - poll fx v chain0 [cmdToRequestKey cmd] >>= P.list + poll fx chain0 [cmdToRequestKey cmd] >>= P.list [ P.match _Just ? P.checkAll [ P.fun _crResult @@ -510,8 +510,8 @@ hyperlaneVerifyNotEnoughRecoveredSignaturesFailure baseRdb step = runResourceT $ ] hyperlaneVerifyNotEnoughCapabilitySignaturesFailure :: RocksDb -> Step -> IO () -hyperlaneVerifyNotEnoughCapabilitySignaturesFailure baseRdb step = runResourceT $ do - fx <- mkFixture v baseRdb +hyperlaneVerifyNotEnoughCapabilitySignaturesFailure baseRdb step = withVersion v $ runResourceT $ do + fx <- mkFixture baseRdb liftIO $ do step "deploy contract" let threshold = 2 @@ -524,9 +524,9 @@ hyperlaneVerifyNotEnoughCapabilitySignaturesFailure baseRdb step = runResourceT [validSignature, validSignature] [validSigner] threshold - send fx v chain0 [cmd] + send fx chain0 [cmd] advanceAllChains_ fx - poll fx v chain0 [cmdToRequestKey cmd] >>= P.list + poll fx chain0 [cmdToRequestKey cmd] >>= P.list [ P.match _Just ? P.checkAll [ P.fun _crResult @@ -540,8 +540,8 @@ hyperlaneVerifyNotEnoughCapabilitySignaturesFailure baseRdb step = runResourceT ] hyperlaneVerifyMerkleIncorrectProofFailure :: RocksDb -> Step -> IO () -hyperlaneVerifyMerkleIncorrectProofFailure baseRdb step = runResourceT $ do - fx <- mkFixture v baseRdb +hyperlaneVerifyMerkleIncorrectProofFailure baseRdb step = withVersion v $ runResourceT $ do + fx <- mkFixture baseRdb liftIO $ do step "deploy contract" let threshold = 1 @@ -553,9 +553,9 @@ hyperlaneVerifyMerkleIncorrectProofFailure baseRdb step = runResourceT $ do [validSignature] [validSigner] threshold - send fx v chain0 [cmd] + send fx chain0 [cmd] advanceAllChains_ fx - poll fx v chain0 [cmdToRequestKey cmd] >>= P.list + poll fx chain0 [cmdToRequestKey cmd] >>= P.list [ P.match _Just ? P.checkAll [ P.fun _crResult @@ -571,8 +571,8 @@ hyperlaneVerifyMerkleIncorrectProofFailure baseRdb step = runResourceT $ do -- | We pass 2 signatures, 1st one matches to the correct validator, -- but there is no second valid validator for the 2nd signature, and the verification fails. hyperlaneVerifyFailureNotEnoughSignaturesToPassThreshold :: RocksDb -> Step -> IO () -hyperlaneVerifyFailureNotEnoughSignaturesToPassThreshold baseRdb step = runResourceT $ do - fx <- mkFixture v baseRdb +hyperlaneVerifyFailureNotEnoughSignaturesToPassThreshold baseRdb step = withVersion v $ runResourceT $ do + fx <- mkFixture baseRdb liftIO $ do step "deploy contract" let threshold = 2 @@ -585,9 +585,9 @@ hyperlaneVerifyFailureNotEnoughSignaturesToPassThreshold baseRdb step = runResou (GasLimit $ Gas 40000) hyperlaneMerkleTreeCorrectProof [validSignature, validSignature] signers threshold - send fx v chain0 [cmd] + send fx chain0 [cmd] advanceAllChains_ fx - poll fx v chain0 [cmdToRequestKey cmd] >>= P.list + poll fx chain0 [cmdToRequestKey cmd] >>= P.list [ P.match _Just ? P.checkAll [ P.fun _crResult diff --git a/test/unit/Chainweb/Test/Pact/PactServiceTest.hs b/test/unit/Chainweb/Test/Pact/PactServiceTest.hs new file mode 100644 index 0000000000..55615da1c2 --- /dev/null +++ b/test/unit/Chainweb/Test/Pact/PactServiceTest.hs @@ -0,0 +1,742 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE ImpredicativeTypes #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NumericUnderscores #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PackageImports #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeApplications #-} + +module Chainweb.Test.Pact.PactServiceTest +( tests +) where + +import Chainweb.BlockHash (BlockHash) +import Chainweb.BlockHeader +import Chainweb.BlockHeader.Genesis.InstantTimedCPM0Payload qualified as IN0 +import Chainweb.BlockHeader.Genesis.InstantTimedCPM1to9Payload qualified as INN +import Chainweb.BlockHeight (BlockHeight) +import Chainweb.ChainId +import Chainweb.Chainweb +import Chainweb.Core.Brief +import Chainweb.Cut +import Chainweb.Graph (singletonChainGraph) +import Chainweb.Logger +import Chainweb.Pact.Backend.Types (throwIfNoHistory, Historical) +import Chainweb.Pact.Mempool.InMem qualified as Mempool +import Chainweb.Pact.Mempool.Mempool qualified as Mempool +import Chainweb.Pact.PactService qualified as PactService +import Chainweb.Pact.PactService.Checkpointer qualified as Checkpointer +import Chainweb.Pact.PactService.ExecBlock qualified as PactService +import Chainweb.Pact.Payload +import Chainweb.Pact.Transaction qualified as Pact +import Chainweb.Pact.Types +import Chainweb.Parent +import Chainweb.PayloadProvider +import Chainweb.PayloadProvider.Pact (pactMemPoolAccess) +import Chainweb.Storage.Table.RocksDB +import Chainweb.Test.Cut.TestBlockDb (TestBlockDb (_bdbPayloadDb), addTestBlockDb, getCutTestBlockDb, getParentTestBlockDb, mkTestBlockDb, setCutTestBlockDb) +import Chainweb.Test.Pact.CmdBuilder +import Chainweb.Test.Pact.Utils +import Chainweb.Test.TestVersions +import Chainweb.Test.Utils +import Chainweb.Time +import Chainweb.Utils +import Chainweb.Version +import Control.Concurrent.Async (forConcurrently) +import Control.Lens hiding (only) +import Control.Monad +import Control.Monad.IO.Class +import Control.Monad.Trans.Resource +import Data.ByteString.Lazy qualified as LBS +import Data.ByteString.Short qualified as SB +import Data.Decimal +import Data.Foldable (toList) +import Data.HashMap.Strict (HashMap) +import Data.HashMap.Strict qualified as HashMap +import Data.HashSet qualified as HashSet +import Data.List qualified as List +import Data.Pool qualified as Pool +import Data.Text qualified as T +import Data.Text.IO qualified as Text +import Data.Vector (Vector) +import Data.Vector qualified as Vector +import Pact.Core.Capabilities +import Pact.Core.ChainData (TxCreationTime (..)) +import Pact.Core.Command.Types hiding (ChainId) +import Pact.Core.Gas.Types +import Pact.Core.Hash qualified as Pact +import Pact.Core.Names +import Pact.Core.PactValue +import PropertyMatchers ((?)) +import PropertyMatchers qualified as P +import Test.Tasty +import Test.Tasty.HUnit (assertBool, assertEqual, testCase) +import Text.Printf (printf) + +data Fixture = Fixture + { _fixtureBlockDb :: TestBlockDb + , _fixtureLogger :: GenericLogger + , _fixtureMempools :: ChainMap (Mempool.MempoolBackend Pact.Transaction) + , _fixturePacts :: ChainMap (ServiceEnv RocksDbTable) + } + +v :: ChainwebVersion +v = instantCpmTestVersion False singletonChainGraph + +mkFixtureWith :: PactServiceConfig -> RocksDb -> ResourceT IO Fixture +mkFixtureWith pactServiceConfig baseRdb = withVersion v $ do + tdb <- mkTestBlockDb baseRdb + logLevel <- liftIO getTestLogLevel + let logger = genericLogger logLevel Text.putStrLn + perChain <- iforM (HashSet.toMap chainIds) $ \chain () -> do + (writeSqlite, readPool) <- withTempChainSqlite chain + let pdb = _bdbPayloadDb tdb + serviceEnv <- PactService.withPactService chain Nothing mempty logger Nothing pdb readPool writeSqlite pactServiceConfig (GenesisPayload $ genesisPayload chain) + let mempoolCfg = + validatingMempoolConfig chain + (GasLimit (Gas 150_000)) + (GasPrice 1e-8) + (PactService.execPreInsertCheckReq logger serviceEnv) + mempool <- liftIO $ Mempool.startInMemoryMempoolTest mempoolCfg + let mempoolAccess = pactMemPoolAccess mempool logger + return (mempool, serviceEnv & psMempoolAccess .~ mempoolAccess) + let fixture = Fixture + { _fixtureBlockDb = tdb + , _fixtureLogger = logger + , _fixtureMempools = ChainMap $ fst <$> perChain + , _fixturePacts = ChainMap $ snd <$> perChain + } + -- The mempool expires txs based on current time, but newBlock expires txs based on parent creation time. + -- So by running an empty block with the creationTime set to the current time, we get these goals to align + -- for future blocks we run. + _ <- liftIO $ advanceAllChains fixture $ onChains [] + return fixture + +genesisPayload :: ChainId -> PayloadWithOutputs +genesisPayload chain = + if chain == unsafeChainId 0 + then IN0.payloadBlock + else INN.payloadBlock + +mkFixture :: RocksDb -> ResourceT IO Fixture +mkFixture baseRdb = do + mkFixtureWith defaultPactServiceConfig baseRdb + +tests :: RocksDb -> TestTree +tests baseRdb = testGroup "Pact5 PactServiceTest" + [ testCase "simple end to end" (simpleEndToEnd baseRdb) + , testCase "continue block spec" (continueBlockSpec baseRdb) + , testCase "new block empty" (newBlockEmpty baseRdb) + , testCase "new block timeout spec" (newBlockTimeoutSpec baseRdb) + , testCase "new block excludes invalid transactions" (testNewBlockExcludesInvalid baseRdb) + , testCase "lookup pact txs spec" (lookupPactTxsSpec baseRdb) + , testCase "failed txs should go into blocks" (failedTxsShouldGoIntoBlocks baseRdb) + , testCase "modules with higher level transitive dependencies (simple)" (modulesWithHigherLevelTransitiveDependenciesSimple baseRdb) + , testCase "modules with higher level transitive dependencies (complex)" (modulesWithHigherLevelTransitiveDependenciesComplex baseRdb) + ] + +-- TODO PP: +-- test: +-- 1. block refreshing (maybe just wait on the tvar) +-- 2. multiple-block play +-- 3. pure rewinds + +simpleEndToEnd :: RocksDb -> IO () +simpleEndToEnd baseRdb = withVersion v $ runResourceT $ do + fixture <- mkFixture baseRdb + liftIO $ do + cmd1 <- buildCwCmd (transferCmd 1.0) + cmd2 <- buildCwCmd (transferCmd 2.0) + + results <- advanceAllChainsWithTxs fixture $ onChain chain0 [cmd1, cmd2] + + -- we only care that they succeed; specifics regarding their outputs are in TransactionExecTest + results & + P.alignExact ? onChain chain0 ? + P.alignExact ? Vector.replicate 2 successfulTx + +newBlockEmpty :: RocksDb -> IO () +newBlockEmpty baseRdb = withVersion v $ runResourceT $ do + fixture <- mkFixture baseRdb + liftIO $ do + cmd <- buildCwCmd (transferCmd 1.0) + mempoolInsert fixture chain0 Mempool.CheckedInsert [cmd] + _ <- advanceAllChains fixture $ onChain chain0 $ \ph -> do + finalizeBlock fixture <$> makeEmptyBlock fixture ph + + results <- advanceAllChains fixture $ onChain chain0 $ \ph -> do + block <- continueBlock fixture =<< makeEmptyBlock fixture ph + return $ finalizeBlock fixture block + + results & + P.alignExact ? onChain chain0 ? + P.alignExact ? Vector.replicate 1 successfulTx + +continueBlockSpec :: RocksDb -> IO () +continueBlockSpec baseRdb = withVersion v $ runResourceT $ do + fixture <- mkFixture baseRdb + liftIO $ do + startCut <- getCut fixture + + -- construct some transactions that we plan to put into the block + cmd1 <- buildCwCmd (transferCmd 1.0) + cmd2 <- buildCwCmd (transferCmd 2.0) + cmd3 <- buildCwCmd (transferCmd 3.0) + + -- insert all transactions + mempoolInsert fixture chain0 Mempool.CheckedInsert [cmd1, cmd2, cmd3] + allAtOnceResults <- advanceAllChains fixture $ onChain chain0 $ \ph -> do + -- construct a new block with all of said transactions + bipAllAtOnce <- continueBlock fixture =<< makeEmptyBlock fixture ph + return $ finalizeBlock fixture bipAllAtOnce + -- assert that 3 successful txs are in the block + allAtOnceResults & + P.alignExact ? onChain chain0 ? + P.alignExact ? Vector.replicate 3 successfulTx + + -- reset back to the empty block for the next phase + -- next, produce the same block by repeatedly extending a block + -- with the same transactions as were included in the original. + -- note that this will reinsert all txs in the full block into the + -- mempool, so we need to clear it after, or else the block will + -- contain all of the transactions before we extend it. + revert fixture startCut + mempoolClear fixture chain0 + continuedResults <- advanceAllChains fixture $ onChain chain0 $ \ph -> do + mempoolInsert fixture chain0 Mempool.CheckedInsert [cmd3] + bipStart <- continueBlock fixture =<< makeEmptyBlock fixture ph + + mempoolInsert fixture chain0 Mempool.CheckedInsert [cmd2] + bipContinued <- continueBlock fixture bipStart + + mempoolInsert fixture chain0 Mempool.CheckedInsert [cmd1] + bipFinal <- continueBlock fixture bipContinued + + -- We must make progress on the same parent header + assertEqual "same block context after continuing block" + (_blockInProgressBlockCtx bipStart) + (_blockInProgressBlockCtx bipContinued) + assertBool "made progress (1)" + (bipStart /= bipContinued) + assertEqual "same block context after finishing block" + (_blockInProgressBlockCtx bipContinued) + (_blockInProgressBlockCtx bipFinal) + assertBool "made progress (2)" + (bipContinued /= bipFinal) + + return $ finalizeBlock fixture bipFinal + + -- assert that the continued results are equal to doing it all at once + continuedResults & P.equals allAtOnceResults + +-- -- * test that the NewBlock timeout works properly and doesn't leave any extra state from a timed-out transaction +newBlockTimeoutSpec :: RocksDb -> IO () +newBlockTimeoutSpec baseRdb = withVersion v $ runResourceT $ do + let pactServiceConfig = defaultPactServiceConfig + { _pactTxTimeLimit = Just (Micros 35_000) + -- this may need to be tweaked for CI. + -- it should be long enough that `timeoutTx` times out + -- but neither `tx1` nor `tx2` time out. + , _pactNewBlockGasLimit = GasLimit (Gas 2000000) + } + fixture <- mkFixtureWith pactServiceConfig baseRdb + + liftIO $ do + tx1 <- buildCwCmd (defaultCmd chain0) + { _cbRPC = mkExec' "1" + , _cbGasPrice = GasPrice 1.0 + , _cbGasLimit = GasLimit (Gas 400) + } + tx2 <- buildCwCmd (defaultCmd chain0) + { _cbRPC = mkExec' "2" + , _cbGasPrice = GasPrice 2.0 + , _cbGasLimit = GasLimit (Gas 400) + } + timeoutTx <- buildCwCmd (defaultCmd chain0) + { _cbRPC = mkExec' $ "(fold + 0 (enumerate 1 10000000))" + , _cbGasPrice = GasPrice 1.5 + , _cbGasLimit = GasLimit (Gas 130000) + } + + results <- advanceAllChains fixture $ onChain chain0 $ \ph -> do + mempoolInsert fixture chain0 Mempool.CheckedInsert [tx2, timeoutTx, tx1] + bip <- continueBlock fixture =<< makeEmptyBlock fixture ph + return $ finalizeBlock fixture bip + results + & P.alignExact ? tabulateChains (\cid -> + if cid == chain0 + then P.alignExact ? Vector.singleton ? + -- Mempool orders by GasPrice. 'buildCwCmd' sets the gas price to the transfer amount. + -- We hope for 'timeoutTx' to fail, meaning that only 'txTransfer2' is in the block. + P.checkAll + [ P.fun _crReqKey ? P.equals (cmdToRequestKey tx2) + , successfulTx + ] + else P.equals Vector.empty + ) + pure () + +testNewBlockExcludesInvalid :: RocksDb -> IO () +testNewBlockExcludesInvalid baseRdb = withVersion v $ runResourceT $ do + fixture <- mkFixture baseRdb + liftIO $ do + -- The mempool should reject a tx that doesn't parse as valid pact. + -- TODO PP: let's test this in the mempool + pact REST API tests + -- badParse <- buildCwCmd (defaultCmd chain0) + -- { _cbRPC = mkExec' "(not a valid pact tx" + -- } + + regularTx1 <- buildCwCmd $ transferCmd 1.0 + -- The mempool checks that a tx does not already exist in the chain before adding it. + let badUnique = regularTx1 + + -- The mempool checks that a tx does not have a creation time too far into the future. + badFuture <- buildCwCmd $ (transferCmd 1.0) + { _cbCreationTime = Just $ TxCreationTime (2 ^ (32 :: Word)) + } + + -- The mempool checks that a tx does not have a creation time too far into the past. + badPast <- buildCwCmd $ (transferCmd 1.0) + { _cbCreationTime = Just $ TxCreationTime 0 + } + + regularTx2 <- buildCwCmd $ transferCmd 1.0 + -- The mempool checks that a tx has a valid hash. + let badTxHash = regularTx2 + { _cmdHash = Pact.hash "wrong string" + } + + badSigs <- buildCwCmdNoSigCheck (defaultCmd chain0) + { _cbSigners = + [ CmdSigner + { _csSigner = Signer + { _siScheme = Nothing + , _siPubKey = fst sender00 + , _siAddress = Nothing + , _siCapList = [] + } + , _csPrivKey = snd sender01 + } + ] + } + + badChain <- buildCwCmd $ transferCmd 1.0 & set cbChainId (toText $ unsafeChainId 1) + + _ <- advanceAllChains fixture $ onChain chain0 $ \ph -> do + mempoolInsert fixture chain0 Mempool.CheckedInsert [regularTx1] + finalizeBlock fixture <$> makeFilledBlock fixture ph + + _ <- advanceAllChains fixture $ onChain chain0 $ \ph -> do + mempoolInsert fixture chain0 Mempool.UncheckedInsert [badSigs] + mempoolInsert fixture chain0 Mempool.UncheckedInsert [badChain, badUnique, badFuture, badPast, badTxHash] + bip <- makeFilledBlock fixture ph + let expectedTxs = [] + let actualTxs = + Vector.toList $ + Vector.map (unRequestKey . _crReqKey . ssnd) $ + _transactionPairs (_blockInProgressTransactions bip) + assertEqual "block has excluded all invalid transactions" expectedTxs actualTxs + return $ finalizeBlock fixture bip + + -- we need to wait until this above block is validate for `badUnique` + -- to disappear, because only the parent block is used to find txs to + -- delete from the mempool + let mempool = _fixtureMempools fixture ^?! atChain chain0 + mempoolInsert fixture chain0 Mempool.CheckedInsert [badUnique, badFuture, badPast, badTxHash] + + let badTxHashes = Vector.fromList $ fmap Mempool.pactRequestKeyToTransactionHash + [ cmdToRequestKey badUnique + , cmdToRequestKey badFuture + , cmdToRequestKey badPast + , cmdToRequestKey badTxHash + , cmdToRequestKey badSigs + ] + + inMempool <- Mempool.mempoolLookup mempool badTxHashes + let badTxsInMempool = + [ i + | (i, Mempool.Pending _) <- zip [0 :: Word ..] (Vector.toList inMempool) + ] + badTxsInMempool & P.equals [] + return () + +lookupPactTxsSpec :: RocksDb -> IO () +lookupPactTxsSpec baseRdb = withVersion v $ runResourceT $ do + fixture <- mkFixture baseRdb + liftIO $ do + cmd1 <- buildCwCmd (transferCmd 1.0) + cmd2 <- buildCwCmd (transferCmd 2.0) + + -- Depth 0 + _ <- advanceAllChains fixture $ onChain chain0 $ \ph -> do + mempoolInsert fixture chain0 Mempool.CheckedInsert [cmd1, cmd2] + bip <- makeFilledBlock fixture ph + return $ finalizeBlock fixture bip + + let rks = List.sort $ List.map _cmdHash [cmd1, cmd2] + + let lookupExpect :: Maybe Word -> IO () + lookupExpect depth = do + txs <- throwIfNoHistory =<< lookupPactTxs fixture chain0 (fmap (ConfirmationDepth . fromIntegral) depth) (Vector.fromList rks) + assertEqual ("all txs should be available with depth=" ++ show depth) + (HashSet.fromList (Pact.unHash <$> rks)) (HashMap.keysSet txs) + let lookupDontExpect :: Maybe Word -> IO () + lookupDontExpect depth = do + txs <- throwIfNoHistory =<< lookupPactTxs fixture chain0 (fmap (ConfirmationDepth. fromIntegral) depth) (Vector.fromList rks) + assertEqual ("no txs should be available with depth=" ++ show depth) + HashSet.empty (HashMap.keysSet txs) + + lookupExpect Nothing + lookupExpect (Just 0) + lookupDontExpect (Just 1) + + -- Depth 1 + _ <- advanceAllChains fixture $ onChains [] + + lookupExpect Nothing + lookupExpect (Just 0) + lookupExpect (Just 1) + lookupDontExpect (Just 2) + + -- Depth 2 + _ <- advanceAllChains fixture $ onChains [] + + lookupExpect Nothing + lookupExpect (Just 0) + lookupExpect (Just 1) + lookupExpect (Just 2) + lookupDontExpect (Just 3) + +failedTxsShouldGoIntoBlocks :: RocksDb -> IO () +failedTxsShouldGoIntoBlocks baseRdb = withVersion v $ runResourceT $ do + fixture <- mkFixture baseRdb + + liftIO $ do + cmd1 <- buildCwCmd (transferCmd 1.0) + cmd2 <- buildCwCmd (defaultCmd chain0) + { _cbRPC = mkExec' "(namespace 'free) (module mod G (defcap G () true) (defun f () true)) (describe-module \"free.mod\")" + -- for ordering the transactions as they appear in the block + , _cbGasPrice = GasPrice 0.1 + , _cbGasLimit = GasLimit (Gas 1000) + } + + -- Depth 0 + _ <- advanceAllChains fixture $ onChain chain0 $ \ph -> do + mempoolInsert fixture chain0 Mempool.CheckedInsert [cmd1, cmd2] + bip <- makeFilledBlock fixture ph + let block = finalizeBlock fixture bip + assertEqual "block has 2 txs even though one of them failed" 2 (Vector.length $ _payloadWithOutputsTransactions block) + return block + + return () + +modulesWithHigherLevelTransitiveDependenciesSimple :: RocksDb -> IO () +modulesWithHigherLevelTransitiveDependenciesSimple baseRdb = withVersion v $ runResourceT $ do + fixture <- mkFixture baseRdb + liftIO $ do + cmd1 <- buildCwCmd (defaultCmd chain0) + { _cbRPC = mkExec' "(namespace 'free) (interface barbar (defconst FOO_CONST:integer 1))" + -- for ordering the transactions as they appear in the block + , _cbGasPrice = GasPrice 0.9 + , _cbGasLimit = GasLimit (Gas 1000) + } + cmd2 <- buildCwCmd (defaultCmd chain0) + { _cbRPC = mkExec' "(namespace 'free) (module foo g (defcap g () true) (defun calls-foo () barbar.FOO_CONST))" + -- for ordering the transactions as they appear in the block + , _cbGasPrice = GasPrice 0.8 + , _cbGasLimit = GasLimit (Gas 1000) + } + cmd3 <- buildCwCmd (defaultCmd chain0) + { _cbRPC = mkExec' "(namespace 'free) (module bar g (defcap g () true) (defun calls-bar () (foo.calls-foo)))" + -- for ordering the transactions as they appear in the block + , _cbGasPrice = GasPrice 0.7 + , _cbGasLimit = GasLimit (Gas 1000) + } + cmd4 <- buildCwCmd (defaultCmd chain0) + { _cbRPC = mkExec' "(namespace 'free) (module baz g (defcap g () true) (defun calls-baz () (bar.calls-bar)))" + -- for ordering the transactions as they appear in the block + , _cbGasPrice = GasPrice 0.6 + , _cbGasLimit = GasLimit (Gas 1000) + } + cmd5 <- buildCwCmd (defaultCmd chain0) + { _cbRPC = mkExec' "(namespace 'free) (baz.calls-baz)" + -- for ordering the transactions as they appear in the block + , _cbGasPrice = GasPrice 0.5 + , _cbGasLimit = GasLimit (Gas 1000) + } + + results <- advanceAllChains fixture $ onChain chain0 $ \ph -> do + mempoolInsert fixture chain0 Mempool.CheckedInsert [cmd1, cmd2, cmd3, cmd4, cmd5] + bip <- makeFilledBlock fixture ph + let block = finalizeBlock fixture bip + return block + + results & + P.alignExact ? onChain chain0 ? + P.alignExact ? Vector.replicate 5 successfulTx + + results & + P.alignExact ? onChain chain0 ? + P.alignExact ? Vector.fromList + [ P.fun _crGas ? P.equals (Gas 196) + , P.fun _crGas ? P.equals (Gas 328) + , P.fun _crGas ? P.equals (Gas 371) + , P.fun _crGas ? P.equals (Gas 412) + , P.fun _crGas ? P.equals (Gas 103) + ] + + return () + +modulesWithHigherLevelTransitiveDependenciesComplex :: RocksDb -> IO () +modulesWithHigherLevelTransitiveDependenciesComplex baseRdb = withVersion v $ runResourceT $ do + fixture <- mkFixture baseRdb + liftIO $ do + cmd1 <- buildCwCmd (defaultCmd chain0) + { _cbRPC = mkExec' "(namespace 'free) (interface barbar (defconst FOO_CONST:integer 1))" + -- for ordering the transactions as they appear in the block + , _cbGasPrice = GasPrice 0.9 + , _cbGasLimit = GasLimit (Gas 1000) + } + cmd2 <- buildCwCmd (defaultCmd chain0) + { _cbRPC = mkExec' $ T.unlines + [ "(namespace 'free)" + , "(module foo g" + , " (defcap g () true)" + , " (defun calls-foo (sender:string amount:integer)" + , " (with-capability (FOO_MANAGED sender amount)" + , " (with-capability (FOO_CAP)" + , " barbar.FOO_CONST" + , " )" + , " )" + , " )" + , " (defcap FOO_CAP () true)" + , "" + , " (defun foo-mgr (a:integer b:integer) (+ a b))" + , "" + , " (defcap FOO_MANAGED (sender:string a:integer)" + , " @managed a foo-mgr" + , " true" + , " )" + , " )" + ] + -- for ordering the transactions as they appear in the block + , _cbGasPrice = GasPrice 0.8 + , _cbGasLimit = GasLimit (Gas 1000) + } + cmd3 <- buildCwCmd (defaultCmd chain0) + { _cbRPC = mkExec' "(namespace 'free) (module bar g (defcap g () true) (defun calls-bar () (install-capability (foo.FOO_MANAGED \"bob\" 100)) (foo.calls-foo \"bob\" 100)))" + -- for ordering the transactions as they appear in the block + , _cbGasPrice = GasPrice 0.7 + , _cbGasLimit = GasLimit (Gas 1000) + } + cmd4 <- buildCwCmd (defaultCmd chain0) + { _cbRPC = mkExec' "(namespace 'free) (module baz g (defcap g () true) (defun calls-baz () (bar.calls-bar)))" + -- for ordering the transactions as they appear in the block + , _cbGasPrice = GasPrice 0.6 + , _cbGasLimit = GasLimit (Gas 1000) + } + cmd5 <- buildCwCmd (defaultCmd chain0) + { _cbRPC = mkExec' "(namespace 'free) (baz.calls-baz)" + -- for ordering the transactions as they appear in the block + , _cbGasPrice = GasPrice 0.5 + , _cbGasLimit = GasLimit (Gas 1000) + } + + results <- advanceAllChains fixture $ onChain chain0 $ \ph -> do + mempoolInsert fixture chain0 Mempool.CheckedInsert [cmd1, cmd2, cmd3, cmd4, cmd5] + bip <- makeFilledBlock fixture ph + let block = finalizeBlock fixture bip + return block + + results & + P.alignExact ? onChain chain0 ? + P.alignExact ? Vector.replicate 5 successfulTx + + results & + P.alignExact ? onChain chain0 ? + P.alignExact ? Vector.fromList + [ P.fun _crGas ? P.equals (Gas 196) + , P.fun _crGas ? P.equals (Gas 737) + , P.fun _crGas ? P.equals (Gas 670) + , P.fun _crGas ? P.equals (Gas 641) + , P.fun _crGas ? P.equals (Gas 104) + ] + + return () + +-- {- +-- tests = do +-- -- * test that ValidateBlock does a destructive rewind to the parent of the block being validated +-- -- * test ValidateBlock's behavior if its parent doesn't exist in the chain database + +-- do +-- -- * test that read-only replay gives results that agree with running the block +-- blocks <- doBlocks (replicate 10 [tx1, tx2]) + +-- -- * test that read-only replay fails with the block missing + + +-- -- * test that PreInsertCheck does a Pact 5 check after the fork and Pact 4 check before the fork +-- -- +-- -- * test that the mempool only gives valid transactions +-- -- * test that blocks fit the block gas limit always +-- -- * test that blocks can include txs even if their gas limits together exceed that block gas limit +-- -} + +chain0 :: ChainId +chain0 = unsafeChainId 0 + +finalizeBlock :: HasVersion => Fixture -> BlockInProgress -> PayloadWithOutputs +finalizeBlock Fixture{..} bip = + toPayloadWithOutputs + (fromJuste $ _psMiner $ _fixturePacts ^?! atChain (_chainId bip)) + (_blockInProgressTransactions bip) + +makeEmptyBlock :: HasVersion => Fixture -> Parent BlockHeader -> IO BlockInProgress +makeEmptyBlock Fixture{..} ph = do + Pool.withResource (_psReadSqlPool serviceEnv) $ \roSql -> do + (throwIfNoHistory =<<) $ + Checkpointer.readFrom _fixtureLogger cid roSql (view blockCreationTime <$> ph) (view rankedBlockHash <$> ph) $ + Checkpointer.readPact5 "unexpected Pact 4" $ \blockEnv initialBlockHandle -> + PactService.makeEmptyBlock _fixtureLogger serviceEnv blockEnv initialBlockHandle + where + cid = _chainId ph + serviceEnv = _fixturePacts ^?! atChain cid + +continueBlock :: HasVersion => Fixture -> BlockInProgress -> IO BlockInProgress +continueBlock Fixture{..} bip = do + Pool.withResource (_psReadSqlPool serviceEnv) $ \roSql -> do + (throwIfNoHistory =<<) $ + Checkpointer.readFrom _fixtureLogger cid roSql parentCreationTime parentRankedHash $ + Checkpointer.readPact5 "unexpected Pact 4" $ \blockEnv _initialBlockHandle -> + PactService.continueBlock _fixtureLogger serviceEnv (_psBlockDbEnv blockEnv) bip + where + parentCreationTime = (_bctxParentCreationTime $ _blockInProgressBlockCtx bip) + parentRankedHash = (_bctxParentRankedBlockHash $ _blockInProgressBlockCtx bip) + cid = _chainId bip + serviceEnv = _fixturePacts ^?! atChain cid + +makeFilledBlock :: HasVersion => Fixture -> Parent BlockHeader -> IO BlockInProgress +makeFilledBlock fixture ph = continueBlock fixture =<< makeEmptyBlock fixture ph + +lookupPactTxs :: HasVersion => Fixture -> ChainId -> Maybe ConfirmationDepth -> Vector Pact.Hash -> IO (Historical (HashMap SB.ShortByteString (T3 BlockHeight BlockPayloadHash BlockHash))) +lookupPactTxs Fixture{..} chain depth hashes = + PactService.execLookupPactTxs _fixtureLogger (_fixturePacts ^?! atChain chain) depth (Pact.unHash <$> hashes) + +mempoolInsert :: Foldable f => Fixture -> ChainId -> Mempool.InsertType -> f Pact.Transaction -> IO () +mempoolInsert Fixture{..} cid insertType txs = + Mempool.mempoolInsert (_fixtureMempools ^?! atChain cid) insertType (Vector.fromList $ toList txs) + +mempoolClear :: Fixture -> ChainId -> IO () +mempoolClear Fixture{..} cid = + Mempool.mempoolClear (_fixtureMempools ^?! atChain cid) + +advanceAllChainsWithTxs + :: HasVersion + => Fixture -> ChainMap [Pact.Transaction] -> IO (ChainMap (Vector TestPact5CommandResult)) +advanceAllChainsWithTxs fixture txsPerChain = do + advanceAllChains fixture $ tabulateChains $ \cid ph -> do + let txs = txsPerChain ^?! atChain cid + mempoolClear fixture cid + mempoolInsert fixture cid Mempool.CheckedInsert txs + filledBlock <- makeFilledBlock fixture ph + return $ finalizeBlock fixture filledBlock + +-- this mines a block on *all chains*. if you don't specify a payload on a chain, +-- it adds empty blocks! +advanceAllChains + :: HasVersion + => Fixture + -> ChainMap (Parent BlockHeader -> IO PayloadWithOutputs) + -> IO (ChainMap (Vector TestPact5CommandResult)) +advanceAllChains fixture@Fixture{..} blocks = do + commandResults <- + forConcurrently (HashSet.toList chainIds) $ \c -> do + ph <- getParentTestBlockDb _fixtureBlockDb c + creationTime <- getCurrentTimeIntegral + let serviceEnv = _fixturePacts ^?! atChain c + payload <- case blocks ^? atChain c of + Nothing -> finalizeBlock fixture <$> makeEmptyBlock fixture ph + Just mkBlockOn -> mkBlockOn ph + added <- addTestBlockDb _fixtureBlockDb + (childBlockHeight c $ view rankedBlockHash <$> ph) + (Nonce 0) + (\_ _ -> creationTime) + c + payload + when (not added) $ + error "failed to mine block" + ph' <- getParentTestBlockDb _fixtureBlockDb c + let forkInfo = blockToForkInfo (unwrapParent ph') ph Nothing + cs' <- PactService.syncToFork _fixtureLogger serviceEnv Nothing forkInfo + -- we always want the sync to succeed + brief cs' + & P.equals (brief (_forkInfoTargetState forkInfo)) + commandResults :: Vector TestPact5CommandResult + <- forM + (_payloadWithOutputsTransactions payload) + (decodeOrThrow' + . LBS.fromStrict + . _transactionOutputBytes + . snd) + -- assert on the command results + return (c, commandResults) + + return (onChains commandResults) + +blockToForkInfo :: HasVersion => BlockHeader -> Parent BlockHeader -> Maybe NewBlockCtx -> ForkInfo +blockToForkInfo bh ph newBlockCtx = ForkInfo + { _forkInfoTrace = + [ConsensusPayload (view blockPayloadHash bh) Nothing <$ + blockHeaderToEvaluationCtx ph] + , _forkInfoBasePayloadHash = view blockPayloadHash <$> ph + , _forkInfoTargetState = ConsensusState syncState syncState syncState + , _forkInfoNewBlockCtx = newBlockCtx + } + where + syncState = syncStateOfBlockHeader bh + +getCut :: HasVersion => Fixture -> IO Cut +getCut Fixture{..} = getCutTestBlockDb _fixtureBlockDb + +revert :: HasVersion => Fixture -> Cut -> IO () +revert Fixture{..} c = do + setCutTestBlockDb _fixtureBlockDb c + forM_ (HashSet.toList chainIds) $ \chain -> do + ph <- getParentTestBlockDb _fixtureBlockDb chain + let syncState = syncStateOfBlockHeader (unwrapParent ph) + let serviceEnv = _fixturePacts ^?! atChain chain + let consensusState = ConsensusState syncState syncState syncState + cs' <- PactService.syncToFork _fixtureLogger serviceEnv Nothing ForkInfo + { _forkInfoTrace = [] + , _forkInfoBasePayloadHash = view blockPayloadHash <$> ph + , _forkInfoTargetState = consensusState + , _forkInfoNewBlockCtx = Nothing + } + cs' & P.equals consensusState + +transferCmd :: Decimal -> CmdBuilder +transferCmd transferAmount = (defaultCmd chain0) + { _cbRPC = mkExec' $ + "(coin.transfer \"sender00\" \"sender01\" " <> + -- if the number doesn't end with a decimal part, even if it's zero, Pact will + -- throw an error + T.pack (printf "%.4f" (realToFrac transferAmount :: Double)) <> + ")" + , _cbSigners = + [ mkEd25519Signer' sender00 + [ CapToken (QualifiedName "GAS" (ModuleName "coin" Nothing)) [] + , CapToken (QualifiedName "TRANSFER" coinModuleName) [PString "sender00", PString "sender01", PDecimal transferAmount] + ] + ] + -- for ordering the transactions as they appear in the block + , _cbGasPrice = GasPrice transferAmount + , _cbGasLimit = GasLimit (Gas 1000) + } diff --git a/test/unit/Chainweb/Test/Pact5/RemotePactTest.hs b/test/unit/Chainweb/Test/Pact/RemotePactTest.hs similarity index 54% rename from test/unit/Chainweb/Test/Pact5/RemotePactTest.hs rename to test/unit/Chainweb/Test/Pact/RemotePactTest.hs index 7c4f2c7cf3..e011953516 100644 --- a/test/unit/Chainweb/Test/Pact5/RemotePactTest.hs +++ b/test/unit/Chainweb/Test/Pact/RemotePactTest.hs @@ -1,58 +1,77 @@ -{-# language - ConstraintKinds - , DataKinds - , DeriveAnyClass - , DerivingStrategies - , FlexibleContexts - , FlexibleInstances - , ImplicitParams - , ImportQualifiedPost - , ImpredicativeTypes - , LambdaCase - , MultiParamTypeClasses - , NamedFieldPuns - , NumericUnderscores - , OverloadedStrings - , PackageImports - , PartialTypeSignatures - , PatternSynonyms - , RecordWildCards - , ScopedTypeVariables - , TemplateHaskell - , TupleSections - , TypeApplications - , UndecidableInstances - , ViewPatterns -#-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE ImplicitParams #-} +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE ImpredicativeTypes #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE NumericUnderscores #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PackageImports #-} +{-# LANGUAGE PartialTypeSignatures #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE ViewPatterns #-} -- temporary {-# OPTIONS_GHC -Wno-partial-type-signatures #-} -module Chainweb.Test.Pact5.RemotePactTest - ( tests - , mkFixture - , Fixture(..) - , HasFixture(..) - , poll - , pollWithDepth - , PollException(..) - , ClientException(..) - , _FailureResponse - , send - , local - , textContains - ) where - +module Chainweb.Test.Pact.RemotePactTest +( tests +, mkFixture +, Fixture(..) +, HasFixture(..) +, poll +, pollWithDepth +, PollException(..) +, ClientException(..) +, _FailureResponse +, send +, local +, textContains +) where + +import Chainweb.BlockHeader.Genesis.InstantTimedCPM0Payload qualified as IN0 +import Chainweb.BlockHeader.Genesis.InstantTimedCPM1to9Payload qualified as INN +import Chainweb.ChainId +import Chainweb.CutDB.RestAPI.Server (someCutGetServer) +import Chainweb.Graph (petersenChainGraph, singletonChainGraph, twentyChainGraph) +import Chainweb.Pact.Mempool.Mempool (TransactionHash (..)) +import Chainweb.Pact.Payload +import Chainweb.Pact.RestAPI.Client +import Chainweb.Pact.RestAPI.Server +import Chainweb.Pact.Types +import Chainweb.RestAPI.Utils (someServerApplication) +import Chainweb.Storage.Table.RocksDB +import Chainweb.Test.Pact.CmdBuilder +import Chainweb.Test.Pact.CutFixture (advanceAllChains, advanceAllChains_, advanceToForkHeight) +import Chainweb.Test.Pact.CutFixture qualified as CutFixture +import Chainweb.Test.Pact.Utils +import Chainweb.Test.TestVersions +import Chainweb.Test.Utils +import Chainweb.Utils +import Chainweb.Version +import Chainweb.Version.Mainnet (mainnet) import Control.Concurrent.Async hiding (poll) import Control.Exception (evaluate) import Control.Exception.Safe import Control.Lens -import Control.Monad (replicateM_, when) +import Control.Monad (replicateM_) import Control.Monad.IO.Class (liftIO) import Control.Monad.Trans.Resource (ResourceT, allocate, runResourceT) import Data.Aeson qualified as A -import Data.Aeson.Lens qualified as A import Data.Aeson.KeyMap qualified as A.KeyMap +import Data.Aeson.Lens qualified as A import Data.ByteString.Base16 qualified as B16 import Data.Foldable (forM_, traverse_) import Data.HashMap.Strict qualified as HashMap @@ -64,9 +83,8 @@ import Data.Maybe (fromMaybe) import Data.Set qualified as S import Data.Text (Text) import Data.Text qualified as T -import Data.Text.IO qualified as T -import Pact.JSON.Encode (getJsonText) import Data.Text.Encoding qualified as T +import Data.Text.IO qualified as T import Data.Text.Lazy qualified as TL import Data.Text.Lazy.Encoding qualified as TL import Data.Vector qualified as V @@ -80,19 +98,12 @@ import Network.TLS qualified as TLS import Network.Wai.Handler.Warp qualified as W import Network.Wai.Handler.WarpTLS qualified as W import Network.X509.SelfSigned -import Prettyprinter qualified as PP -import PropertyMatchers ((?)) -import PropertyMatchers qualified as P -import Servant.Client -import System.IO.Unsafe (unsafePerformIO) -import Test.Tasty -import Test.Tasty.HUnit (testCaseSteps, testCase, assertFailure) - import Pact.Core.Capabilities -import Pact.Core.ChainData (TxCreationTime(..)) +import Pact.Core.ChainData qualified as Pact +import Pact.Core.Command.Client (SubmitBatch(..)) import Pact.Core.Command.Crypto (signEd25519, exportEd25519Signature, importEd25519KeyPair, PrivateKeyBS (..)) import Pact.Core.Command.RPC (ContMsg (..)) -import Pact.Core.Command.Server qualified as Pact5 +import Pact.Core.Command.Server import Pact.Core.Command.Types hiding (ChainId) import Pact.Core.DefPacts.Types import Pact.Core.Errors @@ -102,29 +113,13 @@ import Pact.Core.Hash import Pact.Core.Names import Pact.Core.PactValue import Pact.Core.SPV -import Pact.Types.API qualified as Pact4 -import Pact.Types.ChainId qualified as Pact4 - -import Chainweb.ChainId -import Chainweb.CutDB.RestAPI.Server (someCutGetServer) -import Chainweb.Graph (petersenChainGraph, singletonChainGraph, twentyChainGraph) -import Chainweb.Mempool.Mempool (TransactionHash (..)) -import Chainweb.Pact.RestAPI.Client -import Chainweb.Pact.RestAPI.Server -import Chainweb.Pact.Types -import Chainweb.RestAPI.Utils (someServerApplication) -import Chainweb.Storage.Table.RocksDB -import Chainweb.Test.Pact5.CmdBuilder -import Chainweb.Test.Pact5.CutFixture (advanceAllChains, advanceAllChains_, advanceToForkHeight) -import Chainweb.Test.Pact5.CutFixture qualified as CutFixture -import Chainweb.Test.Pact5.Utils -import Chainweb.Test.TestVersions -import Chainweb.Test.Utils -import Chainweb.Utils -import Chainweb.Version -import Chainweb.Version.Guards (minimumBlockHeaderHistory) -import Chainweb.WebPactExecutionService -import Chainweb.Version.Mainnet (mainnet) +import Prettyprinter qualified as PP +import PropertyMatchers ((?)) +import PropertyMatchers qualified as P +import Servant.Client +import System.IO.Unsafe (unsafePerformIO) +import Test.Tasty +import Test.Tasty.HUnit (testCaseSteps, testCase) -- generating this cert and making an HTTP manager take quite a while relative @@ -141,21 +136,9 @@ httpManager = unsafePerformIO $ HTTP.newTlsManagerWith (HTTP.mkManagerSettings d tests :: RocksDb -> TestTree tests rdb = withResource' (evaluate httpManager >> evaluate cert) $ \_ -> testGroup "Pact5 RemotePactTest" - [ testCaseSteps "crosschainTest" (crosschainTest rdb) - , testCase "spvExpirationTest" $ spvExpirationTest - (pact5InstantCpmTestVersion False petersenChainGraph) - rdb - (P.fun _crResult - ? P.match _PactResultErr - ? P.fun _peMsg - ? P.equals "Continuation error: spv verification failed: target header is not in the chain or is out of bounds") - , testCase "spvExpirationDisabledTest" $ spvExpirationTest - (pact5InstantCpmTestVersionExpiryDisabled petersenChainGraph) - rdb - (P.fun _crResult - ? P.match _PactResultOk - ? P.succeed) - , sendInvalidTxsTest rdb + -- [ testCaseSteps "crosschainTest" (crosschainTest rdb) + -- , testCaseSteps "spvExpirationTest" (spvExpirationTest rdb) + [ sendInvalidTxsTest rdb , testCaseSteps "caplistTest" (caplistTest rdb) , testCaseSteps "pollingInvalidRequestKeyTest" (pollingInvalidRequestKeyTest rdb) , testCaseSteps "pollingConfirmationDepthTest" (pollingConfirmationDepthTest rdb) @@ -163,30 +146,26 @@ tests rdb = withResource' (evaluate httpManager >> evaluate cert) $ \_ -> , testCaseSteps "allocationTest" (allocationTest rdb) , testCaseSteps "webAuthnSignatureTest" (webAuthnSignatureTest rdb) , testCaseSteps "gasPurchaseFailureMessages" (gasPurchaseFailureMessages rdb) - , testCaseSteps "transition occurs" (transitionOccurs rdb) - , testCaseSteps "transition crosschain" (transitionCrosschain rdb) , testCaseSteps "upgradeNamespaceTests" (upgradeNamespaceTests rdb) , testCaseSteps "invalidSigCapNameTest" (invalidSigCapNameTest rdb) - , testCaseSteps "pact53TransitionTest" (pact53TransitionTest rdb) , testCaseSteps "migratePlatformShareTest" (migratePlatformShareTest rdb) , localTests rdb ] pollingInvalidRequestKeyTest :: RocksDb -> Step -> IO () -pollingInvalidRequestKeyTest baseRdb _step = runResourceT $ do - let v = pact5InstantCpmTestVersion False singletonChainGraph - let cid = unsafeChainId 0 - fx <- mkFixture v baseRdb +pollingInvalidRequestKeyTest baseRdb _step = withVersion v $ runResourceT $ do + fx <- mkFixture baseRdb liftIO $ do - poll fx v cid [pactDeadBeef] >>= + poll fx cid [pactDeadBeef] >>= P.equals [Nothing] + where + v = instantCpmTestVersion False singletonChainGraph + cid = unsafeChainId 0 pollingConfirmationDepthTest :: RocksDb -> Step -> IO () -pollingConfirmationDepthTest baseRdb _step = runResourceT $ do - let v = pact5InstantCpmTestVersion False singletonChainGraph - let cid = unsafeChainId 0 - fx <- mkFixture v baseRdb +pollingConfirmationDepthTest baseRdb _step = withVersion v $ runResourceT $ do + fx <- mkFixture baseRdb let trivialTx :: Word -> CmdBuilder trivialTx n = (defaultCmd cid) @@ -194,8 +173,8 @@ pollingConfirmationDepthTest baseRdb _step = runResourceT $ do } liftIO $ do - cmd1 <- buildTextCmd v (trivialTx 42) - cmd2 <- buildTextCmd v (trivialTx 43) + cmd1 <- buildTextCmd (trivialTx 42) + cmd2 <- buildTextCmd (trivialTx 43) let rks = [cmdToRequestKey cmd1, cmdToRequestKey cmd2] let expectSuccessful :: (HasCallStack) => P.Prop [Maybe TestPact5CommandResult] @@ -207,59 +186,61 @@ pollingConfirmationDepthTest baseRdb _step = runResourceT $ do let expectEmpty :: (HasCallStack, Foldable t, Eq a, Show a) => t (Maybe a) -> IO () expectEmpty = traverse_ (P.equals Nothing) - send fx v cid [cmd1, cmd2] + send fx cid [cmd1, cmd2] - pollWithDepth fx v cid rks Nothing + pollWithDepth fx cid rks Nothing >>= expectEmpty - pollWithDepth fx v cid rks (Just (ConfirmationDepth 0)) + pollWithDepth fx cid rks (Just (ConfirmationDepth 0)) >>= expectEmpty advanceAllChains_ fx - pollWithDepth fx v cid rks Nothing + pollWithDepth fx cid rks Nothing >>= expectSuccessful - pollWithDepth fx v cid rks (Just (ConfirmationDepth 0)) + pollWithDepth fx cid rks (Just (ConfirmationDepth 0)) >>= expectSuccessful - pollWithDepth fx v cid rks (Just (ConfirmationDepth 1)) + pollWithDepth fx cid rks (Just (ConfirmationDepth 1)) >>= expectEmpty advanceAllChains_ fx - pollWithDepth fx v cid rks Nothing + pollWithDepth fx cid rks Nothing >>= expectSuccessful - pollWithDepth fx v cid rks (Just (ConfirmationDepth 0)) + pollWithDepth fx cid rks (Just (ConfirmationDepth 0)) >>= expectSuccessful - pollWithDepth fx v cid rks (Just (ConfirmationDepth 1)) + pollWithDepth fx cid rks (Just (ConfirmationDepth 1)) >>= expectSuccessful - pollWithDepth fx v cid rks (Just (ConfirmationDepth 2)) + pollWithDepth fx cid rks (Just (ConfirmationDepth 2)) >>= expectEmpty advanceAllChains_ fx - pollWithDepth fx v cid rks Nothing + pollWithDepth fx cid rks Nothing >>= expectSuccessful - pollWithDepth fx v cid rks (Just (ConfirmationDepth 0)) + pollWithDepth fx cid rks (Just (ConfirmationDepth 0)) >>= expectSuccessful - pollWithDepth fx v cid rks (Just (ConfirmationDepth 1)) + pollWithDepth fx cid rks (Just (ConfirmationDepth 1)) >>= expectSuccessful - pollWithDepth fx v cid rks (Just (ConfirmationDepth 2)) + pollWithDepth fx cid rks (Just (ConfirmationDepth 2)) >>= expectSuccessful - pollWithDepth fx v cid rks (Just (ConfirmationDepth 3)) + pollWithDepth fx cid rks (Just (ConfirmationDepth 3)) >>= expectEmpty return () + where + v = instantCpmTestVersion False singletonChainGraph + cid = unsafeChainId 0 crosschainTest :: RocksDb -> Step -> IO () -crosschainTest baseRdb step = runResourceT $ do - let v = pact5InstantCpmTestVersion False petersenChainGraph - fx <- mkFixture v baseRdb +crosschainTest baseRdb step = withVersion v $ runResourceT $ do + fx <- mkFixture baseRdb let srcChain = unsafeChainId 0 let targetChain = unsafeChainId 9 liftIO $ do step "xchain initiate" - initiator <- buildTextCmd v + initiator <- buildTextCmd $ set cbSigners [ mkEd25519Signer' sender00 [ CapToken (QualifiedName "GAS" (ModuleName "coin" Nothing)) [] @@ -267,33 +248,33 @@ crosschainTest baseRdb step = runResourceT $ do [ PString "sender00" , PString "sender01" , PDecimal 1.0 - , PString (chainIdToText targetChain) + , PString (toText targetChain) ] ] ] - $ set cbRPC (mkExec ("(coin.transfer-crosschain \"sender00\" \"sender01\" (read-keyset 'k) \"" <> chainIdToText targetChain <> "\" 1.0)") (mkKeySetData "k" [sender01])) + $ set cbRPC (mkExec ("(coin.transfer-crosschain \"sender00\" \"sender01\" (read-keyset 'k) \"" <> toText targetChain <> "\" 1.0)") (mkKeySetData "k" [sender01])) $ defaultCmd srcChain - send fx v srcChain [initiator] + send fx srcChain [initiator] let initiatorReqKey = cmdToRequestKey initiator -- what if the source chain hasn't got the xchain transfer in a block yet? - spvTxOutProof fx v targetChain srcChain initiatorReqKey + spvTxOutProof fx targetChain srcChain initiatorReqKey & P.throws ? P.match _FailureResponse ? P.fun responseBody ? P.equals ("Transaction hash not found: " <> sshow initiatorReqKey) advanceAllChains_ fx - [Just sendCr] <- pollWithDepth fx v srcChain [initiatorReqKey] (Just (ConfirmationDepth 0)) + [Just sendCr] <- pollWithDepth fx srcChain [initiatorReqKey] (Just (ConfirmationDepth 0)) let cont = fromMaybe (error "missing continuation") (_crContinuation sendCr) -- what if the target chain isn't aware of the source xchain transfer yet? - spvTxOutProof fx v targetChain srcChain initiatorReqKey + spvTxOutProof fx targetChain srcChain initiatorReqKey & P.throws ? P.match _FailureResponse ? P.fun responseBody ? P.equals "SPV target not reachable: target chain not reachable. Chainweb instance is too young" step "waiting" replicateM_ (int $ diameter petersenChainGraph) $ advanceAllChains_ fx - TransactionOutputProofB64 spvProof <- spvTxOutProof fx v targetChain srcChain initiatorReqKey + TransactionOutputProofB64 spvProof <- spvTxOutProof fx targetChain srcChain initiatorReqKey let contMsg = ContMsg { _cmPactId = _peDefPactId cont , _cmStep = succ $ _peStep cont @@ -304,35 +285,34 @@ crosschainTest baseRdb step = runResourceT $ do step "xchain recv" -- what if we try to finish the xchain on the wrong chain? - recvWrongChain <- buildTextCmd v + recvWrongChain <- buildTextCmd $ set cbRPC (mkCont contMsg) $ defaultCmd srcChain - send fx v srcChain [recvWrongChain] + send fx srcChain [recvWrongChain] let recvWrongChainReqKey = cmdToRequestKey recvWrongChain advanceAllChains_ fx - poll fx v srcChain [recvWrongChainReqKey] + poll fx srcChain [recvWrongChainReqKey] >>= P.match (_head . _Just) ? P.fun _crResult ? P.match _PactResultErr ? P.fun _peMsg -- sic ? P.equals "Continuation error: verifyCont: cannot redeem continuation proof on wrong targget chain" - recv <- buildTextCmd v + recv <- buildTextCmd $ set cbRPC (mkCont contMsg) $ set cbGasPrice (GasPrice 1) $ defaultCmd targetChain - -- what if we try to finish the xchain twice? - -- we need to submit this duplicate finisher *before* the completion for - -- coverage, because if we submit it *after*, the mempool will kick it - -- out, as we test later - recvRepeated <- buildTextCmd v + -- Submit a second finisher before the first one completes. Once the first + -- transaction finishes the defpact, the second one must fail on chain; + -- it was admitted while the defpact was still active. + recvRepeated <- buildTextCmd $ set cbRPC (mkCont contMsg) $ set cbGasPrice (GasPrice 0.1) $ defaultCmd targetChain - send fx v targetChain [recv, recvRepeated] + send fx targetChain [recv, recvRepeated] let recvReqKey = cmdToRequestKey recv let recvRepeatedReqKey = cmdToRequestKey recvRepeated advanceAllChains_ fx - poll fx v targetChain [recvReqKey, recvRepeatedReqKey] + poll fx targetChain [recvReqKey, recvRepeatedReqKey] >>= P.alignExact ? [ P.match _Just ? P.checkAll [ P.fun _crResult ? P.match _PactResultOk P.succeed @@ -341,132 +321,134 @@ crosschainTest baseRdb step = runResourceT $ do , P.checkAll [ P.fun _peName ? P.equals "TRANSFER_XCHAIN_RECD" , P.fun _peArgs ? P.equals - [PString "", PString "sender01", PDecimal 1.0, PString (chainIdToText srcChain)] + [PString "", PString "sender01", PDecimal 1.0, PString (toText srcChain)] ] , P.fun _peName ? P.equals "X_RESUME" , P.succeed ] - , P.fun _crGas ? P.equals (Gas 256) ] - , P.match _Just ? P.fun _crResult ? P.match _PactResultErr ? P.fun _peMsg ? P.fun _boundedText - ? P.equals ("Requested defpact execution already completed for defpact id: " <> T.take 20 (renderDefPactId $ _peDefPactId cont) <> "...") + , P.match _Just ? P.fun _crResult ? P.match _PactResultErr + ? P.fun _peMsg ? P.fun _boundedText + ? P.equals ("Requested defpact execution already completed for defpact id: " + <> T.take 20 (renderDefPactId $ _peDefPactId cont) <> "...") ] - recvRepeatedAfter <- buildTextCmd v + + -- A transaction submitted after completion must be rejected by the + -- mempool pre-insert check rather than included as another failed tx. + recvRepeatedAfter <- buildTextCmd $ set cbRPC (mkCont contMsg) $ defaultCmd targetChain - -- what if we try to continue an already-completed xchain, and submit - -- the continuation after the completion? - send fx v targetChain [recvRepeatedAfter] + send fx targetChain [recvRepeatedAfter] & P.throws ? P.match _FailureResponse ? P.fun responseBody ? textContains "failed with: This transaction is attempting to complete an already-completed defpact" - - -spvExpirationTest :: ChainwebVersion -> RocksDb -> P.Prop TestPact5CommandResult -> IO () -spvExpirationTest v baseRdb prop = runResourceT $ do - fx <- mkFixture v baseRdb - - let srcChain = unsafeChainId 0 - let targetChain = unsafeChainId 9 - - liftIO $ do - initiator <- buildTextCmd v - $ set cbSigners - [ mkEd25519Signer' sender00 - [ CapToken (QualifiedName "GAS" (ModuleName "coin" Nothing)) [] - , CapToken (QualifiedName "TRANSFER_XCHAIN" (ModuleName "coin" Nothing)) - [ PString "sender00" - , PString "sender01" - , PDecimal 1.0 - , PString (chainIdToText targetChain) - ] - ] - ] - $ set cbRPC (mkExec ("(coin.transfer-crosschain \"sender00\" \"sender01\" (read-keyset 'k) \"" <> chainIdToText targetChain <> "\" 1.0)") (mkKeySetData "k" [sender01])) - $ defaultCmd srcChain - - send fx v srcChain [initiator] - let initiatorReqKey = cmdToRequestKey initiator - - -- You have to wait at least N blocks before attempting to run the continuation, - -- where N is the diameter of the graph + some constant. Here, we just run 10 blocks, - -- because it is less than the minimumBlockHeaderHistory of the test version, but - -- more than sufficient for the target chain to be aware of the source xchain transfer. - let waitBlocks :: Integral a => a - waitBlocks = 10 - -- the choice of minBound here is a bit arbitrary. but in the "expiry - -- disabled" case, we definitely don't want to use maxBound. - let expirationWindow = fromMaybe - (error "missing minimumBlockHeaderHistory") - (minimumBlockHeaderHistory v minBound minBound) - when (int expirationWindow < waitBlocks + diameter (chainGraphAt v maxBound)) $ assertFailure "test version has a minimumBlockHeaderHistory that is too short to test" - - replicateM_ waitBlocks $ advanceAllChains_ fx - [Just sendCr] <- pollWithDepth fx v srcChain [initiatorReqKey] (Just (ConfirmationDepth 0)) - let cont = fromMaybe (error "missing continuation") (_crContinuation sendCr) - TransactionOutputProofB64 spvProof <- spvTxOutProof fx v targetChain srcChain initiatorReqKey - let contMsg = ContMsg - { _cmPactId = _peDefPactId cont - , _cmStep = succ $ _peStep cont - , _cmRollback = _peStepHasRollback cont - , _cmData = PUnit - , _cmProof = Just (ContProof (T.encodeUtf8 spvProof)) - } - - -- We have already run an extra 10 blocks since initiating the transfer. - -- We need to wait for the full window to expire. - - -- still accessible at remainingWindow + diameter + 1 so we have to go one beyond - let remainingWindow = int @_ @Int (int expirationWindow - waitBlocks + diameter (chainGraphAt v maxBound) + 2) - replicateM_ remainingWindow $ advanceAllChains_ fx - - recv <- buildTextCmd v - $ set cbRPC (mkCont contMsg) - $ defaultCmd targetChain - send fx v targetChain [recv] - let recvReqKey = cmdToRequestKey recv - advanceAllChains_ fx - poll fx v targetChain [recvReqKey] - >>= P.match (_head . _Just) - ? prop + where + v = instantCpmTestVersion False petersenChainGraph + +-- spvExpirationTest :: RocksDb -> Step -> IO () +-- spvExpirationTest baseRdb _step = runResourceT $ do +-- let v = pact5InstantCpmTestVersion petersenChainGraph +-- fx <- mkFixture v baseRdb + +-- let srcChain = unsafeChainId 0 +-- let targetChain = unsafeChainId 9 + +-- liftIO $ do +-- initiator <- buildTextCmd v +-- $ set cbSigners +-- [ mkEd25519Signer' sender00 +-- [ CapToken (QualifiedName "GAS" (ModuleName "coin" Nothing)) [] +-- , CapToken (QualifiedName "TRANSFER_XCHAIN" (ModuleName "coin" Nothing)) +-- [ PString "sender00" +-- , PString "sender01" +-- , PDecimal 1.0 +-- , PString (chainIdToText targetChain) +-- ] +-- ] +-- ] +-- $ set cbRPC (mkExec ("(coin.transfer-crosschain \"sender00\" \"sender01\" (read-keyset 'k) \"" <> chainIdToText targetChain <> "\" 1.0)") (mkKeySetData "k" [sender01])) +-- $ defaultCmd srcChain + +-- send fx v srcChain [initiator] +-- let initiatorReqKey = cmdToRequestKey initiator + +-- -- You have to wait at least N blocks before attempting to run the continuation, +-- -- where N is the diameter of the graph + some constant. Here, we just run 10 blocks, +-- -- because it is less than the minimumBlockHeaderHistory of the test version, but +-- -- more than sufficient for the target chain to be aware of the source xchain transfer. +-- let waitBlocks :: Integral a => a +-- waitBlocks = 10 +-- let expirationWindow = fromMaybe (error "missing minimumBlockHeaderHistory") (minimumBlockHeaderHistory v maxBound) +-- when (int expirationWindow < waitBlocks + diameter (chainGraphAt v maxBound)) $ assertFailure "test version has a minimumBlockHeaderHistory that is too short to test" + +-- replicateM_ waitBlocks $ advanceAllChains_ fx +-- [Just sendCr] <- pollWithDepth fx v srcChain [initiatorReqKey] (Just (ConfirmationDepth 0)) +-- let cont = fromMaybe (error "missing continuation") (_crContinuation sendCr) +-- TransactionOutputProofB64 spvProof <- spvTxOutProof fx v targetChain srcChain initiatorReqKey +-- let contMsg = ContMsg +-- { _cmPactId = _peDefPactId cont +-- , _cmStep = succ $ _peStep cont +-- , _cmRollback = _peStepHasRollback cont +-- , _cmData = PUnit +-- , _cmProof = Just (ContProof (T.encodeUtf8 spvProof)) +-- } + +-- -- We have already run an extra 10 blocks since initiating the transfer. +-- -- We need to wait for the full window to expire. + +-- -- still accessible at remainingWindow + diameter + 1 so we have to go one beyond +-- let remainingWindow = int @_ @Int (int expirationWindow - waitBlocks + diameter (chainGraphAt v maxBound) + 2) +-- replicateM_ remainingWindow $ advanceAllChains_ fx + +-- recv <- buildTextCmd v +-- $ set cbRPC (mkCont contMsg) +-- $ defaultCmd targetChain +-- send fx v targetChain [recv] +-- let recvReqKey = cmdToRequestKey recv +-- advanceAllChains_ fx +-- poll fx v targetChain [recvReqKey] +-- >>= P.match (_head . _Just) +-- ? P.checkAll +-- [ P.fun _crResult ? P.match _PactResultErr ? P.fun _peMsg ? P.equals "Continuation error: spv verification failed: target header is not in the chain or is out of bounds" +-- ] -- this test suite really wants you not to put any transactions into the final block. sendInvalidTxsTest :: RocksDb -> TestTree -sendInvalidTxsTest rdb = withResourceT (mkFixture v rdb) $ \fx -> - dependentTestGroup "invalid txs in /send" AllFinish +sendInvalidTxsTest rdb = withVersion v $ withResourceT (mkFixture rdb) $ \fx -> + sequentialTestGroup "invalid txs in /send" AllFinish [ testGroup "send txs" [ testCase "syntax error" $ do - cmdParseFailure <- buildTextCmd v + cmdParseFailure <- buildTextCmd $ set cbRPC (mkExec' "(+ 1") $ defaultCmd cid - send fx v cid [cmdParseFailure] - & P.throws ? P.match _FailureResponse ? P.fun responseBody ? textContains "Pact parse error: Expected: [')']" + send fx cid [cmdParseFailure] + & P.throws ? P.match _FailureResponse ? P.fun responseBody ? textContains "ParseError: Expected: [')']" , testCase "invalid hash" $ do cmdInvalidPayloadHash <- do - bareCmd <- buildTextCmd v + bareCmd <- buildTextCmd $ set cbRPC (mkExec "(+ 1 2)" (mkKeySetData "sender00" [sender00])) $ defaultCmd cid pure $ bareCmd { _cmdHash = hash "fakehash" } - send fx v cid [cmdInvalidPayloadHash] + send fx cid [cmdInvalidPayloadHash] & P.throws ? P.match _FailureResponse ? P.fun responseBody ? textContains (validationFailed 0 cmdInvalidPayloadHash "Invalid transaction hash") , testCase "signature length mismatch" $ do cmdSignersSigsLengthMismatch1 <- do - bareCmd <- buildTextCmd v + bareCmd <- buildTextCmd $ set cbRPC (mkExec "(+ 1 2)" (mkKeySetData "sender00" [sender00])) $ defaultCmd cid pure $ bareCmd { _cmdSigs = [] } - send fx v cid [cmdSignersSigsLengthMismatch1] + send fx cid [cmdSignersSigsLengthMismatch1] & P.throws ? P.match _FailureResponse ? P.fun responseBody ? textContains (validationFailed 0 cmdSignersSigsLengthMismatch1 "Invalid transaction sigs: The number of signers and signatures do not match. Number of signers: 1. Number of signatures: 0.") cmdSignersSigsLengthMismatch2 <- do - bareCmd <- buildTextCmd v + bareCmd <- buildTextCmd $ set cbSigners [] $ set cbRPC (mkExec "(+ 1 2)" (mkKeySetData "sender00" [sender00])) $ defaultCmd cid @@ -476,13 +458,13 @@ sendInvalidTxsTest rdb = withResourceT (mkFixture v rdb) $ \fx -> -- but length signers == length signatures is checked first _cmdSigs = [ED25519Sig "fakeSig"] } - send fx v cid [cmdSignersSigsLengthMismatch2] + send fx cid [cmdSignersSigsLengthMismatch2] & P.throws ? P.match _FailureResponse ? P.fun responseBody ? textContains (validationFailed 0 cmdSignersSigsLengthMismatch2 "Invalid transaction sigs: The number of signers and signatures do not match. Number of signers: 0. Number of signatures: 1.") , testCase "invalid signatures" $ do cmdInvalidUserSig <- mkCmdInvalidUserSig - send fx v cid [cmdInvalidUserSig] + send fx cid [cmdInvalidUserSig] & P.throws ? P.match _FailureResponse ? P.fun responseBody ? textContains (validationFailed 0 cmdInvalidUserSig "Invalid transaction sigs: The signature at position 0 is invalid: failed to parse ed25519 signature: invalid bytestring size.") @@ -491,104 +473,115 @@ sendInvalidTxsTest rdb = withResourceT (mkFixture v rdb) $ \fx -> cmdInvalidUserSig <- mkCmdInvalidUserSig -- Test that [badCmd, goodCmd] fails on badCmd, and the batch is rejected. -- We just re-use a previously built bad cmd. - send fx v cid [cmdInvalidUserSig, cmdGood] + send fx cid [cmdInvalidUserSig, cmdGood] & P.throws ? P.match _FailureResponse ? P.fun responseBody ? textContains - (validationFailed 0 cmdInvalidUserSig "Invalid transaction sigs: The signature at position 0 is invalid: failed to parse ed25519 signature: invalid bytestring size.") + (validationFailed 0 cmdInvalidUserSig + "Invalid transaction sigs: The signature at position 0 is invalid: failed to parse ed25519 signature: invalid bytestring size.") -- Test that [goodCmd, badCmd] fails on badCmd, and the batch is rejected. -- Order matters, and the error message also indicates the position of the -- failing tx. -- We just re-use a previously built bad cmd. - send fx v cid [cmdGood, cmdInvalidUserSig] + send fx cid [cmdGood, cmdInvalidUserSig] & P.throws ? P.match _FailureResponse ? P.fun responseBody ? textContains - (validationFailed 1 cmdInvalidUserSig "Invalid transaction sigs: The signature at position 0 is invalid: failed to parse ed25519 signature: invalid bytestring size.") + (validationFailed 1 cmdInvalidUserSig + "Invalid transaction sigs: The signature at position 0 is invalid: failed to parse ed25519 signature: invalid bytestring size.") , testCase "multiple bad txs in batch" $ do cmdGood <- mkCmdGood cmdInvalidUserSig <- mkCmdInvalidUserSig - cmdParseFailure <- buildTextCmd v + cmdParseFailure <- buildTextCmd $ set cbRPC (mkExec' "(+ 1") $ defaultCmd cid - send fx v cid [cmdInvalidUserSig, cmdGood, cmdParseFailure] - & P.throws ? P.match _FailureResponse ? P.fun responseBody ? P.checkAll - [ textContains (validationFailed 0 cmdInvalidUserSig "Invalid transaction sigs: The signature at position 0 is invalid: failed to parse ed25519 signature: invalid bytestring size.") - , textContains (validationFailed 2 cmdParseFailure "Pact parse error: Expected: [')']") - ] + -- if any tx fails parsing, no txs even get validated + send fx cid [cmdInvalidUserSig, cmdGood, cmdParseFailure] + & P.throws ? P.match _FailureResponse ? P.fun responseBody + ? textContains (parseFailed 2 "ParseError: Expected: [')']") + + -- without parse failures, all txs get validated + send fx cid [cmdInvalidUserSig, cmdGood] + & P.throws ? P.match _FailureResponse ? P.fun responseBody + ? textContains (validationFailed 0 cmdInvalidUserSig + "Invalid transaction sigs: The signature at position 0 is invalid: failed to parse ed25519 signature: invalid bytestring size.") , testCase "invalid metadata" $ do cmdGood <- mkCmdGood - send fx v wrongChain [cmdGood] + send fx wrongChain [cmdGood] & P.throws ? P.match _FailureResponse ? P.fun responseBody ? textContains - (validationFailed 0 cmdGood "Transaction metadata (chain id, chainweb version) conflicts with this endpoint") + (validationFailed 0 cmdGood + "Transaction metadata (chain id, chainweb version) conflicts with this endpoint") - send fx wrongV cid [cmdGood] + sendWrongV fx cid [cmdGood] & P.throws ? P.match _FailureResponse ? P.checkAll [ P.fun responseStatusCode ? P.equals notFound404 , P.fun responseBody ? P.equals "" ] let invalidCid = "invalid chain ID" - cmdInvalidChain <- buildTextCmd v (defaultCmd cid & set cbChainId invalidCid) - send fx v wrongChain [cmdInvalidChain] + cmdInvalidChain <- buildTextCmd (defaultCmd cid & set cbChainId invalidCid) + send fx wrongChain [cmdInvalidChain] & P.throws ? P.match _FailureResponse ? P.fun responseBody ? textContains - (validationFailed 0 cmdInvalidChain "insert error: Unparsable ChainId") + (validationFailed 0 cmdInvalidChain + "Transaction metadata (chain id, chainweb version) conflicts with this endpoint") - cmdWrongV <- buildTextCmd wrongV - $ set cbRPC (mkExec "(+ 1 2)" (mkKeySetData "sender00" [sender00])) - $ defaultCmd cid - send fx v cid [cmdWrongV] + cmdWrongV <- buildCmdWrongV + send fx cid [cmdWrongV] & P.throws ? P.match _FailureResponse ? P.fun responseBody ? textContains - (validationFailed 0 cmdWrongV "Transaction metadata (chain id, chainweb version) conflicts with this endpoint") + (validationFailed 0 cmdWrongV + "Transaction metadata (chain id, chainweb version) conflicts with this endpoint") - cmdExpiredTTL <- buildTextCmd v (defaultCmd cid & cbCreationTime .~ Just (TxCreationTime 0)) - send fx v cid [cmdExpiredTTL] + cmdExpiredTTL <- buildTextCmd (defaultCmd cid & cbCreationTime .~ Just (Pact.TxCreationTime 0)) + send fx cid [cmdExpiredTTL] & P.throws ? P.match _FailureResponse ? P.checkAll [ P.fun responseStatusCode ? P.equals badRequest400 , P.fun responseBody ? textContains - (validationFailed 0 cmdExpiredTTL "Transaction time-to-live is expired") + (validationFailed 0 cmdExpiredTTL + "Transaction time-to-live is expired") ] , testCase "cannot buy gas" $ do - cmdExcessiveGasLimit <- buildTextCmd v + cmdExcessiveGasLimit <- buildTextCmd $ set cbGasLimit (GasLimit $ Gas 100000000000000) $ defaultCmd cid - send fx v cid [cmdExcessiveGasLimit] + send fx cid [cmdExcessiveGasLimit] & P.throws ? P.match _FailureResponse ? P.checkAll [ P.fun responseStatusCode ? P.equals badRequest400 , P.fun responseBody ? textContains - (validationFailed 0 cmdExcessiveGasLimit "Transaction gas limit exceeds block gas limit") + (validationFailed 0 cmdExcessiveGasLimit + "Transaction gas limit exceeds block gas limit") ] - cmdGasPriceTooPrecise <- buildTextCmd v + cmdGasPriceTooPrecise <- buildTextCmd $ set cbGasPrice (GasPrice 0.00000000000000001) $ defaultCmd cid - send fx v cid [cmdGasPriceTooPrecise] + send fx cid [cmdGasPriceTooPrecise] & P.throws ? P.match _FailureResponse ? P.checkAll [ P.fun responseStatusCode ? P.equals badRequest400 , P.fun responseBody ? textContains - (validationFailed 0 cmdGasPriceTooPrecise "insert error: This transaction's gas price: 0.00000000000000001 is not correctly rounded. It should be rounded to at most 12 decimal places.") + (validationFailed 0 cmdGasPriceTooPrecise + "This transaction's gas price (0.00000000000000001) is not correctly rounded. It should be rounded to at most 12 decimal places.") ] - cmdNotEnoughGasFunds <- buildTextCmd v + cmdNotEnoughGasFunds <- buildTextCmd $ set cbGasPrice (GasPrice 10_000_000_000) $ set cbGasLimit (GasLimit (Gas 10_000)) $ defaultCmd cid - send fx v cid [cmdNotEnoughGasFunds] + send fx cid [cmdNotEnoughGasFunds] & P.throws ? P.match _FailureResponse ? P.checkAll [ P.fun responseStatusCode ? P.equals badRequest400 , P.fun responseBody ? textContains - (validationFailed 0 cmdNotEnoughGasFunds "Attempt to buy gas failed with: " <> sshow (_cmdHash cmdNotEnoughGasFunds) <> " Failed to buy gas: Insufficient funds") + (validationFailed 0 cmdNotEnoughGasFunds + "Failed to buy gas: Insufficient funds") ] - cmdInvalidSender <- buildTextCmd v + cmdInvalidSender <- buildTextCmd $ set cbSender "invalid-sender" $ defaultCmd cid - send fx v cid [cmdInvalidSender] + send fx cid [cmdInvalidSender] & P.throws ? P.match _FailureResponse ? P.checkAll [ P.fun responseStatusCode ? P.equals badRequest400 , P.fun responseBody ? textContains - -- TODO: the full error is far more verbose than this, - -- perhaps that's something we should fix. - (validationFailed 0 cmdInvalidSender "Attempt to buy gas failed") + (validationFailed 0 cmdInvalidSender + "Failed to buy gas: No value found in table coin_coin-table for key") ] ] @@ -601,30 +594,33 @@ sendInvalidTxsTest rdb = withResourceT (mkFixture v rdb) $ \fx -> ] where - v = pact5InstantCpmTestVersion False petersenChainGraph - wrongV = pact5InstantCpmTestVersion False twentyChainGraph - + v = instantCpmTestVersion False petersenChainGraph + wrongV = instantCpmTestVersion False twentyChainGraph + buildCmdWrongV = withVersion wrongV $ + buildTextCmd + $ set cbRPC (mkExec "(+ 1 2)" (mkKeySetData "sender00" [sender00])) + $ defaultCmd cid + sendWrongV = withVersion wrongV $ send cid = unsafeChainId 0 wrongChain = unsafeChainId 1 validationFailed i cmd msg = "Transaction " <> sshow (_cmdHash cmd) <> " at index " <> sshow @Int i <> " failed with: " <> msg + parseFailed i msg = "Transaction at index " <> sshow @Int i <> " has invalid Pact code: " <> msg mkCmdInvalidUserSig = mkCmdGood <&> set cmdSigs [ED25519Sig "fakeSig"] - mkCmdGood = buildTextCmd v + mkCmdGood = withVersion v + $ buildTextCmd $ set cbRPC (mkExec "(+ 1 2)" (mkKeySetData "sender00" [sender00])) $ defaultCmd cid caplistTest :: RocksDb -> Step -> IO () -caplistTest baseRdb step = runResourceT $ do - let v = pact5InstantCpmTestVersion False petersenChainGraph - fx <- mkFixture v baseRdb - - let cid = unsafeChainId 0 +caplistTest baseRdb step = withVersion v $ runResourceT $ do + fx <- mkFixture baseRdb liftIO $ do - tx0 <- buildTextCmd v + tx0 <- buildTextCmd $ set cbSigners [ mkEd25519Signer' sender00 [ CapToken (QualifiedName "GAS" (ModuleName "coin" Nothing)) [] @@ -639,7 +635,7 @@ caplistTest baseRdb step = runResourceT $ do $ defaultCmd cid step "sending" - send fx v cid [tx0] + send fx cid [tx0] let recvReqKey = cmdToRequestKey tx0 @@ -649,19 +645,23 @@ caplistTest baseRdb step = runResourceT $ do step "polling" - poll fx v cid [recvReqKey] + poll fx cid [recvReqKey] >>= P.alignExact ? List.singleton ? P.match _Just ? P.checkAll [ P.fun _crResult ? P.match (_PactResultOk . _PString) ? P.equals "Write succeeded" - , P.fun _crMetaData ? P.match (_Just . A._Object . at "blockHash") ? P.match _Just P.succeed + , P.fun _crMetaData + ? P.match (_Just . A._Object . at "blockHash") + ? P.match (_Just . A._String . b64UrlNoPaddingPrism) P.succeed ] + where + v = instantCpmTestVersion False petersenChainGraph + cid = unsafeChainId 0 migratePlatformShareTest :: RocksDb -> Step -> IO () -migratePlatformShareTest baseRdb _step = runResourceT $ do - let v = pact5InstantCpmTestVersion True petersenChainGraph +migratePlatformShareTest baseRdb _step = withVersion (instantCpmTestVersion True petersenChainGraph) $ runResourceT $ do let cid = unsafeChainId 0 - fx <- mkFixture v baseRdb - cmd <- buildTextCmd v $ set cbRPC (mkExec' "(describe-keyset \"PS_C0\")") $ defaultCmd cid + fx <- mkFixture baseRdb + cmd <- buildTextCmd $ set cbRPC (mkExec' "(describe-keyset \"PS_C0\")") $ defaultCmd cid let platformShareKeySet = KeySet { _ksKeys = S.fromList [ PublicKeyText "be6918da77866bd20fc2f6581dc9cdacd98372b9c427ac6f9e4f731f7861bca8" @@ -676,94 +676,13 @@ migratePlatformShareTest baseRdb _step = runResourceT $ do ) } liftIO $ do - local fx v cid Nothing Nothing Nothing cmd - >>= P.match _Pact5LocalResultLegacy + local fx cid Nothing Nothing Nothing cmd + >>= P.match _LocalResultLegacy ? P.fun _crResult ? P.match _PactResultOk ? P.match _PGuard ? P.equals (GKeyset platformShareKeySet) -pact53TransitionTest :: RocksDb -> Step -> IO () -pact53TransitionTest baseRdb step = runResourceT $ do - let v = pact53TransitionCpmTestVersion petersenChainGraph - fx <- mkFixture v baseRdb - - let cid = unsafeChainId 0 - let assertTxFailure tx msg = poll fx v cid [cmdToRequestKey tx] - >>= P.alignExact ? List.singleton ? P.match _Just ? - P.checkAll - [ P.fun _crResult ? P.match _PactResultErr ? P.fun _peMsg ? P.equals msg - ] - let assertTxSuccess tx resultVal = poll fx v cid [cmdToRequestKey tx] - >>= P.alignExact ? List.singleton ? P.match _Just ? - P.checkAll - [ P.fun _crResult ? P.match _PactResultOk ? P.equals resultVal - ] - - liftIO $ do - let errorTx = mkExec' "(error \"test error\")" - let pureTx = mkExec' "(pure 1)" - - txErr0 <- buildTextCmd v - $ set cbRPC errorTx - $ defaultCmd cid - txPure0 <- buildTextCmd v - $ set cbRPC pureTx - $ defaultCmd cid - txReadOnlyGuardSetup <- buildTextCmd v - $ set cbRPC (mkExec' $ T.concat - [ "(namespace 'free)" - , "(module test-read-only g (defcap g () true)" - , " (defschema my-schema key:integer)" - , " (deftable my-table:{my-schema})" - , " (defun read-only-fn () (read my-table 'key))" - , " (defun mk-ug () (create-user-guard (read-only-fn)))" - , ")" - , "(create-table my-table)" - , "(insert my-table 'key {'key:1})" - ]) - $ defaultCmd cid - - step "sending first batch of transactions" - send fx v cid [txErr0, txPure0, txReadOnlyGuardSetup] - advanceAllChains_ fx - step "polling for first batch of transactions" - assertTxFailure txErr0 "Cannot find module: error" - assertTxFailure txPure0 "Cannot find module: pure" - assertTxSuccess txReadOnlyGuardSetup (PString "Write succeeded") - - step "sending read only guard tx" - let readOnlyGuardTx = mkExec' "(enforce-guard (free.test-read-only.mk-ug))" - txReadOnly0 <- buildTextCmd v - $ set cbRPC readOnlyGuardTx - $ defaultCmd cid - send fx v cid [txReadOnly0] - advanceAllChains_ fx - step "polling for read only guard tx" - assertTxFailure txReadOnly0 "Error during database operation: Operation is not allowed in read-only or system-only mode." - - step "advancing past the fork" - advanceToForkHeight fx Chainweb230Pact - - txErr1 <- buildTextCmd v - $ set cbRPC errorTx - $ defaultCmd cid - txPure1 <- buildTextCmd v - $ set cbRPC pureTx - $ defaultCmd cid - txReadOnly1 <- buildTextCmd v - $ set cbRPC readOnlyGuardTx - $ defaultCmd cid - - step "Sending post fork txs" - send fx v cid [txErr1, txPure1, txReadOnly1] - advanceAllChains_ fx - step "polling post-fork results" - -- Note: correct output from calling (error "test error") - assertTxFailure txErr1 "test error" - assertTxSuccess txPure1 (PInteger 1) - assertTxSuccess txReadOnly1 (PBool True) - allocation01KeyPair :: (Text, Text) allocation01KeyPair = ( "b4c8a3ea91d3146b0560994740f0e3eed91c59d2eeca1dc99f0c2872845c294d" @@ -783,36 +702,34 @@ allocation02KeyPair' = ) allocationTest :: RocksDb -> (String -> IO ()) -> IO () -allocationTest rdb step = runResourceT $ do - let v = pact5InstantCpmTestVersion False petersenChainGraph - let cid = unsafeChainId 0 - fx <- mkFixture v rdb +allocationTest rdb step = withVersion v $ runResourceT $ do + fx <- mkFixture rdb liftIO $ do do step "allocation00" - release00Cmd <- buildTextCmd v + release00Cmd <- buildTextCmd $ set cbSigners [mkEd25519Signer' allocation00KeyPair [], mkEd25519Signer' sender00 []] $ set cbRPC (mkExec' "(coin.release-allocation \"allocation00\")") $ defaultCmd cid - send fx v cid [release00Cmd] + send fx cid [release00Cmd] advanceAllChains_ fx - poll fx v cid [cmdToRequestKey release00Cmd] >>= + poll fx cid [cmdToRequestKey release00Cmd] >>= P.alignExact [ P.match _Just ? P.checkAll [ P.fun _crResult ? P.match _PactResultOk ? P.succeed - , P.fun _crEvents ? P.match _head - ? event + , P.fun _crEvents ? P.match _head ? + (event (P.equals "RELEASE_ALLOCATION") (P.equals [PString "allocation00", PDecimal 1000000]) - (P.equals coinModuleName) + (P.equals coinModuleName)) ] ] - buildTextCmd v + buildTextCmd (set cbRPC (mkExec' "(coin.details \"allocation00\")") $ defaultCmd cid) - >>= local fx v cid Nothing Nothing Nothing - >>= P.match _Pact5LocalResultLegacy + >>= local fx cid Nothing Nothing Nothing + >>= P.match _LocalResultLegacy ? P.fun _crResult ? P.match _PactResultOk ? P.match _PObject @@ -824,13 +741,13 @@ allocationTest rdb step = runResourceT $ do step "allocation01" do - buildTextCmd v + buildTextCmd (set cbRPC (mkExec' "(coin.release-allocation \"allocation01\")") $ set cbSigners [mkEd25519Signer' allocation01KeyPair [], mkEd25519Signer' sender00 []] $ defaultCmd cid) - >>= local fx v cid Nothing Nothing Nothing - >>= P.match _Pact5LocalResultLegacy + >>= local fx cid Nothing Nothing Nothing + >>= P.match _LocalResultLegacy ? P.fun _crResult ? P.match _PactResultErr ? P.checkAll @@ -838,13 +755,13 @@ allocationTest rdb step = runResourceT $ do , P.fun _peMsg ? P.fun _boundedText ? textContains "funds locked until \"2100-10-31T18:00:00Z\"." ] - buildTextCmd v + buildTextCmd (set cbRPC (mkExec' "(coin.release-allocation \"allocation01\")") $ set cbSigners [mkEd25519Signer' allocation01KeyPair [], mkEd25519Signer' sender00 []] $ defaultCmd cid) - >>= local fx v cid (Just PreflightSimulation) Nothing Nothing - >>= P.match (_Pact5LocalResultWithWarns . _1) ? + >>= local fx cid (Just PreflightSimulation) Nothing Nothing + >>= P.match (_LocalResultWithWarns . _1) ? P.fun _crResult ? P.match _PactResultErr ? P.checkAll [ P.fun _peType ? P.equals ? ErrorType "TxFailure" @@ -853,7 +770,7 @@ allocationTest rdb step = runResourceT $ do step "allocation02" do - redefineKeysetCmd <- buildTextCmd v + redefineKeysetCmd <- buildTextCmd $ set cbSigners [mkEd25519Signer' allocation02KeyPair []] $ set cbSender "allocation02" $ set cbRPC (mkExec @@ -861,38 +778,45 @@ allocationTest rdb step = runResourceT $ do (mkKeySetData "allocation02-keyset" [allocation02KeyPair']) ) $ defaultCmd cid - send fx v cid [redefineKeysetCmd] + send fx cid [redefineKeysetCmd] advanceAllChains_ fx - poll fx v cid [cmdToRequestKey redefineKeysetCmd] - >>= P.alignExact [P.match _Just successfulTx] + [Just redefineKeysetCr] <- poll fx cid [cmdToRequestKey redefineKeysetCmd] + redefineKeysetCr & successfulTx - releaseAllocationCmd <- buildTextCmd v + releaseAllocationCmd <- buildTextCmd $ set cbSender "allocation02" $ set cbSigners [mkEd25519Signer' allocation02KeyPair' []] $ set cbRPC (mkExec' "(coin.release-allocation \"allocation02\")") $ defaultCmd cid - send fx v cid [releaseAllocationCmd] + send fx cid [releaseAllocationCmd] advanceAllChains_ fx - poll fx v cid [cmdToRequestKey releaseAllocationCmd] - >>= P.alignExact [P.match _Just successfulTx] - - buildTextCmd v (set cbRPC (mkExec' "(coin.details \"allocation02\")") $ defaultCmd cid) - >>= local fx v cid Nothing Nothing Nothing - >>= P.match _Pact5LocalResultLegacy + [Just releaseCr] <- poll fx cid [cmdToRequestKey releaseAllocationCmd] + releaseCr & successfulTx + + -- the allocation balance depends on the gas consumed by the + -- define-keyset and release-allocation transactions, which depends + -- on the gas model + let gasUsed = _gas (_crGas releaseCr) + _gas (_crGas redefineKeysetCr) + expectedBalance = 1_100_000 - 0.000_1 * fromIntegral gasUsed + + buildTextCmd (set cbRPC (mkExec' "(coin.details \"allocation02\")") $ defaultCmd cid) + >>= local fx cid Nothing Nothing Nothing + >>= P.match _LocalResultLegacy ? P.fun _crResult ? P.match _PactResultOk ? P.match _PObject ? P.equals ? Map.fromList [ ("account", (PString "allocation02")) - , ("balance", (PDecimal 1_099_999.9748)) -- 1k + 1mm - gas + , ("balance", (PDecimal expectedBalance)) , ("guard", (PGuard $ GKeySetRef (KeySetName "allocation02" Nothing))) ] + where + v = instantCpmTestVersion False petersenChainGraph + cid = unsafeChainId 0 gasPurchaseFailureMessages :: RocksDb -> Step -> IO () -gasPurchaseFailureMessages rdb _step = runResourceT $ do - let v = pact5InstantCpmTestVersion False petersenChainGraph - let cid = unsafeChainId 0 - fx <- mkFixture v rdb +gasPurchaseFailureMessages rdb _step = withVersion v $ runResourceT $ do + fx <- mkFixture rdb -- Check the ways buyGas can fail and its error messages. -- Each case is checked with both `/local` (with preflight) and `/send`. @@ -901,24 +825,24 @@ gasPurchaseFailureMessages rdb _step = runResourceT $ do -- (gas price * gas limit) should return an error -- this relies on sender00's starting balance. do - cmd <- buildTextCmd v + cmd <- buildTextCmd $ set cbSender "sender00" $ set cbSigners [mkEd25519Signer' sender00 []] $ set cbGasPrice (GasPrice 70_000) $ set cbGasLimit (GasLimit (Gas 100_000)) $ defaultCmd cid - local fx v cid (Just PreflightSimulation) Nothing Nothing cmd - >>= P.match _Pact5LocalResultWithWarns + local fx cid (Just PreflightSimulation) Nothing Nothing cmd + >>= P.match _LocalResultWithWarns ? P.fun fst ? P.fun _crResult ? P.match _PactResultErr ? P.checkAll - [ P.fun _peType ? P.equals ? ErrorType "EvalError" + [ P.fun _peType ? P.equals ? ErrorType "TxFailure" , P.fun _peMsg ? P.fun _boundedText ? textContains "Failed to buy gas: Insufficient funds" ] - send fx v cid [cmd] + send fx cid [cmd] & P.throws ? P.match _FailureResponse ? P.fun responseBody @@ -927,7 +851,7 @@ gasPurchaseFailureMessages rdb _step = runResourceT $ do -- multiple gas payer caps should lead to an error, because it's unclear -- which module will pay for gas do - cmd <- buildTextCmd v + cmd <- buildTextCmd $ set cbSender "sender00" $ set cbSigners [ mkEd25519Signer' sender00 @@ -938,137 +862,51 @@ gasPurchaseFailureMessages rdb _step = runResourceT $ do ] $ defaultCmd cid - local fx v cid (Just PreflightSimulation) Nothing Nothing cmd - >>= P.match _Pact5LocalResultWithWarns + local fx cid (Just PreflightSimulation) Nothing Nothing cmd + >>= P.match _LocalResultWithWarns ? P.fun fst ? P.fun _crResult ? P.match _PactResultErr ? P.checkAll [ P.fun _peType ? P.equals ? ErrorType "EvalError" - , P.fun _peMsg ? P.fun _boundedText ? textContains "Failed to buy gas: Multiple gas payer capabilities" + , P.fun _peMsg ? P.fun _boundedText + ? textContains "Failed to buy gas: multiple gas payer capabilities in signers list" ] - send fx v cid [cmd] + send fx cid [cmd] & P.throws ? P.match _FailureResponse ? P.fun responseBody - ? textContains "Failed to buy gas: Multiple gas payer capabilities" - -transitionOccurs :: RocksDb -> Step -> IO () -transitionOccurs rdb _step = runResourceT $ do - let v = instantCpmTransitionTestVersion petersenChainGraph - let cid = unsafeChainId 0 - fx <- mkFixture v rdb - - liftIO $ do - checkPactVersion fx v cid >>= P.equals Pact4 - advanceToForkHeight fx Pact5Fork - checkPactVersion fx v cid >>= P.equals Pact5 - --- | Test that xchains work across the Pact4->Pact4 transition boundary. --- This is mostly the same as 'crosschainTest', except it waits for the transition. -transitionCrosschain :: RocksDb -> Step -> IO () -transitionCrosschain rdb step = runResourceT $ do - let v = instantCpmTransitionTestVersion petersenChainGraph - let srcChain = unsafeChainId 0 - let targetChain = unsafeChainId 9 - fx <- mkFixture v rdb - - let checkIsVersion pv = do - checkPactVersion fx v srcChain >>= P.equals pv - checkPactVersion fx v targetChain >>= P.equals pv - - liftIO $ do - checkIsVersion Pact4 - - step "xchain initiate" - initiator <- buildTextCmd v - $ set cbSigners - [ mkEd25519Signer' sender00 - [ CapToken (QualifiedName "GAS" (ModuleName "coin" Nothing)) [] - , CapToken (QualifiedName "TRANSFER_XCHAIN" (ModuleName "coin" Nothing)) - [ PString "sender00" - , PString "sender01" - , PDecimal 1.0 - , PString (chainIdToText targetChain) - ] - ] - ] - $ set cbRPC (mkExec ("(coin.transfer-crosschain \"sender00\" \"sender01\" (read-keyset 'k) \"" <> chainIdToText targetChain <> "\" 1.0)") (mkKeySetData "k" [sender01])) - $ defaultCmd srcChain - - send fx v srcChain [initiator] - let initiatorReqKey = cmdToRequestKey initiator - advanceAllChains_ fx - [Just sendCr] <- pollWithDepth fx v srcChain [initiatorReqKey] (Just (ConfirmationDepth 0)) - let cont = fromMaybe (error "missing continuation") (_crContinuation sendCr) - - step "waiting until pact5 transition" - - step "... performing transition" - replicateM_ 16 $ advanceAllChains_ fx - checkIsVersion Pact4 - advanceAllChains_ fx - checkIsVersion Pact5 - - TransactionOutputProofB64 spvProof <- spvTxOutProof fx v targetChain srcChain initiatorReqKey - let contMsg = ContMsg - { _cmPactId = _peDefPactId cont - , _cmStep = succ $ _peStep cont - , _cmRollback = _peStepHasRollback cont - , _cmData = PUnit - , _cmProof = Just (ContProof (T.encodeUtf8 spvProof)) - } - step "xchain recv" - - recv <- buildTextCmd v - $ set cbRPC (mkCont contMsg) - $ defaultCmd targetChain - send fx v targetChain [recv] - let recvReqKey = cmdToRequestKey recv - advanceAllChains_ fx - poll fx v targetChain [recvReqKey] - >>= P.match (_head . _Just) - ? P.checkAll - [ P.fun _crResult ? P.match _PactResultOk P.succeed - , P.fun _crEvents ? P.alignExact - [ P.succeed - , P.checkAll - [ P.fun _peName ? P.equals "TRANSFER_XCHAIN_RECD" - , P.fun _peArgs ? P.equals - [PString "", PString "sender01", PDecimal 1.0, PString (chainIdToText srcChain)] - ] - , P.fun _peName ? P.equals "X_RESUME" - , P.succeed - ] - ] + ? textContains "Failed to buy gas: multiple gas payer capabilities in signers list" return () + where + v = instantCpmTestVersion False petersenChainGraph + cid = unsafeChainId 0 -- Test that transactions signed with (mock) WebAuthn keypairs are accepted -- by the pact service. webAuthnSignatureTest :: RocksDb -> Step -> IO () -webAuthnSignatureTest rdb _step = runResourceT $ do - let v = pact5InstantCpmTestVersion False petersenChainGraph - let cid = unsafeChainId 0 - fx <- mkFixture v rdb +webAuthnSignatureTest rdb _step = withVersion v $ runResourceT $ do + fx <- mkFixture rdb liftIO $ do - cmd <- buildTextCmd v + cmd <- buildTextCmd $ set cbSigners [mkWebAuthnSigner' sender02WebAuthn [], mkEd25519Signer' sender00 []] $ set cbRPC (mkExec' "(concat [\"chainweb-\" \"node\"])") $ defaultCmd cid - send fx v cid [cmd] + send fx cid [cmd] advanceAllChains_ fx - poll fx v cid [cmdToRequestKey cmd] >>= + poll fx cid [cmdToRequestKey cmd] >>= P.alignExact [P.match _Just successfulTx] + where + v = instantCpmTestVersion False petersenChainGraph + cid = unsafeChainId 0 localTests :: RocksDb -> TestTree -localTests baseRdb = let - v = pact5InstantCpmTestVersion False petersenChainGraph - cid = unsafeChainId 0 - in testGroup "tests for local" - [ testCase "ordinary txs" $ runResourceT $ do - fx <- mkFixture v baseRdb +localTests baseRdb = + testGroup "tests for local" + [ testCase "ordinary txs" $ withVersion v $ runResourceT $ do + fx <- mkFixture baseRdb liftIO $ do let expectation = P.checkAll [ P.fun _crResult ? P.match _PactResultOk ? P.equals (PInteger 1) @@ -1086,129 +924,129 @@ localTests baseRdb = let ]) ] ] - buildTextCmd v (defaultCmd cid) - >>= local fx v cid (Just PreflightSimulation) Nothing Nothing - >>= P.match _Pact5LocalResultWithWarns ? P.fun fst ? expectation + buildTextCmd (defaultCmd cid) + >>= local fx cid (Just PreflightSimulation) Nothing Nothing + >>= P.match _LocalResultWithWarns ? P.fun fst ? expectation - buildTextCmd v (defaultCmd cid) - >>= local fx v cid (Just PreflightSimulation) (Just NoVerify) Nothing - >>= P.match _Pact5LocalResultWithWarns ? P.fun fst ? expectation + buildTextCmd (defaultCmd cid) + >>= local fx cid (Just PreflightSimulation) (Just NoVerify) Nothing + >>= P.match _LocalResultWithWarns ? P.fun fst ? expectation - , testCase "signature with the wrong key" $ runResourceT $ do - fx <- mkFixture v baseRdb + , testCase "signature with the wrong key" $ withVersion v $ runResourceT $ do + fx <- mkFixture baseRdb liftIO $ do let buildSender00Cmd = defaultCmd cid & cbSigners .~ [mkEd25519Signer' sender00 []] - goodCmdHash <- _cmdHash <$> buildTextCmd v buildSender00Cmd + goodCmdHash <- _cmdHash <$> buildTextCmd buildSender00Cmd sender01KeyPair <- either error return $ importEd25519KeyPair Nothing (PrivBS $ either error id $ B16.decode $ T.encodeUtf8 $ snd sender01) let sender01Sig = ED25519Sig $ T.decodeUtf8 $ B16.encode $ exportEd25519Signature $ signEd25519 (fst sender01KeyPair) (snd sender01KeyPair) goodCmdHash - buildTextCmd v buildSender00Cmd + buildTextCmd buildSender00Cmd <&> set cmdSigs [sender01Sig] -- preflight mode, verify signatures - >>= local fx v cid (Just PreflightSimulation) Nothing Nothing + >>= local fx cid (Just PreflightSimulation) Nothing Nothing & P.throws ? P.match _FailureResponse ? P.checkAll [ P.fun responseStatusCode ? P.equals badRequest400 , P.fun responseBody ? P.equals "Metadata validation failed: [\"The signature at position 0 is invalid: invalid ed25519 signature.\"]" ] - buildTextCmd v buildSender00Cmd + buildTextCmd buildSender00Cmd <&> set cmdSigs [sender01Sig] -- preflight mode, do not verify signatures - >>= local fx v cid (Just PreflightSimulation) (Just NoVerify) Nothing + >>= local fx cid (Just PreflightSimulation) (Just NoVerify) Nothing >>= P.succeed - buildTextCmd v buildSender00Cmd + buildTextCmd buildSender00Cmd <&> set cmdSigs [sender01Sig] -- non-preflight mode, verify signatures - >>= local fx v cid Nothing Nothing Nothing + >>= local fx cid Nothing Nothing Nothing & P.throws ? P.match _FailureResponse ? P.checkAll [ P.fun responseStatusCode ? P.equals badRequest400 , P.fun responseBody ? P.equals "Metadata validation failed: [\"The signature at position 0 is invalid: invalid ed25519 signature.\"]" ] - buildTextCmd v buildSender00Cmd + buildTextCmd buildSender00Cmd <&> set cmdSigs [sender01Sig] -- non-preflight mode, do not verify signatures - >>= local fx v cid Nothing (Just NoVerify) Nothing + >>= local fx cid Nothing (Just NoVerify) Nothing >>= P.match _LocalResultLegacy ? P.succeed - , testCase "invalid tx metadata" $ runResourceT $ do - fx <- mkFixture v baseRdb + , testCase "invalid tx metadata" $ withVersion v $ runResourceT $ do + fx <- mkFixture baseRdb liftIO $ do let wrongChain = unsafeChainId maxBound - buildTextCmd v (defaultCmd wrongChain) - >>= local fx v cid (Just PreflightSimulation) Nothing Nothing + buildTextCmd (defaultCmd wrongChain) + >>= local fx cid (Just PreflightSimulation) Nothing Nothing & P.throws ? P.match _FailureResponse ? P.checkAll [ P.fun responseStatusCode ? P.equals badRequest400 , P.fun responseBody ? P.equals "Metadata validation failed: [\"Chain id mismatch\"]" ] -- /local without preflight does not care about incorrect chains - buildTextCmd v (defaultCmd wrongChain) - >>= local fx v cid Nothing Nothing Nothing + buildTextCmd (defaultCmd wrongChain) + >>= local fx cid Nothing Nothing Nothing >>= P.succeed let invalidChain = "not a real chain" - buildTextCmd v (defaultCmd cid & set cbChainId invalidChain) - >>= local fx v cid (Just PreflightSimulation) Nothing Nothing + buildTextCmd (defaultCmd cid & set cbChainId invalidChain) + >>= local fx cid (Just PreflightSimulation) Nothing Nothing & P.throws ? P.match _FailureResponse ? P.checkAll [ P.fun responseStatusCode ? P.equals badRequest400 , P.fun responseBody ? P.equals "Metadata validation failed: [\"Chain id mismatch\"]" ] - buildTextCmd v (defaultCmd cid & set cbChainId invalidChain) - >>= local fx v cid Nothing Nothing Nothing + buildTextCmd (defaultCmd cid & set cbChainId invalidChain) + >>= local fx cid Nothing Nothing Nothing >>= P.succeed - buildTextCmd v (set cbGasLimit (GasLimit $ Gas 100000000000000) $ defaultCmd cid) - >>= local fx v cid (Just PreflightSimulation) Nothing Nothing + buildTextCmd (set cbGasLimit (GasLimit $ Gas 100000000000000) $ defaultCmd cid) + >>= local fx cid (Just PreflightSimulation) Nothing Nothing & P.throws ? P.match _FailureResponse ? P.checkAll [ P.fun responseStatusCode ? P.equals badRequest400 , P.fun responseBody ? P.equals "Metadata validation failed: [\"Transaction Gas limit exceeds block gas limit\"]" ] - buildTextCmd v (set cbGasPrice (GasPrice 0.00000000000000001) $ defaultCmd cid) - >>= local fx v cid (Just PreflightSimulation) Nothing Nothing + buildTextCmd (set cbGasPrice (GasPrice 0.00000000000000001) $ defaultCmd cid) + >>= local fx cid (Just PreflightSimulation) Nothing Nothing & P.throws ? P.match _FailureResponse ? P.checkAll [ P.fun responseStatusCode ? P.equals badRequest400 , P.fun responseBody ? P.equals "Metadata validation failed: [\"Gas price decimal precision too high\"]" ] - buildTextCmd mainnet (defaultCmd cid) - >>= local fx v cid (Just PreflightSimulation) Nothing Nothing + buildCmdMainnet + >>= local fx cid (Just PreflightSimulation) Nothing Nothing & P.throws ? P.match _FailureResponse ? P.checkAll [ P.fun responseStatusCode ? P.equals badRequest400 , P.fun responseBody ? P.equals "Metadata validation failed: [\"Network id mismatch\"]" ] let sigs' = replicate 101 $ mkEd25519Signer' sender00 [] - buildTextCmd v (defaultCmd cid & set cbSigners sigs') - >>= local fx v cid (Just PreflightSimulation) Nothing Nothing + buildTextCmd (defaultCmd cid & set cbSigners sigs') + >>= local fx cid (Just PreflightSimulation) Nothing Nothing & P.throws ? P.match _FailureResponse ? P.checkAll [ P.fun responseStatusCode ? P.equals badRequest400 , P.fun responseBody ? P.equals "Metadata validation failed: [\"Signature list size too big\"]" ] - buildTextCmd v + buildTextCmd (defaultCmd cid & set cbGasPrice (GasPrice 10_000_000_000) & set cbGasLimit (GasLimit (Gas 10_000))) - >>= local fx v cid (Just PreflightSimulation) Nothing Nothing - >>= P.match (_Pact5LocalResultWithWarns . _1) + >>= local fx cid (Just PreflightSimulation) Nothing Nothing + >>= P.match (_LocalResultWithWarns . _1) ? P.fun _crResult -- TODO: a more detailed check here than "is an error" might be nice ? P.match _PactResultErr P.succeed - , withResourceT (mkFixture v baseRdb) $ \fx -> testCase "local with depth" $ do - startBalance <- buildTextCmd v (defaultCmd cid & set cbRPC (mkExec' "(coin.details 'sender00)")) - >>= local fx v cid Nothing Nothing (Just (RewindDepth 0)) + , withVersion v $ withResourceT (mkFixture baseRdb) $ \fx -> testCase "local with depth" $ do + startBalance <- buildTextCmd (defaultCmd cid & set cbRPC (mkExec' "(coin.details 'sender00)")) + >>= local fx cid Nothing Nothing (Just (RewindDepth 0)) <&> unsafeHeadOf - ? _Pact5LocalResultLegacy + ? _LocalResultLegacy . to _crResult . _PactResultOk . _PObject . at "balance" . _Just @@ -1223,7 +1061,7 @@ localTests baseRdb = let hasBlockHeight p = P.fun _crMetaData ? P.match (_Just . A._Object . at "blockHeight" . _Just . A._Number) p - transfer <- buildTextCmd v $ set cbSigners + transfer <- buildTextCmd $ set cbSigners [ mkEd25519Signer' sender00 [ CapToken (QualifiedName "GAS" (ModuleName "coin" Nothing)) [] , CapToken (QualifiedName "TRANSFER" (ModuleName "coin" Nothing)) @@ -1232,78 +1070,80 @@ localTests baseRdb = let ] $ set cbRPC (mkExec' "(coin.transfer \"sender00\" \"sender01\" 100.0)") $ defaultCmd cid - send fx v cid [transfer] + send fx cid [transfer] advanceAllChains_ fx - buildTextCmd v (defaultCmd cid & set cbRPC (mkExec' "(coin.details 'sender00)")) - >>= local fx v cid Nothing Nothing Nothing - >>= P.match _Pact5LocalResultLegacy + buildTextCmd (defaultCmd cid & set cbRPC (mkExec' "(coin.details 'sender00)")) + >>= local fx cid Nothing Nothing Nothing + >>= P.match _LocalResultLegacy ? P.checkAll [ hasBalance ? P.lt startBalance , hasBlockHeight (P.equals 3) ] - buildTextCmd v (defaultCmd cid & set cbRPC (mkExec' "(coin.details 'sender00)")) - >>= local fx v cid Nothing Nothing (Just (RewindDepth 0)) - >>= P.match _Pact5LocalResultLegacy + buildTextCmd (defaultCmd cid & set cbRPC (mkExec' "(coin.details 'sender00)")) + >>= local fx cid Nothing Nothing (Just (RewindDepth 0)) + >>= P.match _LocalResultLegacy ? P.checkAll [ hasBalance ? P.lt startBalance , hasBlockHeight (P.equals 3) ] - buildTextCmd v (defaultCmd cid & set cbRPC (mkExec' "(coin.details 'sender00)")) - >>= local fx v cid Nothing Nothing (Just (RewindDepth 1)) - >>= P.match _Pact5LocalResultLegacy + buildTextCmd (defaultCmd cid & set cbRPC (mkExec' "(coin.details 'sender00)")) + >>= local fx cid Nothing Nothing (Just (RewindDepth 1)) + >>= P.match _LocalResultLegacy ? P.checkAll [ hasBalance ? P.equals startBalance , hasBlockHeight (P.equals 2) ] - buildTextCmd v (defaultCmd cid & set cbRPC (mkExec' "(coin.details 'sender00)")) - >>= local fx v cid Nothing Nothing (Just (RewindDepth 2)) - >>= P.match _Pact5LocalResultLegacy + buildTextCmd (defaultCmd cid & set cbRPC (mkExec' "(coin.details 'sender00)")) + >>= local fx cid Nothing Nothing (Just (RewindDepth 2)) + >>= P.match _LocalResultLegacy ? P.checkAll [ hasBalance ? P.equals startBalance , hasBlockHeight (P.equals 1) ] - buildTextCmd v (defaultCmd cid & set cbRPC (mkExec' "(coin.details 'sender00)")) - >>= local fx v cid Nothing Nothing (Just (RewindDepth 3)) - >>= P.match _Pact5LocalResultLegacy - ? P.checkAll - [ hasBalance ? P.equals startBalance - , hasBlockHeight (P.equals 1) - ] + buildTextCmd (defaultCmd cid & set cbRPC (mkExec' "(coin.details 'sender00)")) + >>= local fx cid Nothing Nothing (Just (RewindDepth 3)) + & P.throws + ? P.match _FailureResponse + ? P.fun responseBody + ? textContains "No block exists at the given rewind depth" - , withResourceT (mkFixture v baseRdb) $ \fx -> testCase "local continuation" $ do + , withVersion v $ withResourceT (mkFixture baseRdb) $ \fx -> testCase "local continuation" $ do let code = "(namespace 'free)(module m G (defcap G () true) (defpact p () (step (yield { \"a\" : (+ 1 1) })) (step (resume { \"a\" := a } a))))(free.m.p)" - initiator <- buildTextCmd v + initiator <- buildTextCmd $ set cbGasLimit (GasLimit (Gas 70_000)) $ set cbRPC (mkExec' code) $ defaultCmd cid - send fx v cid [initiator] + send fx cid [initiator] advanceAllChains_ fx - Just defPactId <- poll fx v cid [cmdToRequestKey initiator] + Just defPactId <- poll fx cid [cmdToRequestKey initiator] <&> preview (ix 0 . _Just . crContinuation . _Just . peDefPactId) - continuer <- buildTextCmd v + continuer <- buildTextCmd $ set cbRPC (mkCont (mkContMsg defPactId 1)) $ defaultCmd cid - local fx v cid Nothing Nothing Nothing continuer - >>= P.match _Pact5LocalResultLegacy ? P.fun _crResult + local fx cid Nothing Nothing Nothing continuer + >>= P.match _LocalResultLegacy ? P.fun _crResult ? P.match _PactResultOk ? P.equals (PInteger 2) ] + where + v = instantCpmTestVersion False petersenChainGraph + cid = unsafeChainId 0 + buildCmdMainnet = withVersion mainnet $ buildTextCmd (defaultCmd cid) + pollingMetadataTest :: RocksDb -> Step -> IO () -pollingMetadataTest baseRdb _step = runResourceT $ do - let v = pact5InstantCpmTestVersion False singletonChainGraph - let cid = unsafeChainId 0 - fx <- mkFixture v baseRdb +pollingMetadataTest baseRdb _step = withVersion v $ runResourceT $ do + fx <- mkFixture baseRdb liftIO $ do - cmd <- buildTextCmd v (defaultCmd cid) - send fx v cid [cmd] + cmd <- buildTextCmd (defaultCmd cid) + send fx cid [cmd] (_, commandResults) <- advanceAllChains fx -- there is no metadata in the actual block outputs commandResults @@ -1313,26 +1153,26 @@ pollingMetadataTest baseRdb _step = runResourceT $ do -- the metadata reported by poll has a different shape from that -- reported by /local - poll fx v cid [cmdToRequestKey cmd] >>= + poll fx cid [cmdToRequestKey cmd] >>= P.alignExact [ P.match _Just ? P.fun _crMetaData ? P.match _Just ? P.match A._Object ? P.alignExact ? A.KeyMap.fromList - [ ("blockHash", P.match A._String P.succeed) + [ ("blockHash", P.match (A._String . b64UrlNoPaddingPrism) P.succeed) , ("blockHeight", P.equals (A.Number 2)) - , ("blockTime", P.match A._Number P.succeed) - , ("prevBlockHash", P.match A._String P.succeed) + , ("blockPayloadHash", P.match (A._String . b64UrlNoPaddingPrism) P.succeed) ] ] + where + v = instantCpmTestVersion False singletonChainGraph + cid = unsafeChainId 0 upgradeNamespaceTests :: RocksDb -> Step -> IO () -upgradeNamespaceTests baseRdb _step = runResourceT $ do - let v = pact5InstantCpmTestVersion False singletonChainGraph - let cid = unsafeChainId 0 - fx <- mkFixture v baseRdb +upgradeNamespaceTests baseRdb _step = withVersion v $ runResourceT $ do + fx <- mkFixture baseRdb liftIO $ do upgradeNsContract <- T.readFile "pact/namespaces/ns.pact" do - unprivilegedUpgradeCmd <- buildTextCmd v $ + unprivilegedUpgradeCmd <- buildTextCmd $ set cbRPC (mkExec' upgradeNsContract) $ set cbSigners [mkEd25519Signer' sender00 @@ -1340,9 +1180,9 @@ upgradeNamespaceTests baseRdb _step = runResourceT $ do [CapToken (QualifiedName "GAS" (ModuleName "coin" Nothing)) []] ] $ defaultCmd cid - send fx v cid [unprivilegedUpgradeCmd] + send fx cid [unprivilegedUpgradeCmd] advanceAllChains_ fx - poll fx v cid [cmdToRequestKey unprivilegedUpgradeCmd] + poll fx cid [cmdToRequestKey unprivilegedUpgradeCmd] >>= P.match (_head . _Just) ? P.fun _crResult ? P.match _PactResultErr @@ -1350,45 +1190,48 @@ upgradeNamespaceTests baseRdb _step = runResourceT $ do ? P.fun _boundedText ? textContains "Keyset failure" do - privilegedUpgradeCmd <- buildTextCmd v $ + privilegedUpgradeCmd <- buildTextCmd $ set cbRPC (mkExec' upgradeNsContract) $ set cbSigners -- sender00 controls ns, and module upgrades require unscoped signatures [mkEd25519Signer' sender00 [] ] $ defaultCmd cid - send fx v cid [privilegedUpgradeCmd] + send fx cid [privilegedUpgradeCmd] advanceAllChains_ fx - poll fx v cid [cmdToRequestKey privilegedUpgradeCmd] + poll fx cid [cmdToRequestKey privilegedUpgradeCmd] >>= P.match (_head . _Just) ? P.fun _crResult ? P.match _PactResultOk ? P.match _PString ? textContains "Loaded module ns" + where + v = instantCpmTestVersion False singletonChainGraph + cid = unsafeChainId 0 invalidSigCapNameTest :: RocksDb -> Step -> IO () -invalidSigCapNameTest baseRdb _step = runResourceT $ do - let v = pact5InstantCpmTestVersion False singletonChainGraph +invalidSigCapNameTest baseRdb _step = withVersion (instantCpmTestVersion False singletonChainGraph) $ runResourceT $ do let cid = unsafeChainId 0 - fx <- mkFixture v baseRdb + fx <- mkFixture baseRdb liftIO $ do - badCmd <- buildTextCmd v $ + badCmd <- buildTextCmd $ set cbSigners [mkEd25519Signer' sender00 -- sender00 controls ns, but module upgrades require unscoped signatures [CapToken (QualifiedName "GAS " (ModuleName "coin" Nothing)) []] ] $ defaultCmd cid - send fx v cid [badCmd] + send fx cid [badCmd] & P.throws ? P.match _FailureResponse ? P.succeed advanceAllChains_ fx - poll fx v cid [cmdToRequestKey badCmd] + poll fx cid [cmdToRequestKey badCmd] >>= P.match (_head . _Nothing) P.succeed ----------------------------------------------------- + +-- ---------------------------------------------------- data Fixture = Fixture { _cutFixture :: CutFixture.Fixture @@ -1406,19 +1249,26 @@ instance HasFixture Fixture where instance HasFixture a => HasFixture (IO a) where remotePactTestFixture = (>>= remotePactTestFixture) -mkFixture :: ChainwebVersion -> RocksDb -> ResourceT IO Fixture -mkFixture v baseRdb = do - fx <- CutFixture.mkFixture v testPactServiceConfig baseRdb +instantCpmTestVersionGenesis :: ChainId -> PayloadWithOutputs +instantCpmTestVersionGenesis chain + | chain == unsafeChainId 0 = IN0.payloadBlock + | otherwise = INN.payloadBlock + +mkFixture :: HasVersion => RocksDb -> ResourceT IO Fixture +mkFixture baseRdb = do + fx <- CutFixture.mkFixture + instantCpmTestVersionGenesis + defaultPactServiceConfig { _pactBlockRefreshInterval = 10_000 } + baseRdb logger <- liftIO getTestLogger let mkSomePactServerData cid = PactServerData - { _pactServerDataCutDb = fx ^. CutFixture.fixtureCutDb - , _pactServerDataMempool = fx ^. CutFixture.fixtureMempools ^?! atChain cid + { _pactServerDataMempool = fx ^?! CutFixture.fixtureMempools . atChain cid , _pactServerDataLogger = logger - , _pactServerDataPact = mkPactExecutionService (fx ^. CutFixture.fixturePactQueues ^?! atChain cid) + , _pactServerDataPact = fx ^?! CutFixture.fixturePacts . atChain cid } - let pactServer = somePactServers v $ List.map (\cid -> (cid, mkSomePactServerData cid)) (HashSet.toList (chainIds v)) - let cutGetServer = someCutGetServer v (fx ^. CutFixture.fixtureCutDb) + let pactServer = somePactServers $ List.map (\cid -> (cid, mkSomePactServerData cid)) (HashSet.toList chainIds) + let cutGetServer = someCutGetServer (fx ^. CutFixture.fixtureCutDb) let app = someServerApplication (pactServer <> cutGetServer) -- Run pact server API @@ -1447,32 +1297,36 @@ newtype PollException = PollException String poll :: HasFixture fx + => HasVersion => fx - -> ChainwebVersion -> ChainId -> [RequestKey] -> IO [Maybe TestPact5CommandResult] -poll fx v cid rks = pollWithDepth fx v cid rks Nothing +poll fx cid rks = pollWithDepth fx cid rks Nothing pollWithDepth :: HasFixture fx + => HasVersion => fx - -> ChainwebVersion -> ChainId -> [RequestKey] -> Maybe ConfirmationDepth -> IO [Maybe TestPact5CommandResult] -pollWithDepth fx v cid rks mConfirmationDepth = do +pollWithDepth fx cid rks mConfirmationDepth = do clientEnv <- _serviceClientEnv <$> remotePactTestFixture fx let rksNel = NE.fromList rks - pollResult <- runClientM (pactPollWithQueryApiClient v cid mConfirmationDepth (Pact5.PollRequest rksNel)) clientEnv + pollResult <- runClientM (pactPollApiClient cid mConfirmationDepth (PollRequest rksNel)) clientEnv case pollResult of Left e -> do throwM (PollException (show e)) - Right (Pact5.PollResponse response) -> do + Right (PollResponse response) -> do -- the poll should only return results for commands -- that were polled for - response & P.fun HashMap.keys ? traverse_ ? P.fun (\rk -> elem rk rks) ? P.equals True + response + & P.fun HashMap.keys + ? traverse_ + ? P.fun (\rk -> elem rk rks) + ? P.equals True return (rks <&> (\rk -> HashMap.lookup rk response)) @@ -1487,53 +1341,53 @@ _FailureResponse = folding $ \case ClientException _ (FailureResponse _req resp) -> Just (TL.toStrict . TL.decodeUtf8 <$> resp) _ -> Nothing -send :: (HasCallStack, HasFixture fx) +send :: (HasVersion, HasCallStack, HasFixture fx) => fx - -> ChainwebVersion -> ChainId -> [Command Text] -> IO () -send fx v cid cmds = do +send fx cid cmds = do let commands = NE.fromList $ toListOf each cmds - let batch = Pact4.SubmitBatch (fmap toPact4Command commands) + let batch = SendRequest (SubmitBatch commands) clientEnv <- _serviceClientEnv <$> remotePactTestFixture fx - sendResult <- runClientM (pactSendApiClient v cid batch) clientEnv + sendResult <- runClientM (pactSendApiClient cid batch) clientEnv case sendResult of Left e -> do throwM (ClientException callStack e) - Right (Pact4.RequestKeys (fmap toPact5RequestKey -> response)) -> do + Right (SendResponse (RequestKeys response)) -> do -- the returned request keys should always be exactly the hashes -- of the commands response & P.equals (cmdToRequestKey <$> commands) -local :: (HasCallStack, HasFixture fx) +local :: (HasVersion, HasCallStack, HasFixture fx) => fx - -> ChainwebVersion -> ChainId -> Maybe LocalPreflightSimulation -> Maybe LocalSignatureVerification -> Maybe RewindDepth -> Command Text -> IO LocalResult -local fx v cid preflight sigVerify depth cmd = do +local fx cid preflight sigVerify depth cmd = do -- send a single local request and return the result -- clientEnv <- _serviceClientEnv <$> remotePactTestFixture fx - r <- runClientM (pactLocalWithQueryApiClient v cid preflight sigVerify depth (toPact4Command cmd)) clientEnv + r <- runClientM + (pactLocalApiClient cid preflight sigVerify depth cmd) + clientEnv either (throwM . ClientException callStack) return r -spvTxOutProof :: (HasCallStack, HasFixture fx) +spvTxOutProof :: (HasVersion, HasCallStack, HasFixture fx) => fx - -> ChainwebVersion -> ChainId -> ChainId -> RequestKey -> IO TransactionOutputProofB64 -spvTxOutProof fx v trgChain srcChain reqKey = do +spvTxOutProof fx trgChain srcChain reqKey = do clientEnv <- _serviceClientEnv <$> remotePactTestFixture fx - let pact4TrgChain = Pact4.ChainId $ toText trgChain - let pact4ReqKey = toPact4RequestKey reqKey - r <- runClientM (pactSpvApiClient v srcChain (SpvRequest pact4ReqKey pact4TrgChain)) clientEnv + let pactTrgChain = Pact.ChainId $ toText trgChain + r <- runClientM + (pactSpvApiClient srcChain (SpvRequest reqKey pactTrgChain)) + clientEnv either (throwM . ClientException callStack) return r pactDeadBeef :: RequestKey @@ -1545,24 +1399,3 @@ textContains expectedStr actualStr | expectedStr `T.isInfixOf` actualStr = P.succeed actualStr | otherwise = P.fail ("String containing: " <> PP.pretty expectedStr) actualStr - -checkPactVersion :: Fixture -> ChainwebVersion -> ChainId -> IO PactVersion -checkPactVersion fx v cid = do - cmd <- buildTextCmd v - $ set cbRPC (mkExec' "(do 1)") - $ defaultCmd cid - r <- local fx v cid (Just PreflightSimulation) Nothing Nothing cmd - case r of - LocalResultLegacy (getJsonText -> txt) -> do - if extractError txt == Just "Cannot resolve do" - then return Pact4 - else return Pact5 - LocalResultWithWarns (getJsonText -> txt) _warns -> do - if extractError txt == Just "Cannot resolve do" - then return Pact4 - else return Pact5 - anythingElse -> do - assertFailure $ "checkPactVersion: Unexpected result: " ++ show anythingElse - where - extractError :: Text -> Maybe Text - extractError json = json ^? A.key "result" . A.key "error" . A.key "message" . A._String diff --git a/test/unit/Chainweb/Test/Pact5/SPVTest.hs b/test/unit/Chainweb/Test/Pact/SPVTest.hs similarity index 83% rename from test/unit/Chainweb/Test/Pact5/SPVTest.hs rename to test/unit/Chainweb/Test/Pact/SPVTest.hs index 778ab74061..22811540ed 100644 --- a/test/unit/Chainweb/Test/Pact5/SPVTest.hs +++ b/test/unit/Chainweb/Test/Pact/SPVTest.hs @@ -19,19 +19,19 @@ {-# options_ghc -Wwarn #-} {-# options_ghc -w #-} -module Chainweb.Test.Pact5.SPVTest +module Chainweb.Test.Pact.SPVTest ( tests ) where import Data.ByteString.Base16 qualified as Base16 -import Chainweb.Block (Block (_blockPayloadWithOutputs)) +import Chainweb.Pact.Block (Block (_blockPayloadWithOutputs)) import System.Environment (lookupEnv, setEnv) import Control.Applicative ((<|>)) import Data.List qualified as List -import Chainweb.Payload.PayloadStore +import Chainweb.Pact.Payload.PayloadStore import Chainweb.Pact.Service.BlockValidation import Chainweb.Pact.Service.PactInProcApi -import Chainweb.Mempool.Consensus +import Chainweb.Pact.Mempool.Consensus import Chainweb.Pact.PactService import Chainweb.Pact.Service.PactQueue import Chainweb.BlockCreationTime @@ -41,14 +41,14 @@ import Chainweb.Chainweb import Chainweb.Cut import Chainweb.Graph (singletonChainGraph) import Chainweb.Logger -import Chainweb.Mempool.Consensus -import Chainweb.Mempool.InMem -import Chainweb.Mempool.Mempool (InsertType (..), LookupResult(..), MempoolBackend (..), TransactionHash(..)) +import Chainweb.Pact.Mempool.Consensus +import Chainweb.Pact.Mempool.InMem +import Chainweb.Pact.Mempool.Mempool (InsertType (..), LookupResult(..), MempoolBackend (..), TransactionHash(..)) import Chainweb.MerkleLogHash import Chainweb.MerkleUniverse (ChainwebMerkleHashAlgorithm) import Chainweb.Miner.Pact import Chainweb.Miner.Pact (noMiner) -import Chainweb.Pact5.Backend.ChainwebPactDb (Pact5Db (doPact5DbTransaction)) +import Chainweb.Pact.Backend.ChainwebPactDb (Pact5Db (doPact5DbTransaction)) import Chainweb.Pact.Backend.SQLite.DirectV2 (close_v2) import Chainweb.Pact.Backend.Utils import Chainweb.Pact.PactService @@ -62,23 +62,23 @@ import Chainweb.Pact.Service.PactQueue import Chainweb.Pact.Types import Chainweb.Pact.Types (defaultModuleCacheLimit, psBlockDbEnv, BlockInProgress (_blockInProgressTransactions)) import Chainweb.Pact.Utils (emptyPayload) -import Chainweb.Pact4.Transaction qualified as Pact4 -import Chainweb.Pact4.TransactionExec (applyGenesisCmd) -import Chainweb.Pact4.TransactionExec qualified -import Chainweb.Pact5.Transaction -import Chainweb.Pact5.Transaction qualified as Pact5 -import Chainweb.Pact5.TransactionExec -import Chainweb.Pact5.TransactionExec qualified -import Chainweb.Pact5.TransactionExec qualified as Pact5 -import Chainweb.Pact5.Types -import Chainweb.Payload -import Chainweb.Payload (PayloadWithOutputs_ (_payloadWithOutputsPayloadHash), Transaction (Transaction)) -import Chainweb.Payload.PayloadStore +import Chainweb.Pact.Transaction qualified as Pact +import Chainweb.Pact.TransactionExec (applyGenesisCmd) +import Chainweb.Pact.TransactionExec qualified +import Chainweb.Pact.Transaction +import Chainweb.Pact.Transaction qualified as Pact5 +import Chainweb.Pact.TransactionExec +import Chainweb.Pact.TransactionExec qualified +import Chainweb.Pact.TransactionExec qualified as Pact5 +import Chainweb.Pact.Types +import Chainweb.Pact.Payload +import Chainweb.Pact.Payload(PayloadWithOutputs_ (_payloadWithOutputsPayloadHash), Transaction (Transaction)) +import Chainweb.Pact.Payload.PayloadStore import Chainweb.Storage.Table.RocksDB import Chainweb.Test.Cut.TestBlockDb (TestBlockDb (_bdbPayloadDb, _bdbWebBlockHeaderDb), addTestBlockDb, getCutTestBlockDb, getParentTestBlockDb, mkTestBlockDb, setCutTestBlockDb) -import Chainweb.Test.Pact4.Utils (stdoutDummyLogger, testPactServiceConfig, withBlockHeaderDb) -import Chainweb.Test.Pact5.CmdBuilder -import Chainweb.Test.Pact5.Utils +import Chainweb.Test.Pact4.Utils (stdoutDummyLogger, defaultPactServiceConfig, withBlockHeaderDb) +import Chainweb.Test.Pact.CmdBuilder +import Chainweb.Test.Pact.Utils import Chainweb.Test.TestVersions import Chainweb.Test.Utils import Chainweb.Time @@ -128,8 +128,8 @@ import GHC.Stack import Hedgehog hiding (Update) import Hedgehog.Gen qualified as Gen import Hedgehog.Range qualified as Range -import "pact" Pact.Types.Command qualified as Pact4 -import "pact" Pact.Types.Hash qualified as Pact4 +import "pact" Pact.Types.Command qualified as Pact +import "pact" Pact.Types.Hash qualified as Pact import Numeric.AffineSpace import Pact.Core.Builtin import Pact.Core.Capabilities @@ -156,7 +156,7 @@ import Pact.Core.SPV (noSPVSupport) import Pact.Core.Serialise import Pact.Core.StableEncoding (encodeStable) import Pact.Core.Verifiers -import Pact.Types.Gas qualified as Pact4 +import Pact.Types.Gas qualified as Pact import PropertyMatchers ((?)) import PropertyMatchers qualified as P import Streaming.Prelude qualified as Stream @@ -201,7 +201,7 @@ roundtrip' roundtrip' v sid0 tid0 burn create step = withTestBlockDb v $ \bdb -> do tg <- newMVar mempty let logger = hunitDummyLogger step - withWebPactExecutionService logger v testPactServiceConfig bdb (chainToMPA' tg) $ \(pact,_) -> do + withWebPactExecutionService logger v defaultPactServiceConfig bdb (chainToMPA' tg) $ \(pact,_) -> do sid <- mkChainId v maxBound sid0 tid <- mkChainId v maxBound tid0 @@ -257,4 +257,4 @@ successfulTx :: P.Prop (CommandResult log err) successfulTx = P.fun _crResult ? P.match _PactResultOk P.succeed cid = unsafeChainId 0 -v = pact5InstantCpmTestVersion False singletonChainGraph +v = pact5InstantCpmTestVersion singletonChainGraph diff --git a/test/unit/Chainweb/Test/Pact5/SignedListPluginTests.hs b/test/unit/Chainweb/Test/Pact/SignedListPluginTests.hs similarity index 88% rename from test/unit/Chainweb/Test/Pact5/SignedListPluginTests.hs rename to test/unit/Chainweb/Test/Pact/SignedListPluginTests.hs index 9f02a3d7c3..35120eed23 100644 --- a/test/unit/Chainweb/Test/Pact5/SignedListPluginTests.hs +++ b/test/unit/Chainweb/Test/Pact/SignedListPluginTests.hs @@ -3,7 +3,7 @@ {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE RecordWildCards #-} -module Chainweb.Test.Pact5.SignedListPluginTests (tests) where +module Chainweb.Test.Pact.SignedListPluginTests (tests) where import Control.Lens import Control.Monad.IO.Class @@ -23,10 +23,10 @@ import Test.Tasty.HUnit (testCaseSteps, assertFailure) import Chainweb.Graph import Chainweb.Storage.Table.RocksDB (RocksDb) -import Chainweb.Test.Pact5.CmdBuilder -import Chainweb.Test.Pact5.CutFixture (advanceAllChains_) -import Chainweb.Test.Pact5.RemotePactTest hiding (tests) -import Chainweb.Test.Pact5.Utils +import Chainweb.Test.Pact.CmdBuilder +import Chainweb.Test.Pact.CutFixture (advanceAllChains_) +import Chainweb.Test.Pact.RemotePactTest hiding (tests) +import Chainweb.Test.Pact.Utils import Chainweb.Test.TestVersions import Chainweb.Test.Utils @@ -40,7 +40,7 @@ import Pact.Core.Verifiers -- | Test suite v :: ChainwebVersion -v = pact5InstantCpmTestVersion False petersenChainGraph +v = instantCpmTestVersion False petersenChainGraph chain0 :: ChainId chain0 = unsafeChainId 0 @@ -97,8 +97,8 @@ plist :: [PactValue] -> PactValue plist = PList . V.fromList signedListTestTemplate :: RocksDb -> SignedListTest -> TestTree -signedListTestTemplate baseRdb SignedListTest{..} = testCaseSteps sltName $ \step -> runResourceT $ do - fx <- mkFixture v baseRdb +signedListTestTemplate baseRdb SignedListTest{..} = withVersion v $ testCaseSteps sltName $ \step -> runResourceT $ do + fx <- mkFixture baseRdb liftIO $ do deployContract fx step step "use plugin" @@ -107,14 +107,14 @@ signedListTestTemplate baseRdb SignedListTest{..} = testCaseSteps sltName $ \ste _ -> assertFailure "Failed to decode proof JSON" let cap = CapToken (QualifiedName "K" (ModuleName "m" (Just (NamespaceName "free")))) sltCapArgsEnv - usePlugin <- buildTextCmd v + usePlugin <- buildTextCmd $ set cbRPC (mkExec' "(free.m.x)") $ set cbVerifiers [Verifier (VerifierName "signed_list") prf [SigCapability cap]] $ set cbGasLimit (GasLimit (Gas 100000)) $ defaultCmd chain0 - send fx v chain0 [usePlugin] + send fx chain0 [usePlugin] advanceAllChains_ fx - poll fx v chain0 [cmdToRequestKey usePlugin] >>= \result -> do + poll fx chain0 [cmdToRequestKey usePlugin] >>= \result -> do P.list [P.match _Just ? P.checkAll [ if sltExpectSuccess then successfulTx else case sltExpectedErrMsg of @@ -122,10 +122,10 @@ signedListTestTemplate baseRdb SignedListTest{..} = testCaseSteps sltName $ \ste Nothing -> P.fail "should have suceed..." ]] result where - deployContract :: Fixture -> Step -> IO () + deployContract :: HasVersion => Fixture -> Step -> IO () deployContract fx step = do step "deploy contract" - deploy <- buildTextCmd v + deploy <- buildTextCmd $ set cbGasLimit (GasLimit (Gas 100000)) $ set cbRPC (mkExec' $ mconcat [ "(namespace 'free)" @@ -135,9 +135,9 @@ signedListTestTemplate baseRdb SignedListTest{..} = testCaseSteps sltName $ \ste , "(defun x () (with-capability (K ", sltCapArgsContract ,") 1)))" ]) $ defaultCmd chain0 - send fx v chain0 [deploy] + send fx chain0 [deploy] advanceAllChains_ fx - poll fx v chain0 [cmdToRequestKey deploy] >>= P.list [P.match _Just successfulTx] + poll fx chain0 [cmdToRequestKey deploy] >>= P.list [P.match _Just successfulTx] -- -- | Test data diff --git a/test/unit/Chainweb/Test/Pact5/TransactionExecTest.hs b/test/unit/Chainweb/Test/Pact/TransactionExecTest.hs similarity index 72% rename from test/unit/Chainweb/Test/Pact5/TransactionExecTest.hs rename to test/unit/Chainweb/Test/Pact/TransactionExecTest.hs index 6561e9a0a4..09682fd775 100644 --- a/test/unit/Chainweb/Test/Pact5/TransactionExecTest.hs +++ b/test/unit/Chainweb/Test/Pact/TransactionExecTest.hs @@ -14,32 +14,36 @@ {-# LANGUAGE TypeApplications #-} {-# LANGUAGE UndecidableInstances #-} -module Chainweb.Test.Pact5.TransactionExecTest (tests) where +module Chainweb.Test.Pact.TransactionExecTest (tests) where import Chainweb.BlockHeader -import Chainweb.Graph (singletonChainGraph, petersenChainGraph) -import Chainweb.Miner.Pact (Miner(..), MinerId(..), MinerKeys(..), noMiner) +import Chainweb.BlockHeader.Genesis.InstantTimedCPM0Payload qualified as PIN0 +import Chainweb.Graph (petersenChainGraph) +import Chainweb.Logger +import Chainweb.Miner.Pact (Miner(..), MinerId(..), MinerGuard(..), noMiner) +import Chainweb.Pact.Backend.InMemDb qualified as InMemDb +import Chainweb.Pact.Backend.Types import Chainweb.Pact.PactService (initialPayloadState, withPactService) -import Chainweb.Pact.PactService.Checkpointer (readFrom, SomeBlockM(..)) +import Chainweb.Pact.PactService.Checkpointer (readFrom, mkFakeParentCreationTime) +import Chainweb.Pact.PactService.Checkpointer qualified as Checkpointer +import Chainweb.Pact.Transaction +import Chainweb.Pact.TransactionExec import Chainweb.Pact.Types -import Chainweb.Pact5.Transaction -import Chainweb.Pact5.TransactionExec -import Chainweb.Pact5.Types +import Chainweb.Parent import Chainweb.Storage.Table.RocksDB -import Chainweb.Test.Cut.TestBlockDb (TestBlockDb (_bdbPayloadDb, _bdbWebBlockHeaderDb), mkTestBlockDb) -import Chainweb.Test.Pact5.CmdBuilder +import Chainweb.Test.Cut.TestBlockDb (TestBlockDb (_bdbPayloadDb), mkTestBlockDb) +import Chainweb.Test.Pact.CmdBuilder +import Chainweb.Test.Pact.Utils import Chainweb.Test.TestVersions import Chainweb.Test.Utils -import Chainweb.Utils (T2(..)) import Chainweb.Version -import Chainweb.WebBlockHeaderDB (getWebBlockHeaderDb) import Control.Lens hiding (only) import Control.Monad.Except import Control.Monad.IO.Class import Control.Monad.Reader +import Control.Monad.State.Strict import Control.Monad.Trans.Resource import Data.Decimal -import Data.Functor.Product import Data.HashMap.Strict qualified as HashMap import Data.IORef import Data.Maybe (fromMaybe) @@ -48,7 +52,6 @@ import Data.String (fromString) import Data.Text qualified as T import Data.Text.Encoding qualified as T import Data.Text.IO qualified as T -import Chainweb.Test.Pact5.Utils hiding (withTempSQLiteResource) import GHC.Stack import Pact.Core.Capabilities import Pact.Core.Command.Types hiding (ChainId) @@ -57,22 +60,19 @@ import Pact.Core.Errors import Pact.Core.Evaluate import Pact.Core.Gas.TableGasModel import Pact.Core.Gas.Types +import Pact.Core.Guards qualified as Pact import Pact.Core.Hash import Pact.Core.Names import Pact.Core.PactValue import Pact.Core.Persistence hiding (pactDb) import Pact.Core.SPV (noSPVSupport) import Pact.Core.Verifiers -import Pact.Types.KeySet qualified as Pact4 import Pact.JSON.Encode qualified as J import PropertyMatchers ((?), pattern (:=>)) import PropertyMatchers qualified as P import Test.Tasty import Test.Tasty.HUnit (assertEqual, testCase) import Text.Printf -import Chainweb.Logger -import Chainweb.Pact.Backend.InMemDb qualified as InMemDb -import Chainweb.Pact.Backend.Types tests :: RocksDb -> TestTree tests baseRdb = testGroup "Pact5 TransactionExecTest" @@ -88,7 +88,6 @@ tests baseRdb = testGroup "Pact5 TransactionExecTest" , testCase "applyCmd failure spec" (applyCmdFailureSpec baseRdb) , testCase "applyCmd coin.transfer" (applyCmdCoinTransfer baseRdb) , testCase "applyCoinbase spec" (applyCoinbaseSpec baseRdb) - , testCase "test coin upgrade" (testCoinUpgrade baseRdb) , testCase "test local only fails outside of local" (testLocalOnlyFailsOutsideOfLocal baseRdb) , testCase "payload failure all gas should go to the miner - type error" (payloadFailureShouldPayAllGasToTheMinerTypeError baseRdb) , testCase "payload failure all gas should go to the miner - insufficient funds" (payloadFailureShouldPayAllGasToTheMinerInsufficientFunds baseRdb) @@ -96,7 +95,6 @@ tests baseRdb = testGroup "Pact5 TransactionExecTest" , testCase "writes from failed transaction should not make it into the db" (testWritesFromFailedTxDontMakeItIn baseRdb) , testCase "quirk spec" (quirkSpec baseRdb) , testCase "test writes to nonexistent tables" (testWritesToNonExistentTables baseRdb) - , testCase "test CommandResult 5 is valid for 4" (testCommandResult5To4 baseRdb) , testCase "test hash-keccak256" (testKeccak256 baseRdb) ] @@ -105,57 +103,55 @@ tests baseRdb = testGroup "Pact5 TransactionExecTest" -- focused on the transaction level. Tests that need to be aware of blocks, for -- example to observe database writes, belong in a different suite, like -- PactServiceTest or RemotePactTest. -readFromAfterGenesis :: ChainwebVersion -> RocksDb -> PactBlockM GenericLogger RocksDbTable a -> IO a -readFromAfterGenesis ver rdb act = runResourceT $ do - sql <- withTempSQLiteResource - tdb <- mkTestBlockDb ver rdb +readFromAfterGenesis :: HasVersion => RocksDb -> (BlockEnv -> BlockHandle -> IO a) -> IO a +readFromAfterGenesis rdb act = runResourceT $ do + (writeSql, readPool) <- withTempChainSqlite cid + tdb <- mkTestBlockDb rdb + -- fake ro-sql pool, assuming we're using this single-threaded + logger <- liftIO $ testLogger + serviceEnv <- withPactService cid Nothing mempty logger Nothing (_bdbPayloadDb tdb) readPool writeSql defaultPactServiceConfig (GenesisPayload PIN0.payloadBlock) liftIO $ do - bhdb <- getWebBlockHeaderDb (_bdbWebBlockHeaderDb tdb) cid - logger <- testLogger - T2 a _finalPactState <- withPactService ver cid logger Nothing bhdb (_bdbPayloadDb tdb) sql testPactServiceConfig $ do - initialPayloadState ver cid - throwIfNoHistory =<< - readFrom - (Just $ ParentHeader (gh ver cid)) - (SomeBlockM $ Pair (error "Pact4") act) - return a + initialPayloadState logger serviceEnv + fakeParentCreationTime <- mkFakeParentCreationTime + throwIfNoHistory =<< + readFrom logger cid writeSql fakeParentCreationTime + (Parent (gh cid ^. rankedBlockHash)) + (Checkpointer.readPact5 "unexpected Pact 4" $ act) buyGasShouldTakeGasTokensFromTheTransactionSender :: RocksDb -> IO () -buyGasShouldTakeGasTokensFromTheTransactionSender rdb = readFromAfterGenesis v rdb $ - pactTransaction Nothing $ \pactDb -> do +buyGasShouldTakeGasTokensFromTheTransactionSender rdb = withVersion v $ readFromAfterGenesis rdb $ \blockEnv blockHandle -> + flip evalStateT blockHandle $ doChainwebPactDbTransaction (blockEnv ^. psBlockDbEnv) Nothing $ \pactDb _spv -> do startSender00Bal <- readBal pactDb "sender00" assertEqual "starting balance" (Just 100_000_000) startSender00Bal - cmd <- buildCwCmd v (defaultCmd cid) + cmd <- buildCwCmd (defaultCmd cid) { _cbGasPrice = GasPrice 2 , _cbGasLimit = GasLimit (Gas 200) } - let txCtx = TxContext { _tcParentHeader = ParentHeader (gh v cid), _tcMiner = noMiner } gasEnv <- mkTableGasEnv (MilliGasLimit mempty) GasLogsEnabled logger <- testLogger - _ <- buyGas logger gasEnv pactDb txCtx (view payloadObj <$> cmd) + _ <- buyGas logger gasEnv pactDb noMiner (_psBlockCtx blockEnv) (view payloadObj <$> cmd) endSender00Bal <- readBal pactDb "sender00" assertEqual "balance after buying gas" (Just $ 100_000_000 - 200 * 2) endSender00Bal buyGasFailures :: RocksDb -> IO () -buyGasFailures rdb = readFromAfterGenesis v rdb $ do - pactTransaction Nothing $ \pactDb -> do +buyGasFailures rdb = withVersion v $ readFromAfterGenesis rdb $ \blockEnv blockHandle -> do + flip evalStateT blockHandle $ doChainwebPactDbTransaction (blockEnv ^. psBlockDbEnv) Nothing $ \pactDb _spv -> do startSender00Bal <- readBal pactDb "sender00" assertEqual "starting balance" (Just 100_000_000) startSender00Bal -- buying gas with insufficient balance to pay for the full supply -- (gas price * gas limit) should return an error do - cmd <- buildCwCmd v (defaultCmd cid) + cmd <- buildCwCmd (defaultCmd cid) { _cbGasPrice = GasPrice 70_000 , _cbGasLimit = GasLimit (Gas 100_000) } - let txCtx' = TxContext {_tcParentHeader = ParentHeader (gh v cid), _tcMiner = noMiner} gasEnv <- mkTableGasEnv (MilliGasLimit mempty) GasLogsEnabled logger <- testLogger - buyGas logger gasEnv pactDb txCtx' (view payloadObj <$> cmd) + buyGas logger gasEnv pactDb noMiner (_psBlockCtx blockEnv) (view payloadObj <$> cmd) >>= P.match (_Left . _BuyGasPactError . _PEUserRecoverableError) ? P.fun (view _1) ? P.equals (UserEnforceError "Insufficient funds") @@ -163,7 +159,7 @@ buyGasFailures rdb = readFromAfterGenesis v rdb $ do -- multiple gas payer caps should lead to an error, because it's unclear -- which module will pay for gas do - cmd <- buildCwCmd v (defaultCmd cid) + cmd <- buildCwCmd (defaultCmd cid) { _cbSigners = [ mkEd25519Signer' sender00 [ CapToken (QualifiedName "GAS" (ModuleName "coin" Nothing)) [] @@ -172,46 +168,46 @@ buyGasFailures rdb = readFromAfterGenesis v rdb $ do ] ] } - let txCtx' = TxContext {_tcParentHeader = ParentHeader (gh v cid), _tcMiner = noMiner} gasEnv <- mkTableGasEnv (MilliGasLimit mempty) GasLogsEnabled logger <- testLogger - buyGas logger gasEnv pactDb txCtx' (view payloadObj <$> cmd) + buyGas logger gasEnv pactDb noMiner (_psBlockCtx blockEnv) (view payloadObj <$> cmd) >>= P.equals ? Left BuyGasMultipleGasPayerCaps redeemGasShouldGiveGasTokensToTheTransactionSenderAndMiner :: RocksDb -> IO () -redeemGasShouldGiveGasTokensToTheTransactionSenderAndMiner rdb = readFromAfterGenesis v rdb $ do - pactTransaction Nothing $ \pactDb -> do - startSender00Bal <- readBal pactDb "sender00" - assertEqual "starting balance" (Just 100_000_000) startSender00Bal - startMinerBal <- readBal pactDb "NoMiner" - - cmd <- buildCwCmd v (defaultCmd cid) - { _cbGasPrice = GasPrice 2 - , _cbGasLimit = GasLimit (Gas 10) - } - let txCtx = TxContext {_tcParentHeader = ParentHeader (gh v cid), _tcMiner = noMiner} - -- redeeming gas with 3 gas used, with a limit of 10, should return 7 gas worth of tokens - -- to the gas payer +redeemGasShouldGiveGasTokensToTheTransactionSenderAndMiner rdb = + withVersion v $ readFromAfterGenesis rdb $ \blockEnv blockHandle -> do + flip evalStateT blockHandle $ doChainwebPactDbTransaction (blockEnv ^. psBlockDbEnv) Nothing $ \pactDb _spv -> do + startSender00Bal <- readBal pactDb "sender00" + assertEqual "starting balance" (Just 100_000_000) startSender00Bal + startMinerBal <- readBal pactDb "NoMiner" + + cmd <- buildCwCmd (defaultCmd cid) + { _cbGasPrice = GasPrice 2 + , _cbGasLimit = GasLimit (Gas 10) + } + -- redeeming gas with 3 gas used, with a limit of 10, should return 7 gas worth of tokens + -- to the gas payer - -- TODO: should we be throwing some predicates at the redeem gas result? - logger <- testLogger - redeemGas logger pactDb txCtx (Gas 3) Nothing (view payloadObj <$> cmd) - >>= P.match _Right ? P.succeed - endSender00Bal <- readBal pactDb "sender00" - assertEqual "balance after redeeming gas" (Just $ 100_000_000 + (10 - 3) * 2) endSender00Bal - endMinerBal <- readBal pactDb "NoMiner" - assertEqual "miner balance after redeeming gas" (Just $ fromMaybe 0 startMinerBal + 3 * 2) endMinerBal + -- TODO: should we be throwing some predicates at the redeem gas result? + logger <- testLogger + redeemGas logger pactDb noMiner (_psBlockCtx blockEnv) (Gas 3) Nothing (view payloadObj <$> cmd) + >>= P.match _Right ? P.succeed + endSender00Bal <- readBal pactDb "sender00" + assertEqual "balance after redeeming gas" (Just $ 100_000_000 + (10 - 3) * 2) endSender00Bal + endMinerBal <- readBal pactDb "NoMiner" + assertEqual "miner balance after redeeming gas" (Just $ fromMaybe 0 startMinerBal + 3 * 2) endMinerBal redeemGasFailure :: RocksDb -> IO () -redeemGasFailure rdb = readFromAfterGenesis v rdb $ do - pactTransaction Nothing $ \pactDb -> do +redeemGasFailure rdb = withVersion v $ readFromAfterGenesis rdb $ \blockEnv blockHandle -> do + flip evalStateT blockHandle $ doChainwebPactDbTransaction (blockEnv ^. psBlockDbEnv) Nothing $ \pactDb _spv -> do let miner = Miner (MinerId "sender00") - $ MinerKeys - $ Pact4.mkKeySet - [Pact4.PublicKeyText $ fst sender00] - "keys-all" + $ MinerGuard + $ Pact.GKeyset + $ Pact.KeySet + (Set.singleton (Pact.PublicKeyText $ fst sender00)) + Pact.KeysAll - cmd <- buildCwCmd v + cmd <- buildCwCmd $ set cbRPC (mkExec ("(coin.rotate \"sender00\" (read-keyset 'ks))") (mkKeySetData "ks" [sender01])) $ set cbSigners [ mkEd25519Signer' sender00 @@ -220,45 +216,42 @@ redeemGasFailure rdb = readFromAfterGenesis v rdb $ do ] ] $ defaultCmd cid - let txCtx = TxContext {_tcParentHeader = ParentHeader (gh v cid), _tcMiner = miner} logger <- testLogger - applyCmd logger Nothing pactDb txCtx (TxBlockIdx 0) noSPVSupport (Gas 1) (view payloadObj <$> cmd) + applyCmd logger Nothing pactDb miner (_psBlockCtx blockEnv) (TxBlockIdx 0) noSPVSupport (Gas 1) (view payloadObj <$> cmd) >>= P.match _Left - ? P.match (_RedeemGasError . _2 . _RedeemGasPactError) + ? P.match (_RedeemGasError . _RedeemGasPactError) ? P.match (_PEUserRecoverableError . _1) ? P.equals (UserEnforceError "account guards do not match") purchaseGasTxTooBig :: RocksDb -> IO () -purchaseGasTxTooBig rdb = readFromAfterGenesis v rdb $ do - pactTransaction Nothing $ \pactDb -> do - cmd <- buildCwCmd v +purchaseGasTxTooBig rdb = withVersion v $ readFromAfterGenesis rdb $ \blockEnv blockHandle -> do + flip evalStateT blockHandle $ doChainwebPactDbTransaction (blockEnv ^. psBlockDbEnv) Nothing $ \pactDb _spv -> do + cmd <- buildCwCmd $ set cbSender "sender00" $ set cbSigners [mkEd25519Signer' sender00 []] $ set cbGasLimit (GasLimit (Gas 1)) -- We set the gas limit to lower than the initialGas passed to applyCmd so that this test fails $ defaultCmd cid - let txCtx = TxContext {_tcParentHeader = ParentHeader (gh v cid), _tcMiner = noMiner} logger <- testLogger - applyCmd logger Nothing pactDb txCtx (TxBlockIdx 0) noSPVSupport (Gas 2) (view payloadObj <$> cmd) + applyCmd logger Nothing pactDb noMiner (_psBlockCtx blockEnv) (TxBlockIdx 0) noSPVSupport (Gas 2) (view payloadObj <$> cmd) >>= P.match _Left ? P.match _PurchaseGasTxTooBigForGasLimit ? P.succeed payloadFailureShouldPayAllGasToTheMinerTypeError :: RocksDb -> IO () -payloadFailureShouldPayAllGasToTheMinerTypeError rdb = readFromAfterGenesis v rdb $ do - pactTransaction Nothing $ \pactDb -> do +payloadFailureShouldPayAllGasToTheMinerTypeError rdb = withVersion v $ readFromAfterGenesis rdb $ \blockEnv blockHandle -> do + flip evalStateT blockHandle $ doChainwebPactDbTransaction (blockEnv ^. psBlockDbEnv) Nothing $ \pactDb _spv -> do startSender00Bal <- readBal pactDb "sender00" assertEqual "starting balance" (Just 100_000_000) startSender00Bal startMinerBal <- readBal pactDb "NoMiner" - cmd <- buildCwCmd v (defaultCmd cid) + cmd <- buildCwCmd (defaultCmd cid) { _cbRPC = mkExec' "(+ 1 \"hello\")" , _cbGasPrice = GasPrice 2 , _cbGasLimit = GasLimit (Gas 1000) } let gasToMiner = 2 * 1_000 -- gasPrice * gasLimit - let txCtx = TxContext {_tcParentHeader = ParentHeader (gh v cid), _tcMiner = noMiner} logger <- testLogger - applyCmd logger Nothing pactDb txCtx (TxBlockIdx 0) noSPVSupport (Gas 1) (view payloadObj <$> cmd) + applyCmd logger Nothing pactDb noMiner (_psBlockCtx blockEnv) (TxBlockIdx 0) noSPVSupport (Gas 1) (view payloadObj <$> cmd) >>= P.match _Right ? P.checkAll [ P.fun _crResult @@ -289,13 +282,13 @@ payloadFailureShouldPayAllGasToTheMinerTypeError rdb = readFromAfterGenesis v rd assertEqual "miner balance after payload failure" (Just $ fromMaybe 0 startMinerBal + gasToMiner) endMinerBal payloadFailureShouldPayAllGasToTheMinerInsufficientFunds :: RocksDb -> IO () -payloadFailureShouldPayAllGasToTheMinerInsufficientFunds rdb = readFromAfterGenesis v rdb $ - pactTransaction Nothing $ \pactDb -> do +payloadFailureShouldPayAllGasToTheMinerInsufficientFunds rdb = withVersion v $ readFromAfterGenesis rdb $ \blockEnv blockHandle -> + flip evalStateT blockHandle $ doChainwebPactDbTransaction (blockEnv ^. psBlockDbEnv) Nothing $ \pactDb _spv -> do startSender00Bal <- readBal pactDb "sender00" assertEqual "starting balance" (Just 100_000_000) startSender00Bal startMinerBal <- readBal pactDb "NoMiner" - cmd <- buildCwCmd v (defaultCmd cid) + cmd <- buildCwCmd (defaultCmd cid) { _cbRPC = mkExec' $ fromString $ "(coin.transfer \"sender00\" \"sender01\" " <> printf "%.f" (realToFrac @_ @Double $ fromMaybe 0 startSender00Bal + 1) @@ -310,9 +303,8 @@ payloadFailureShouldPayAllGasToTheMinerInsufficientFunds rdb = readFromAfterGene , _cbGasLimit = GasLimit (Gas 1000) } let gasToMiner = 2 * 1_000 -- gasPrice * gasLimit - let txCtx = TxContext {_tcParentHeader = ParentHeader (gh v cid), _tcMiner = noMiner} logger <- testLogger - applyCmd logger Nothing pactDb txCtx (TxBlockIdx 0) noSPVSupport (Gas 1) (view payloadObj <$> cmd) + applyCmd logger Nothing pactDb noMiner (_psBlockCtx blockEnv) (TxBlockIdx 0) noSPVSupport (Gas 1) (view payloadObj <$> cmd) >>= P.match _Right ? P.checkAll [ P.fun _crResult @@ -344,18 +336,17 @@ payloadFailureShouldPayAllGasToTheMinerInsufficientFunds rdb = readFromAfterGene assertEqual "miner balance after payload failure" (Just $ fromMaybe 0 startMinerBal + gasToMiner) endMinerBal runPayloadShouldReturnEvalResultRelatedToTheInputCommand :: RocksDb -> IO () -runPayloadShouldReturnEvalResultRelatedToTheInputCommand rdb = readFromAfterGenesis v rdb $ - pactTransaction Nothing $ \pactDb -> do - cmd <- buildCwCmd v (defaultCmd cid) +runPayloadShouldReturnEvalResultRelatedToTheInputCommand rdb = withVersion v $ readFromAfterGenesis rdb $ \blockEnv blockHandle -> do + flip evalStateT blockHandle $ doChainwebPactDbTransaction (blockEnv ^. psBlockDbEnv) Nothing $ \pactDb _spv -> do + cmd <- buildCwCmd (defaultCmd cid) { _cbRPC = mkExec' "(fold + 0 [1 2 3 4 5])" } - let txCtx = TxContext {_tcParentHeader = ParentHeader (gh v cid), _tcMiner = noMiner} gasEnv <- mkTableGasEnv (MilliGasLimit (gasToMilliGas $ Gas 10)) GasLogsEnabled logger <- testLogger payloadResult <- runExceptT $ runReaderT (runTransactionM - (runPayload Transactional Set.empty pactDb noSPVSupport [] managedNamespacePolicy gasEnv txCtx (TxBlockIdx 0) (view payloadObj <$> cmd))) + (runPayload Transactional Set.empty pactDb noSPVSupport [] managedNamespacePolicy gasEnv (_psBlockCtx blockEnv) (TxBlockIdx 0) (view payloadObj <$> cmd))) (TransactionEnv logger gasEnv) gasUsed <- readIORef (_geGasRef gasEnv) @@ -374,19 +365,18 @@ runPayloadShouldReturnEvalResultRelatedToTheInputCommand rdb = readFromAfterGene -- applyLocal should mostly be the same as applyCmd, this is mostly a smoke test applyLocalSpec :: RocksDb -> IO () -applyLocalSpec rdb = readFromAfterGenesis v rdb $ - pactTransaction Nothing $ \pactDb -> do +applyLocalSpec rdb = withVersion v $ readFromAfterGenesis rdb $ \blockEnv blockHandle -> do + flip evalStateT blockHandle $ doChainwebPactDbTransaction (blockEnv ^. psBlockDbEnv) Nothing $ \pactDb _spv -> do startSender00Bal <- readBal pactDb "sender00" assertEqual "starting balance" (Just 100_000_000) startSender00Bal startMinerBal <- readBal pactDb "NoMiner" - cmd <- buildCwCmd v (defaultCmd cid) + cmd <- buildCwCmd (defaultCmd cid) { _cbRPC = mkExec' "(fold + 0 [1 2 3 4 5])" , _cbSigners = [] } - let txCtx = TxContext {_tcParentHeader = ParentHeader (gh v cid), _tcMiner = noMiner} logger <- testLogger - applyLocal logger Nothing pactDb txCtx noSPVSupport (view payloadObj <$> cmd) + applyLocal logger Nothing pactDb (_psBlockCtx blockEnv) noSPVSupport (view payloadObj <$> cmd) >>= P.checkAll -- Local has no buy gas, therefore -- no gas buy event @@ -405,24 +395,23 @@ applyLocalSpec rdb = readFromAfterGenesis v rdb $ assertEqual "miner balance after redeeming gas should have increased" startMinerBal endMinerBal applyCmdSpec :: RocksDb -> IO () -applyCmdSpec rdb = readFromAfterGenesis v rdb $ do - pactTransaction Nothing $ \pactDb -> do +applyCmdSpec rdb = withVersion v $ readFromAfterGenesis rdb $ \blockEnv blockHandle -> do + bh <- flip execStateT blockHandle $ doChainwebPactDbTransaction (blockEnv ^. psBlockDbEnv) Nothing $ \pactDb _spv -> do startSender00Bal <- readBal pactDb "sender00" let expectedStartingBal = 100_000_000 assertEqual "starting balance" (Just expectedStartingBal) startSender00Bal startMinerBal <- readBal pactDb "NoMiner" - cmd <- buildCwCmd v (defaultCmd cid) + cmd <- buildCwCmd (defaultCmd cid) { _cbRPC = mkExec' "(fold + 0 [1 2 3 4 5])" , _cbGasPrice = GasPrice 2 , _cbGasLimit = GasLimit (Gas 500) -- no caps should be equivalent to the GAS cap , _cbSigners = [mkEd25519Signer' sender00 []] } - let txCtx = TxContext {_tcParentHeader = ParentHeader (gh v cid), _tcMiner = noMiner} let expectedGasConsumed = 73 logger <- testLogger - applyCmd logger Nothing pactDb txCtx (TxBlockIdx 0) noSPVSupport (Gas 1) (view payloadObj <$> cmd) + applyCmd logger Nothing pactDb noMiner (_psBlockCtx blockEnv) (TxBlockIdx 0) noSPVSupport (Gas 1) (view payloadObj <$> cmd) >>= P.match _Right ? P.checkAll -- only the event reflecting the final transfer to the miner for gas used @@ -464,44 +453,40 @@ applyCmdSpec rdb = readFromAfterGenesis v rdb $ do endMinerBal -- test cache contents - use pbBlockHandle >>= \bh -> liftIO $ bh - & P.fun _blockHandlePending - ? P.fun _pendingWrites - ? P.checkAll - [ P.fun InMemDb.userTables - ? P.alignExact ? HashMap.fromList - [ TableName "coin-table" (ModuleName "coin" Nothing) :=> - P.alignExact ? HashMap.fromList - [ RowKey "NoMiner" :=> - P.match InMemDb._WriteEntry P.succeed - , RowKey "sender00" :=> - P.match InMemDb._WriteEntry P.succeed - ] - ] + liftIO $ bh + & P.fun _blockHandlePending + ? P.fun _pendingWrites + ? P.checkAll + [ P.fun InMemDb.userTables + ? P.alignExact ? HashMap.fromList + [ TableName "coin-table" (ModuleName "coin" Nothing) :=> + P.alignExact ? HashMap.fromList + [ RowKey "NoMiner" :=> + P.match InMemDb._WriteEntry P.succeed + , RowKey "sender00" :=> + P.match InMemDb._WriteEntry P.succeed + ] + ] - , P.fun InMemDb.modules - ? P.alignExact ? HashMap.fromList - [ ModuleName "coin" Nothing :=> - P.match InMemDb._ReadEntry P.succeed - ] - ] + , P.fun InMemDb.modules + ? P.alignExact ? HashMap.fromList + [ ModuleName "coin" Nothing :=> + P.match InMemDb._ReadEntry P.succeed + ] + ] quirkSpec :: RocksDb -> IO () -quirkSpec rdb = readFromAfterGenesis quirkVer rdb $ - pactTransaction Nothing $ \pactDb -> do - cmd <- buildCwCmd v (defaultCmd cid) +quirkSpec rdb = withVersion quirkVer $ readFromAfterGenesis rdb $ \blockEnv blockHandle -> + flip evalStateT blockHandle $ doChainwebPactDbTransaction (blockEnv ^. psBlockDbEnv) Nothing $ \pactDb _spv -> do + cmd <- buildCwCmd (defaultCmd cid) { _cbRPC = mkExec' "(* 1000 200000)" , _cbSigners = [mkEd25519Signer' sender00 []] , _cbSender = "sender00" , _cbGasPrice = GasPrice 2 , _cbGasLimit = GasLimit (Gas 70_000) } - let txCtx = TxContext - { _tcParentHeader = ParentHeader (gh quirkVer cid) - , _tcMiner = noMiner - } logger <- testLogger - applyCmd logger Nothing pactDb txCtx (TxBlockIdx 0) noSPVSupport (Gas 1) (view payloadObj <$> cmd) + applyCmd logger Nothing pactDb noMiner (_psBlockCtx blockEnv) (TxBlockIdx 0) noSPVSupport (Gas 1) (view payloadObj <$> cmd) >>= P.match _Right ? P.checkAll -- gas buy event @@ -517,14 +502,14 @@ quirkSpec rdb = readFromAfterGenesis quirkVer rdb $ , P.fun _crGas ? P.equals ? Gas 1 ] where - quirkVer = quirkedGasPact5InstantCpmTestVersion petersen + quirkVer = quirkedGasInstantCpmTestVersion petersen applyCmdVerifierSpec :: RocksDb -> IO () -applyCmdVerifierSpec rdb = readFromAfterGenesis v rdb $ - pactTransaction Nothing $ \pactDb -> do +applyCmdVerifierSpec rdb = withVersion v $ readFromAfterGenesis rdb $ \blockEnv blockHandle -> + flip evalStateT blockHandle $ doChainwebPactDbTransaction (blockEnv ^. psBlockDbEnv) Nothing $ \pactDb _spv -> do -- Define module with capability do - cmd <- buildCwCmd v (defaultCmd cid) + cmd <- buildCwCmd (defaultCmd cid) { _cbRPC = mkExec' $ T.unlines [ "(namespace 'free)" , "(module m G" @@ -535,9 +520,8 @@ applyCmdVerifierSpec rdb = readFromAfterGenesis v rdb $ , _cbGasPrice = GasPrice 2 , _cbGasLimit = GasLimit (Gas 70_000) } - let txCtx = TxContext {_tcParentHeader = ParentHeader (gh v cid), _tcMiner = noMiner} logger <- testLogger - applyCmd logger Nothing pactDb txCtx (TxBlockIdx 0) noSPVSupport (Gas 1) (view payloadObj <$> cmd) + applyCmd logger Nothing pactDb noMiner (_psBlockCtx blockEnv) (TxBlockIdx 0) noSPVSupport (Gas 1) (view payloadObj <$> cmd) >>= P.match _Right ? P.checkAll -- gas buy event @@ -561,10 +545,9 @@ applyCmdVerifierSpec rdb = readFromAfterGenesis v rdb $ -- Invoke module when verifier capability isn't present. Should fail. do - cmd <- buildCwCmd v baseCmd - let txCtx = TxContext {_tcParentHeader = ParentHeader (gh v cid), _tcMiner = noMiner} + cmd <- buildCwCmd baseCmd logger <- testLogger - applyCmd logger Nothing pactDb txCtx (TxBlockIdx 0) noSPVSupport (Gas 1) (view payloadObj <$> cmd) + applyCmd logger Nothing pactDb noMiner (_psBlockCtx blockEnv) (TxBlockIdx 0) noSPVSupport (Gas 1) (view payloadObj <$> cmd) >>= P.match _Right ? P.checkAll -- gas buy event @@ -587,7 +570,7 @@ applyCmdVerifierSpec rdb = readFromAfterGenesis v rdb $ do let cap :: SigCapability cap = SigCapability $ CapToken (QualifiedName "G" (ModuleName "m" (Just (NamespaceName "free")))) [] - cmd <- buildCwCmd v baseCmd + cmd <- buildCwCmd baseCmd { _cbVerifiers = [ Verifier { _verifierName = VerifierName "allow" @@ -596,9 +579,8 @@ applyCmdVerifierSpec rdb = readFromAfterGenesis v rdb $ } ] } - let txCtx = TxContext {_tcParentHeader = ParentHeader (gh v cid), _tcMiner = noMiner} logger <- testLogger - applyCmd logger Nothing pactDb txCtx (TxBlockIdx 0) noSPVSupport (Gas 1) (view payloadObj <$> cmd) + applyCmd logger Nothing pactDb noMiner (_psBlockCtx blockEnv) (TxBlockIdx 0) noSPVSupport (Gas 1) (view payloadObj <$> cmd) >>= P.match _Right ? P.checkAll -- gas buy event @@ -616,21 +598,20 @@ applyCmdVerifierSpec rdb = readFromAfterGenesis v rdb $ ] applyCmdFailureSpec :: RocksDb -> IO () -applyCmdFailureSpec rdb = readFromAfterGenesis v rdb $ - pactTransaction Nothing $ \pactDb -> do +applyCmdFailureSpec rdb = withVersion v $ readFromAfterGenesis rdb $ \blockEnv blockHandle -> + flip evalStateT blockHandle $ doChainwebPactDbTransaction (blockEnv ^. psBlockDbEnv) Nothing $ \pactDb _spv -> do startSender00Bal <- readBal pactDb "sender00" assertEqual "starting balance" (Just 100_000_000) startSender00Bal startMinerBal <- readBal pactDb "NoMiner" - cmd <- buildCwCmd v (defaultCmd cid) + cmd <- buildCwCmd (defaultCmd cid) { _cbRPC = mkExec' "(+ 1 \"abc\")" , _cbGasPrice = GasPrice 2 , _cbGasLimit = GasLimit (Gas 500) } - let txCtx = TxContext {_tcParentHeader = ParentHeader (gh v cid), _tcMiner = noMiner} let expectedGasConsumed = 500 logger <- testLogger - applyCmd logger Nothing pactDb txCtx (TxBlockIdx 0) noSPVSupport (Gas 1) (view payloadObj <$> cmd) + applyCmd logger Nothing pactDb noMiner (_psBlockCtx blockEnv) (TxBlockIdx 0) noSPVSupport (Gas 1) (view payloadObj <$> cmd) >>= P.match _Right ? P.checkAll -- gas buy event @@ -668,14 +649,13 @@ applyCmdFailureSpec rdb = readFromAfterGenesis v rdb $ endMinerBal applyCmdCoinTransfer :: RocksDb -> IO () -applyCmdCoinTransfer rdb = readFromAfterGenesis v rdb $ do - txCtx <- TxContext <$> view psParentHeader <*> pure noMiner - pactTransaction Nothing $ \pactDb -> do +applyCmdCoinTransfer rdb = withVersion v $ readFromAfterGenesis rdb $ \blockEnv blockHandle -> do + flip evalStateT blockHandle $ doChainwebPactDbTransaction (blockEnv ^. psBlockDbEnv) Nothing $ \pactDb _spv -> do startSender00Bal <- readBal pactDb "sender00" assertEqual "starting balance" (Just 100_000_000) startSender00Bal startMinerBal <- readBal pactDb "NoMiner" - cmd <- buildCwCmd v (defaultCmd cid) + cmd <- buildCwCmd (defaultCmd cid) { _cbRPC = mkExec' "(coin.transfer 'sender00 'sender01 420.0)" , _cbSigners = [ mkEd25519Signer' sender00 @@ -688,7 +668,7 @@ applyCmdCoinTransfer rdb = readFromAfterGenesis v rdb $ do -- Note: if/when core changes gas prices, tweak here. let expectedGasConsumed = 227 logger <- testLogger - e <- applyCmd logger (Just logger) pactDb txCtx (TxBlockIdx 0) noSPVSupport (Gas 1) (view payloadObj <$> cmd) + e <- applyCmd logger Nothing pactDb noMiner (_psBlockCtx blockEnv) (TxBlockIdx 0) noSPVSupport (Gas 1) (view payloadObj <$> cmd) e & P.match _Right ? P.checkAll [ P.fun _crResult ? P.equals ? PactResultOk (PString "Write succeeded") @@ -742,13 +722,14 @@ applyCmdCoinTransfer rdb = readFromAfterGenesis v rdb $ do endMinerBal applyCoinbaseSpec :: RocksDb -> IO () -applyCoinbaseSpec rdb = readFromAfterGenesis v rdb $ - pactTransaction Nothing $ \pactDb -> do +applyCoinbaseSpec rdb = withVersion v $ readFromAfterGenesis rdb $ \blockEnv blockHandle -> + flip evalStateT blockHandle $ doChainwebPactDbTransaction (blockEnv ^. psBlockDbEnv) Nothing $ \pactDb _spv -> do startMinerBal <- readBal pactDb "NoMiner" - let txCtx = TxContext {_tcParentHeader = ParentHeader (gh v cid), _tcMiner = noMiner} logger <- testLogger - applyCoinbase logger pactDb 5 txCtx + -- reward is 23.04523 (first entry in miner_rewards.csv) divided by #chains + let expectedMiningReward = 23.04523 / 10 + applyCoinbase logger pactDb noMiner (_psBlockCtx blockEnv) >>= P.match _Right ? P.checkAll [ P.fun _crResult ? P.equals ? PactResultOk (PString "Write succeeded") @@ -762,40 +743,19 @@ applyCoinbaseSpec rdb = readFromAfterGenesis v rdb $ , P.fun _crEvents ? P.list [ event (P.equals "TRANSFER") - (P.equals [PString "", PString "NoMiner", PDecimal 5.0]) + (P.equals [PString "", PString "NoMiner", PDecimal expectedMiningReward]) (P.equals coinModuleName) ] ] endMinerBal <- readBal pactDb "NoMiner" assertEqual "miner balance should include block reward" - (Just $ fromMaybe 0 startMinerBal + 5) + (Just $ fromMaybe 0 startMinerBal + expectedMiningReward) endMinerBal -testCoinUpgrade :: RocksDb -> IO () -testCoinUpgrade rdb = readFromAfterGenesis vUpgrades rdb $ do - txCtx <- TxContext <$> view psParentHeader <*> pure noMiner - pactTransaction Nothing $ \pactDb -> do - - logger <- testLogger - getCoinModuleHash logger txCtx pactDb - >>= P.equals ? PactResultOk (PString "wOTjNC3gtOAjqgCY8S9hQ-LBiwcPUE7j4iBDE0TmdJo") - - applyUpgrades logger pactDb txCtx - - getCoinModuleHash logger txCtx pactDb - >>= P.equals ? PactResultOk (PString "3iIBQdJnst44Z2ZgXoHPkAauybJ0h85l_en_SGHNibE") - where - getCoinModuleHash logger txCtx pactDb = do - cmd <- buildCwCmd vUpgrades (defaultCmd cid) - { _cbRPC = mkExec' "(at 'hash (describe-module 'coin))" - } - _crResult <$> applyLocal logger Nothing pactDb txCtx noSPVSupport (view payloadObj <$> cmd) - - testEvents :: RocksDb -> IO () -testEvents rdb = readFromAfterGenesis v rdb $ - pactTransaction Nothing $ \pactDb -> do - cmd <- buildCwCmd v (defaultCmd cid) +testEvents rdb = withVersion v $ readFromAfterGenesis rdb $ \blockEnv blockHandle -> do + flip evalStateT blockHandle $ doChainwebPactDbTransaction (blockEnv ^. psBlockDbEnv) Nothing $ \pactDb _spv -> do + cmd <- buildCwCmd (defaultCmd cid) { _cbRPC = mkExec' "(coin.transfer 'sender00 'sender01 420.0) (coin.transfer 'sender00 'sender01 69.0)" , _cbSigners = [ mkEd25519Signer' sender00 @@ -806,9 +766,8 @@ testEvents rdb = readFromAfterGenesis v rdb $ , _cbGasPrice = GasPrice 2 , _cbGasLimit = GasLimit (Gas 1100) } - let txCtx = TxContext {_tcParentHeader = ParentHeader (gh v cid), _tcMiner = noMiner} logger <- testLogger - e <- applyCmd logger Nothing pactDb txCtx (TxBlockIdx 0) noSPVSupport (Gas 1) (view payloadObj <$> cmd) + e <- applyCmd logger Nothing pactDb noMiner (_psBlockCtx blockEnv) (TxBlockIdx 0) noSPVSupport (Gas 1) (view payloadObj <$> cmd) e & P.match _Right ? P.checkAll @@ -841,21 +800,20 @@ testEvents rdb = readFromAfterGenesis v rdb $ ] testLocalOnlyFailsOutsideOfLocal :: RocksDb -> IO () -testLocalOnlyFailsOutsideOfLocal rdb = readFromAfterGenesis v rdb $ do - txCtx <- TxContext <$> view psParentHeader <*> pure noMiner - pactTransaction Nothing $ \pactDb -> do +testLocalOnlyFailsOutsideOfLocal rdb = withVersion v $ readFromAfterGenesis rdb $ \blockEnv blockHandle -> do + flip evalStateT blockHandle $ doChainwebPactDbTransaction (blockEnv ^. psBlockDbEnv) Nothing $ \pactDb _spv -> do let testLocalOnly txt = do - cmd <- buildCwCmd v (defaultCmd cid) + cmd <- buildCwCmd (defaultCmd cid) { _cbRPC = mkExec' txt } logger <- testLogger -- should succeed in local - applyLocal logger Nothing pactDb txCtx noSPVSupport (view payloadObj <$> cmd) + applyLocal logger Nothing pactDb (_psBlockCtx blockEnv) noSPVSupport (view payloadObj <$> cmd) >>= P.fun _crResult (P.match _PactResultOk P.succeed) -- should fail in non-local - applyCmd logger Nothing pactDb txCtx (TxBlockIdx 0) noSPVSupport (Gas 1) (view payloadObj <$> cmd) + applyCmd logger Nothing pactDb noMiner (_psBlockCtx blockEnv) (TxBlockIdx 0) noSPVSupport (Gas 1) (view payloadObj <$> cmd) >>= P.match _Right ? P.fun _crResult ? P.match (_PactResultErr . _PEExecutionError . _1 . _OperationIsLocalOnly) P.succeed @@ -863,27 +821,25 @@ testLocalOnlyFailsOutsideOfLocal rdb = readFromAfterGenesis v rdb $ do testLocalOnly "(describe-module \"coin\")" testWritesFromFailedTxDontMakeItIn :: RocksDb -> IO () -testWritesFromFailedTxDontMakeItIn rdb = readFromAfterGenesis v rdb $ do - txCtx <- TxContext <$> view psParentHeader <*> pure noMiner - pactTransaction Nothing $ \pactDb -> do +testWritesFromFailedTxDontMakeItIn rdb = withVersion v $ readFromAfterGenesis rdb $ \blockEnv blockHandle -> do + bh <- flip execStateT blockHandle $ doChainwebPactDbTransaction (blockEnv ^. psBlockDbEnv) Nothing $ \pactDb _spv -> do - moduleDeploy <- buildCwCmd v (defaultCmd cid) + moduleDeploy <- buildCwCmd (defaultCmd cid) { _cbRPC = mkExec' "(module m g (defcap g () (enforce false \"non-upgradeable\"))) (enforce false \"boom\")" , _cbGasLimit = GasLimit (Gas 200_000) , _cbSigners = [mkEd25519Signer' sender00 []] } logger <- testLogger - applyCmd logger Nothing pactDb txCtx (TxBlockIdx 0) noSPVSupport (Gas 1) (view payloadObj <$> moduleDeploy) + applyCmd logger Nothing pactDb noMiner (_psBlockCtx blockEnv) (TxBlockIdx 0) noSPVSupport (Gas 1) (view payloadObj <$> moduleDeploy) >>= P.match _Right ? P.fun _crResult ? P.match _PactResultErr P.succeed -- Assert that the writes from the failed transaction didn't make it into the db -- but there is some write to the coin contract - use pbBlockHandle - >>= (liftIO .) - ? P.fun _blockHandlePending + liftIO $ bh + & P.fun _blockHandlePending ? P.fun _pendingWrites ? P.checkAll [ P.fun InMemDb.modules @@ -898,10 +854,9 @@ testWritesFromFailedTxDontMakeItIn rdb = readFromAfterGenesis v rdb $ do ] testWritesToNonExistentTables :: RocksDb -> IO () -testWritesToNonExistentTables rdb = readFromAfterGenesis v rdb $ do - txCtx <- TxContext <$> view psParentHeader <*> pure noMiner - pactTransaction Nothing $ \pactDb -> do - cmd <- buildCwCmd v +testWritesToNonExistentTables rdb = withVersion v $ readFromAfterGenesis rdb $ \blockEnv blockHandle -> do + flip evalStateT blockHandle $ doChainwebPactDbTransaction (blockEnv ^. psBlockDbEnv) Nothing $ \pactDb _spv -> do + cmd <- buildCwCmd $ set cbRPC (mkExec' $ T.concat [ "(namespace 'free)" , "(module m G" @@ -915,61 +870,38 @@ testWritesToNonExistentTables rdb = readFromAfterGenesis v rdb $ do $ defaultCmd cid logger <- testLogger - applyCmd logger Nothing pactDb txCtx (TxBlockIdx 0) noSPVSupport (Gas 1) (view payloadObj <$> cmd) + applyCmd logger Nothing pactDb noMiner (_psBlockCtx blockEnv) (TxBlockIdx 0) noSPVSupport (Gas 1) (view payloadObj <$> cmd) >>= P.match _Right ? P.fun _crResult ? P.match (_PactResultErr . _PEExecutionError . _1) ? P.equals (DbOpFailure (NoSuchTable (TableName "t" (ModuleName "m" (Just "free"))))) testKeccak256 :: RocksDb -> IO () -testKeccak256 rdb = readFromAfterGenesis v rdb $ do - txCtx <- TxContext <$> view psParentHeader <*> pure noMiner - pactTransaction Nothing $ \pactDb -> do - cmd <- buildCwCmd v +testKeccak256 rdb = withVersion v $ readFromAfterGenesis rdb $ \blockEnv blockHandle -> do + flip evalStateT blockHandle $ doChainwebPactDbTransaction (blockEnv ^. psBlockDbEnv) Nothing $ \pactDb _spv -> do + cmd <- buildCwCmd $ set cbRPC (mkExec' "(hash-keccak256 [\"T73FllCNJKKgAQ4UCYC4CfucbVXsdRJYkd2YXTdmW9gPm-tqUCB1iKvzzu6Md82KWtSKngqgdO04hzg2JJbS-yyHVDuzNJ6mSZfOPntCTqktEi9X27CFWoAwWEN_4Ir7DItecXm5BEu_TYGnFjsxOeMIiLU2sPlX7_macWL0ylqnVqSpgt-tvzHvJVCDxLXGwbmaEH19Ov_9uJFHwsxMmiZD9Hjl4tOTrqN7THy0tel9rc8WtrUKrg87VJ7OR3Rtts5vZ91EBs1OdVldUQPRP536eTcpJNMo-N0fy-taji6L9Mdt4I4_xGqgIfmJxJMpx6ysWmiFVte8vLKl1L5p0yhOnEDsSDjuhZISDOIKC2NeytqoT9VpBQn1T3fjWkF8WEZIvJg5uXTge_qwA46QKV0LE5AlMKgw0cK91T8fnJ-u1Dyk7tCo3XYbx-292iiih8YM1Cr1-cdY5cclAjHAmlglY2ia_GXit5p6K2ggBmd1LpEBdG8DGE4jmeTtiDXLjprpDilq8iCuI0JZ_gvQvMYPekpf8_cMXtTenIxRmhDpYvZzyCxek1F4aoo7_VcAMYV71Mh_T8ox7U1Q4U8hB9oCy1BYcAt06iQai0HXhGFljxsrkL_YSkwsnWVDhhqzxWRRdX3PubpgMzSI290C1gG0Gq4xfKdHTrbm3Q\"])") $ defaultCmd cid logger <- testLogger - applyCmd logger Nothing pactDb txCtx (TxBlockIdx 0) noSPVSupport (Gas 1) (view payloadObj <$> cmd) + applyCmd logger Nothing pactDb noMiner (_psBlockCtx blockEnv) (TxBlockIdx 0) noSPVSupport (Gas 1) (view payloadObj <$> cmd) >>= P.match _Right ? P.checkAll [ P.fun _crResult ? P.equals ? PactResultOk (PString "DqM-LjT1ckQGQCRMfx9fBGl86XE5vacqZVjYZjwCs4g") , P.fun _crGas ? P.equals ? Gas 75 ] -testCommandResult5To4 :: RocksDb -> IO () -testCommandResult5To4 rdb = readFromAfterGenesis v rdb $ do - txCtx <- TxContext <$> view psParentHeader <*> pure noMiner - pactTransaction Nothing $ \pactDb -> do - cmd <- buildCwCmd v - $ set cbRPC (mkExec' "(+ 1 'hello)") - $ defaultCmd cid - - logger <- testLogger - applyCmd logger Nothing pactDb txCtx (TxBlockIdx 0) noSPVSupport (Gas 1) (view payloadObj <$> cmd) - >>= P.checkAll - [ P.match _Right - ? P.fun _crResult - ? P.match _PactResultErr - ? P.succeed - , P.match _Right - ? P.fun (fmap pactErrorToOnChainError) - ? P.fun hashPact5TxLogs - ? P.fun toPact4CommandResult - ? P.forced - ] - cid :: ChainId cid = unsafeChainId 0 -gh :: ChainwebVersion -> ChainId -> BlockHeader +gh :: HasVersion => ChainId -> BlockHeader gh = genesisBlockHeader -vUpgrades :: ChainwebVersion -vUpgrades = pact5SlowCpmTestVersion singletonChainGraph +-- vUpgrades :: ChainwebVersion +-- vUpgrades = slowCpmTestVersion singletonChainGraph v :: ChainwebVersion -v = pact5InstantCpmTestVersion False petersenChainGraph +v = instantCpmTestVersion False petersenChainGraph -- | this utility for reading balances from the pactdb also takes care of -- making a transaction for the read to live in diff --git a/test/unit/Chainweb/Test/Pact5/TransactionTests.hs b/test/unit/Chainweb/Test/Pact/TransactionTests.hs similarity index 85% rename from test/unit/Chainweb/Test/Pact5/TransactionTests.hs rename to test/unit/Chainweb/Test/Pact/TransactionTests.hs index 9de5221b3f..2bb10f6826 100644 --- a/test/unit/Chainweb/Test/Pact5/TransactionTests.hs +++ b/test/unit/Chainweb/Test/Pact/TransactionTests.hs @@ -6,9 +6,9 @@ {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE ScopedTypeVariables #-} -module Chainweb.Test.Pact5.TransactionTests (tests) where +module Chainweb.Test.Pact.TransactionTests (tests) where -import Chainweb.Pact5.Templates +import Chainweb.Pact.Templates import Chainweb.Miner.Pact import Control.Lens hiding ((.=)) import Data.Foldable @@ -21,16 +21,18 @@ import Pact.Core.Repl import Pact.Core.Repl.Utils import Control.Monad (when) import Data.Text qualified as Text -import Pact.Types.KeySet qualified as Pact4 import Test.Tasty import Test.Tasty.HUnit import Data.Map.Strict qualified as Map +import Pact.Core.Guards +import qualified Data.Set as Set +import Pact.Core.Names -- ---------------------------------------------------------------------- -- -- Global settings tests :: TestTree -tests = testGroup "Chainweb.Test.Pact5.TransactionTests" +tests = testGroup "Chainweb.Test.Pact.TransactionTests" [ testCase "coin contract v6" $ runReplTest coinReplV6 , testCase "namespace v1" $ runReplTest nsReplV1 , testCase "namespace v2" $ runReplTest nsReplV2 @@ -85,7 +87,7 @@ injectionTest = do badMinerId :: MinerId badMinerId = MinerId "alpha\" (read-keyset \"miner-keyset\") 9999999.99)(coin.coinbase \"alpha" -minerKeys0 :: MinerKeys -minerKeys0 = MinerKeys $ Pact4.mkKeySet - ["f880a433d6e2a13a32b6169030f56245efdd8c1b8a5027e9ce98a88e886bef27"] - "default" +minerKeys0 :: MinerGuard +minerKeys0 = MinerGuard $ GKeyset $ KeySet + (Set.singleton (PublicKeyText "f880a433d6e2a13a32b6169030f56245efdd8c1b8a5027e9ce98a88e886bef27")) + (CustomPredicate (TBN $ BareName "default")) diff --git a/test/unit/Chainweb/Test/Pact4/Checkpointer.hs b/test/unit/Chainweb/Test/Pact4/Checkpointer.hs deleted file mode 100644 index cc8222e63b..0000000000 --- a/test/unit/Chainweb/Test/Pact4/Checkpointer.hs +++ /dev/null @@ -1,872 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE DataKinds #-} - -module Chainweb.Test.Pact4.Checkpointer (tests) where - -import Control.Concurrent.MVar -import Control.DeepSeq -import Control.Exception -import Control.Lens hiding ((.=)) -import Control.Monad (when, void) -import Control.Monad.Reader - -import Data.Aeson (Value(..), object, (.=), Key) -import Data.Function -import qualified Data.Map.Strict as M -import Data.Text (Text) -import qualified Data.Text as T - -import qualified Streaming.Prelude as Stream - -import Pact.Gas -import Pact.Interpreter (EvalResult(..), PactDbEnv(..), defaultInterpreter) -import Pact.JSON.Legacy.Value -import Pact.Native (nativeDefs) -import Pact.Repl -import Pact.Repl.Types -import Pact.Types.Command -import qualified Pact.Types.Hash as H -import Pact.Types.PactValue -import Pact.Types.RowData -import Pact.Types.Runtime hiding (ChainId) -import Pact.Types.SPV (noSPVSupport) -import Pact.Types.SQLite -import qualified Pact.JSON.Encode as J -import qualified Pact.Utils.StableHashMap as SHM - -import Test.Tasty -import Test.Tasty.HUnit - --- internal imports -import Chainweb.BlockHash -import Chainweb.BlockHeader.Internal -import Chainweb.BlockHeight -import Chainweb.Logger -import Chainweb.MerkleLogHash (merkleLogHash) -import Chainweb.MerkleUniverse -import Chainweb.Pact4.Backend.ChainwebPactDb - -import Chainweb.Pact.Backend.Utils -import Chainweb.Pact4.TransactionExec -import Chainweb.Pact.Types -import Chainweb.Test.Pact4.Utils -import Chainweb.Test.Utils -import Chainweb.Test.TestVersions -import Chainweb.Utils -import Chainweb.Version - -import Chainweb.Test.Orphans.Internal ({- Arbitrary BlockHash -}) -import Chainweb.Pact.Backend.Types -import qualified Chainweb.Pact.PactService.Checkpointer.Internal as Checkpointer -import qualified Chainweb.Pact5.Backend.ChainwebPactDb as Pact5 - --- -------------------------------------------------------------------------- -- --- Tests - -tests :: TestTree -tests = testGroup "Checkpointer" - [ testRelational - , testKeyset - , testModuleName - , testCaseSteps "PactDb Regression" testRegress - , testCaseSteps "readRow unitTest" readRowUnitTest - ] - --- -------------------------------------------------------------------------- -- --- Module Name Test - -testModuleName :: TestTree -testModuleName = withResourceT withTempSQLiteResource $ \s -> - runSQLite' f s - where - f = \resIO -> testCase "testModuleName" $ do - - (cp, sql) <- resIO - - -- init genesis - let - hash00 = getArbitrary 0 - pc00 = childOf Nothing hash00 - cpRestoreAndSave cp Nothing - [(pc00, \_ -> return ())] - - let - hash01 = getArbitrary 1 - pc01 = childOf (Just pc00) hash01 - cpRestoreAndSave cp (Just pc00) - [(pc01, \_ -> return ()) - ] - let - hash02 = getArbitrary 2 - pc02 = childOf (Just pc01) hash02 - cpRestoreAndSave cp (Just pc01) - [(pc02, \(PactDbEnv pactdb mvar) -> do - -- block 2: write module records - (_,_,mod') <- loadModule - -- write qualified - _writeRow pactdb Insert Modules "nsname.qualmod" mod' mvar - -- write unqualified - _writeRow pactdb Insert Modules "baremod" mod' mvar - )] - - r1 <- qry_ sql "SELECT rowkey FROM [SYS:Modules] WHERE rowkey LIKE '%qual%'" [RText] - assertEqual "correct namespaced module name" [[SText "nsname.qualmod"]] r1 - - r2 <- qry_ sql "SELECT rowkey FROM [SYS:Modules] WHERE rowkey LIKE '%bare%'" [RText] - assertEqual "correct bare module name" [[SText "baremod"]] r2 - --- -------------------------------------------------------------------------- -- --- Key Set Test - -testKeyset :: TestTree -testKeyset = withResource initializeSQLite freeSQLiteResource $ \s -> runSQLite keysetTest s - -keysetTest :: Logger logger => IO (Checkpointer logger) -> TestTree -keysetTest c = testCaseSteps "Keyset test" $ \next -> do - cp <- c - let - hash00 = nullBlockHash - pc00 = childOf Nothing hash00 - - - next "init" - cpRestoreAndSave cp Nothing [(pc00, \_ -> pure ())] - - next "next block (blockheight 1, version 0)" - cpReadFrom cp (Just pc00) $ \dbEnv -> - addKeyset dbEnv "k2" (mkKeySet [] ">=") - - - next "fork on blockheight = 1" - hash11 <- BlockHash <$> liftIO (merkleLogHash @_ @ChainwebMerkleHashAlgorithm "0000000000000000000000000000001b") - let pc11 = childOf (Just pc00) hash11 - cpRestoreAndSave cp (Just pc00) [(pc11, \dbEnv -> - addKeyset dbEnv "k1" (mkKeySet [] ">=") - )] - --- -------------------------------------------------------------------------- -- --- CheckPointer Test - -testRelational :: TestTree -testRelational = - withRelationalCheckpointerResource $ - checkpointerTest "Relational Checkpointer" True - -checkpointerTest :: (Logger logger) => String -> Bool -> IO (Checkpointer logger) -> TestTree -checkpointerTest name relational cenvIO = testCaseSteps name $ \next -> do - cenv <- cenvIO - let - cp = cenv - readFrom = cpReadFrom cp - restoreAndSave = cpRestoreAndSave cp - ------------------------------------------------------------------ - -- s01 : new block workflow (restore -> discard), genesis - ------------------------------------------------------------------ - - runTwice next $ do - next "Step 1 : new block workflow (restore -> discard), genesis" - readFrom Nothing $ \dbEnv -> do - void $ runExec cenv dbEnv (Just $ ksData "1") $ defModule "1" - runExec cenv dbEnv Nothing "(m1.readTbl)" >>= - \EvalResult{..} -> Right _erOutput @?= traverse toPactValue [tIntList [1]] - - - ----------------------------------------------------------- - -- s02 : validate block workflow (restore -> save), genesis - ----------------------------------------------------------- - - let hash00 = nullBlockHash - next "Step 2 : validate block workflow (restore -> save), genesis" - let pc00 = childOf Nothing hash00 - restoreAndSave Nothing - [(pc00, \dbEnv -> do - void $ runExec cenv dbEnv (Just $ ksData "1") $ defModule "1" - void $ runExec cenv dbEnv Nothing "(m1.readTbl)" - >>= \EvalResult{..} -> Right _erOutput @?= traverse toPactValue [tIntList [1]] - )] - - ------------------------------------------------------------------ - -- s03 : new block 00 - ------------------------------------------------------------------ - - next "Step 3 : new block 00" - let pactCheckStep = preview (_Just . peStep) . _erExec - let pactId = "DldRwCblQ7Loqy6wYJnaodHl30d3j3eH-qtFzfEv46g" - void $ readFrom (Just pc00) $ \dbEnv -> do - -- start a pact - -- test is that exec comes back with proper step - void $ runExec cenv dbEnv Nothing "(m1.insertTbl 'b 2)" - runExec cenv dbEnv Nothing "(m1.readTbl)" >>= \EvalResult{..} -> Right _erOutput @?= traverse toPactValue [tIntList [1,2]] - runExec cenv dbEnv Nothing "(m1.dopact 'pactA)" >>= ((Just 0 @=?) . pactCheckStep) - - ------------------------------------------------------------------ - -- s04: validate block 1 - ------------------------------------------------------------------ - - next "Step 4: validate block 1" - hash01 <- BlockHash <$> liftIO (merkleLogHash "0000000000000000000000000000001a") - let pc01 = childOf (Just pc00) hash01 - restoreAndSave (Just pc00) - [(pc01, \dbEnv -> do - void $ runExec cenv dbEnv Nothing "(m1.insertTbl 'b 2)" - runExec cenv dbEnv Nothing "(m1.readTbl)" - >>= \EvalResult{..} -> Right _erOutput @?= traverse toPactValue [tIntList [1,2]] - runExec cenv dbEnv Nothing "(m1.dopact 'pactA)" - >>= ((Just 0 @=?) . pactCheckStep) - )] - - ------------------------------------------------------------------ - -- s05: validate block 02 - -- create m2 module, exercise RefStore checkpoint - -- exec next part of pact - ------------------------------------------------------------------ - - let msg = "Step 5: validate block 02\n create m2 module, exercise RefStore checkpoint\n exec next part of pact" - next msg - hash02 <- BlockHash <$> merkleLogHash "0000000000000000000000000000002a" - let pc02 = childOf (Just pc01) hash02 - restoreAndSave (Just pc01) - [(pc02, \dbEnv -> do - void $ runExec cenv dbEnv (Just $ ksData "2") $ defModule "2" - runExec cenv dbEnv Nothing "(m2.readTbl)" - >>= \EvalResult{..} -> Right _erOutput @?= traverse toPactValue [tIntList [1]] - runCont cenv dbEnv pactId 1 - >>= ((Just 1 @=?) . pactCheckStep) - )] - - ------------------------------------------------------------------ - -- s06 : new block 03 - ------------------------------------------------------------------ - - next "Step 6 : new block 03" - readFrom (Just pc02) $ \dbEnv -> do - void $ runExec cenv dbEnv Nothing "(m2.insertTbl 'b 2)" - runExec cenv dbEnv Nothing "(m2.readTbl)" - >>= \EvalResult{..} -> Right _erOutput @?= traverse toPactValue [tIntList [1,2]] - - ------------------------------------------------------------------ - -- s07 : validate block 03 - ------------------------------------------------------------------ - - next "Step 7 : validate block 03" - hash03 <- BlockHash <$> merkleLogHash "0000000000000000000000000000003a" - let pc03 = childOf (Just pc02) hash03 - restoreAndSave (Just pc02) - [(pc03, \dbEnv -> do - void $ runExec cenv dbEnv Nothing "(m2.insertTbl 'b 2)" - runExec cenv dbEnv Nothing "(m2.readTbl)" - >>= \EvalResult{..} -> Right _erOutput @?= traverse toPactValue [tIntList [1,2]] - )] - -- insert here would fail if new block 03 had not been discarded - - ------------------------------------------------------------------ - -- s08: FORK! block 02, new hash - -- recreate m2 module, exercise RefStore checkpoint - -- exec next part of pact - ------------------------------------------------------------------ - - next "Step 8: FORK! block 02, new hash\n recreate m2 module, exercise RefStore checkpoint\n exec next part of pact" - hash02Fork <- BlockHash <$> merkleLogHash "0000000000000000000000000000002b" - let pc02Fork = childOf (Just pc01) hash02Fork - restoreAndSave (Just pc01) - [(pc02Fork, \dbEnv -> do - void $ runExec cenv dbEnv (Just $ ksData "2") $ defModule "2" - runExec cenv dbEnv Nothing "(m2.readTbl)" >>= \EvalResult{..} -> Right _erOutput @?= traverse toPactValue [tIntList [1]] - -- this would fail if not a fork - runCont cenv dbEnv pactId 1 >>= ((Just 1 @=?) . pactCheckStep) - )] - - next "step 9: test update row: new block 03" - readFrom (Just pc02Fork) $ \dbEnv -> do - void $ runExec cenv dbEnv Nothing "(m1.updateTbl 'b 3)" - runExec cenv dbEnv Nothing "(m1.readTbl)" >>= \EvalResult{..} -> Right _erOutput @?= traverse toPactValue [tIntList [1,3]] - -- updating key previously written at blockheight 1 (the "restore point") - - next "step 10: test update row: validate block 03" - hash13 <- BlockHash <$> merkleLogHash "0000000000000000000000000000003b" - let pc13 = childOf (Just pc02Fork) hash13 - restoreAndSave (Just pc02Fork) - [(pc13, \dbEnv -> do - void $ runExec cenv dbEnv Nothing "(m1.updateTbl 'b 3)" - runExec cenv dbEnv Nothing "(m1.readTbl)" >>= \EvalResult{..} -> Right _erOutput @?= traverse toPactValue [tIntList [1,3]] - )] - -- updating key previously written at blockheight 1 (the "restore point") - - next "mini-regression test for dropping user tables (part 1) empty block" - hash04 <- BlockHash <$> merkleLogHash "0000000000000000000000000000004a" - let pc04 = childOf (Just pc13) hash04 - restoreAndSave (Just pc13) - [(pc04, \_ -> return ())] - - next "mini-regression test for dropping user tables (part 2) (create module with offending table)" - hash05 <- BlockHash <$> merkleLogHash "0000000000000000000000000000005a" - let pc05 = childOf (Just pc04) hash05 - restoreAndSave (Just pc04) - [(pc05, \dbEnv -> do - void $ runExec cenv dbEnv (Just $ ksData "5") $ defModule "5" - runExec cenv dbEnv Nothing "(m5.readTbl)" >>= - \EvalResult{..} -> Right _erOutput @?= traverse toPactValue [tIntList [1]] - )] - - next "mini-regression test for dropping user tables (part 3) (reload the offending table)" - hash05Fork <- BlockHash <$> merkleLogHash "0000000000000000000000000000005b" - let pc05Fork = childOf (Just pc04) hash05Fork - restoreAndSave (Just pc04) - [(pc05Fork, \dbEnv -> do - void $ runExec cenv dbEnv (Just $ ksData "5") $ defModule "5" - runExec cenv dbEnv Nothing "(m5.readTbl)" >>= \EvalResult{..} -> Right _erOutput @?= traverse toPactValue [tIntList [1]] - )] - - next "2nd mini-regression test for debugging updates (part 1) empty block" - hash14 <- BlockHash <$> merkleLogHash "0000000000000000000000000000004b" - let pc14 = childOf (Just pc13) hash14 - restoreAndSave (Just pc13) - [(pc14, \_ -> return ())] - - next "2nd mini-regression test for debugging updates (part 2) create module & table" - hash15 <- BlockHash <$> merkleLogHash "0000000000000000000000000000005c" - let pc15 = childOf (Just pc14) hash15 - restoreAndSave (Just pc14) - [(pc15, \dbEnv -> do - void $ runExec cenv dbEnv (Just $ ksData "6") $ defModule "6" - runExec cenv dbEnv Nothing "(m6.readTbl)" >>= \EvalResult{..} -> Right _erOutput @?= traverse toPactValue [tIntList [1]] - )] - - next "2nd mini-regression test for debugging updates (part 3) step 1 of insert value then update twice" - hash06 <- BlockHash <$> merkleLogHash "0000000000000000000000000000006a" - let pc06 = childOf (Just pc15) hash06 - restoreAndSave (Just pc15) - [(pc06, \dbEnv -> do - void $ runExec cenv dbEnv Nothing "(m6.insertTbl 'b 2)" - )] - - next "2nd mini-regression test for debugging updates (part 4) step 2 of insert value then update twice" - hash07 <- BlockHash <$> merkleLogHash "0000000000000000000000000000007a" - let pc07 = childOf (Just pc06) hash07 - restoreAndSave (Just pc06) - [(pc07, \dbEnv -> do - void $ runExec cenv dbEnv Nothing "(m6.weirdUpdateTbl 'b 4)" - )] - - next "2nd mini-regression test for debugging updates (part 5) step 3 of insert value then update twice" - hash08 <- BlockHash <$> merkleLogHash "0000000000000000000000000000008a" - let pc08 = childOf (Just pc07) hash08 - restoreAndSave (Just pc07) - [(pc08, \dbEnv -> do - runExec cenv dbEnv Nothing "(m6.readTbl)" >>= \EvalResult{..} -> Right _erOutput @?= traverse toPactValue [tIntList [1,4]] - )] - -- FOR DEBUGGING/INSPECTING VALUES AT SPECIFIC KEYS - -- void $ runExec cenv blockEnv09 Nothing "(let ((written (at 'col (read m6.tbl 'a [\"col\"])))) (enforce (= written 1) \"key a\"))" - -- void $ runExec cenv blockEnv09 Nothing "(let ((written (at 'col (read m6.tbl 'b [\"col\"])))) (enforce (= written 4) \"key b\"))" - -- FOR DEBUGGING/INSPECTING VALUES AT SPECIFIC KEYS - - next "Create the free namespace for the test" - hash09 <- BlockHash <$> merkleLogHash "0000000000000000000000000000009a" - let pc09 = childOf (Just pc08) hash09 - restoreAndSave (Just pc08) - [(pc09, \dbEnv -> do - void $ runExec cenv dbEnv Nothing defFree - )] - hash10 <- BlockHash <$> merkleLogHash "0000000000000000000000000000010a" - - next "Don't create the same table twice in the same block" - let tKeyset = object ["test-keyset" .= object ["keys" .= ([] :: [Text]), "pred" .= String ">="]] - readFrom (Just pc09) $ \dbEnv -> do - void $ runExec cenv dbEnv (Just tKeyset) tablecode - expectException "The table duplication somehow went through. Investigate this error." $ - runExec cenv dbEnv (Just tKeyset) tablecode - - - next "Don't create the same table twice in the same transaction." - - readFrom (Just pc09) $ \dbEnv -> - expectException "The table duplication somehow went through. Investigate this error." $ - runExec cenv dbEnv (Just tKeyset) (tablecode <> tablecode) - - - next "Don't create the same table twice over blocks." - - let pc10 = childOf (Just pc09) hash10 - restoreAndSave (Just pc09) - [(pc10, \dbEnv -> do - void $ runExec cenv dbEnv (Just tKeyset) tablecode - ) - ] - - - hash11 <- BlockHash <$> merkleLogHash "0000000000000000000000000000011a" - let pc11 = childOf (Just pc10) hash11 - restoreAndSave (Just pc10) - [(pc11, \dbEnv -> do - expectException "The table duplication somehow went through. Investigate this error." $ - runExec cenv dbEnv (Just tKeyset) tablecode - )] - - - next "Purposefully restore to an illegal checkpoint." - - let pc10Invalid = pc10 & blockHeight .~ 13 - void $ expectException "Illegal checkpoint successfully restored to" $ - readFrom (Just pc10Invalid) $ \_ -> return () - - when relational $ do - - next "Rewind to block 5" - - next "Run block 5b with pact 4.2.0 changes" - - readFrom (Just pc14) $ \dbEnv -> do - - void $ runExec cenv dbEnv (Just $ ksData "7") (defModule "7") - void $ runExec cenv dbEnv Nothing "(m7.insertTbl 'b 2)" - void $ runExec cenv dbEnv Nothing "(m7.insertTbl 'd 3)" - void $ runExec cenv dbEnv Nothing "(m7.insertTbl 'c 4)" - void $ runExec cenv dbEnv Nothing "(keys m7.tbl)" >>= \EvalResult{..} -> - Right _erOutput @?= traverse toPactValue [tStringList $ T.words "a b c d"] - - next "Rollback to block 4 and expect failure with pact 4.2.0 changes" - - readFrom (Just pc13) $ \dbEnv -> do - void $ runExec cenv dbEnv (Just $ ksData "7") (defModule "7") - void $ runExec cenv dbEnv Nothing "(m7.insertTbl 'b 2)" - void $ runExec cenv dbEnv Nothing "(m7.insertTbl 'd 3)" - void $ runExec cenv dbEnv Nothing "(m7.insertTbl 'c 4)" - runExec cenv dbEnv Nothing "(keys m7.tbl)" >>= \EvalResult{..} -> - assertBool "order should be different" - (Right _erOutput /= traverse toPactValue [tStringList $ T.words "a b c d"]) - - where - - h :: SomeException -> IO (Maybe String) - h = const (return Nothing) - - expectException msg act = do - result <- (act >> return (Just msg)) `catchAllSynchronous` h - maybe (return ()) (`assertBool` False) result - - ksData :: Key -> Value - ksData idx = object - [ ("k" <> idx) .= object - [ "keys" .= ([] :: [Text]) - , "pred" .= String ">=" - ] - ] - --- -------------------------------------------------------------------------- -- --- Read Row Unit Test - -readRowUnitTest :: (String -> IO ()) -> Assertion -readRowUnitTest logBackend = simpleBlockEnvInit logger runUnitTest - where - logger = hunitDummyLogger logBackend - writeRow' pactdb writeType conn i = - _writeRow pactdb writeType (UserTables "user1") "key1" - (RowData RDV1 (ObjectMap $ M.fromList [("f", (RDLiteral (LInteger i)))])) conn - runUnitTest pactdb e schemaInit = do - conn <- newMVar e - void $ schemaInit conn - let user1 = "user1" - usert = UserTables user1 - void $ begin pactdb conn - _createUserTable pactdb user1 "someModule" conn - writeRow' pactdb Insert conn 1 - void $ commit pactdb conn - let numWrites = 100 :: Int - loop current = - if current == numWrites - then return () - else do - void $ begin pactdb conn - writeRow' pactdb Update conn $ - fromIntegral $ current + 1 - void $ commit pactdb conn - loop (current + 1) - loop 1 - r <- _readRow pactdb usert "key1" conn - case r of - Nothing -> assertFailure "Unsuccessful write" - Just (RowData _ (ObjectMap m)) -> case M.lookup "f" m of - Just l -> assertEquals "Unsuccesful write at field key \"f\"" l (RDLiteral (LInteger 100)) - Nothing -> assertFailure "Field not found" - --- -------------------------------------------------------------------------- -- --- Test Regress - -testRegress :: (String -> IO ()) -> Assertion -testRegress logBackend = - regressChainwebPactDb logger - >>= fmap (toTup . _benvBlockState) . readMVar - >>= assertEquals "The final block state is" finalBlockState - where - logger = hunitDummyLogger logBackend - finalBlockState = 2 - toTup BlockState { _bsTxId = txid } = txid - -regressChainwebPactDb :: (Logger logger) => logger -> IO (MVar (BlockEnv logger)) -regressChainwebPactDb logger = simpleBlockEnvInit logger runRegression - -{- this should be moved to pact -} -runRegression - :: PactDb e -- your pactdb instance - -> e -- ambient environment - -> (MVar e -> IO ()) -- schema "creator" - -> IO (MVar e) -- the final state of the environment -runRegression pactdb e schemaInit = do - conn <- newMVar e - schemaInit conn - Just t1 <- begin pactdb conn - let user1 = "user1" - usert = UserTables user1 - toPV :: ToTerm a => a -> RowDataValue - toPV = pactValueToRowData . toPactValueLenient . toTerm' - _createUserTable pactdb user1 "someModule" conn - assertEquals' "output of commit2" - [ encodeTxLog $ TxLog "SYS:usertables" "user1" $ - J.object - [ "utModule" J..= J.object - [ "namespace" J..= J.null - , "name" J..= J.text "someModule" - ] - ] - ] - (commit pactdb conn) - - void $ begin pactdb conn - let row = RowData RDV1 $ ObjectMap $ M.fromList [("gah", RDLiteral (LDecimal 123.454345))] - _writeRow pactdb Insert usert "key1" row conn - assertEquals' "usert insert" (Just row) (_readRow pactdb usert "key1" conn) - let row' = RowData RDV1 $ ObjectMap $ M.fromList [("gah",toPV False),("fh",toPV (1 :: Int))] - _writeRow pactdb Update usert "key1" row' conn - assertEquals' "user update" (Just row') (_readRow pactdb usert "key1" conn) - let ks = mkKeySet [PublicKeyText "skdjhfskj"] "predfun" - _writeRow pactdb Write KeySets "ks1" ks conn - assertEquals' "keyset write" (Just ks) $ _readRow pactdb KeySets "ks1" conn - (modName,modRef,mod') <- loadModule - _writeRow pactdb Write Modules modName mod' conn - assertEquals' "module write" (Just mod') $ _readRow pactdb Modules modName conn - assertEquals "module native repopulation" (Right modRef) $ - traverse (traverse (fromPersistDirect nativeLookup)) mod' - assertEquals' "result of commit 3" - [ encodeTxLog TxLog - { _txDomain = "SYS:KeySets" - , _txKey = "ks1" - , _txValue = ks - } - , encodeTxLog TxLog - { _txDomain = "SYS:Modules" - , _txKey = asString modName - , _txValue = mod' - } - , encodeTxLog TxLog - { _txDomain = "user1" - , _txKey = "key1" - , _txValue = row - } - , encodeTxLog TxLog - { _txDomain = "user1" - , _txKey = "key1" - , _txValue = row' - } - ] - (commit pactdb conn) - void $ begin pactdb conn - tids <- _txids pactdb user1 t1 conn - assertEquals "user txids" [1] tids - -- assertEquals' "user txlogs" - -- [TxLog "user1" "key1" row, - -- TxLog "user1" "key1" row'] $ - -- _getTxLog chainwebpactdb usert (head tids) conn - assertEquals' "user txlogs" [TxLog "user1" "key1" (RowData RDV1 (ObjectMap $ on M.union (_objectMap . _rdData) row' row))] $ - _getTxLog pactdb usert (head tids) conn - _writeRow pactdb Insert usert "key2" row conn - assertEquals' "user insert key2 pre-rollback" (Just row) (_readRow pactdb usert "key2" conn) - assertEquals' "keys pre-rollback" ["key1","key2"] $ _keys pactdb (UserTables user1) conn - _rollbackTx pactdb conn - assertEquals' "rollback erases key2" Nothing $ _readRow pactdb usert "key2" conn - assertEquals' "keys" ["key1"] $ _keys pactdb (UserTables user1) conn - return conn - --- -------------------------------------------------------------------------- -- --- Chainweb Settings - -testVer :: ChainwebVersion -testVer = slowForkingCpmTestVersion petersen - -testChainId :: ChainId -testChainId = unsafeChainId 0 - --- -------------------------------------------------------------------------- -- --- Testing Utils - -assertEquals' :: (Eq a, Show a, NFData a) => String -> a -> IO a -> IO () -assertEquals' msg a b = assertEquals msg a =<< b - -assertEquals :: (Eq a,Show a,NFData a) => String -> a -> a -> IO () -assertEquals msg a b - | [a,b] `deepseq` a == b = return () - | otherwise = throwFail - $ "FAILURE: " ++ msg - ++ ": expected \n " ++ show a ++ "\n got \n " ++ show b - -throwFail :: String -> IO a -throwFail = throwIO . userError - --- -------------------------------------------------------------------------- -- --- Checkpointer Utils - -withRelationalCheckpointerResource - :: (Logger logger, logger ~ GenericLogger) - => (IO (Checkpointer logger) -> TestTree) - -> TestTree -withRelationalCheckpointerResource f = - withResource initializeSQLite freeSQLiteResource $ \s -> runSQLite f s - -addKeyset :: PactDbEnv (BlockEnv logger) -> KeySetName -> KeySet -> IO () -addKeyset (PactDbEnv pactdb mvar) keysetname keyset = - _writeRow pactdb Insert KeySets keysetname keyset mvar - -runTwice :: MonadIO m => (String -> IO ()) -> m () -> m () -runTwice step action = do - liftIO $ step "Running the first time!" - action - liftIO $ step "Running the second time!" - action - -runSQLite - :: (Logger logger, logger ~ GenericLogger) - => (IO (Checkpointer logger) -> TestTree) - -> IO SQLiteEnv - -> TestTree -runSQLite f = runSQLite' (f . fmap fst) - -runSQLite' - :: (Logger logger, logger ~ GenericLogger) - => (IO (Checkpointer logger, SQLiteEnv) -> TestTree) - -> IO SQLiteEnv - -> TestTree -runSQLite' runTest sqlEnvIO = runTest $ do - sqlenv <- sqlEnvIO - cp <- Checkpointer.initCheckpointerResources defaultModuleCacheLimit sqlenv DoNotPersistIntraBlockWrites logger testVer testChainId - return (cp, sqlenv) - where - logger = addLabel ("sub-component", "relational-checkpointer") $ dummyLogger - -runExec :: forall logger. (Logger logger) => Checkpointer logger -> PactDbEnv (BlockEnv logger) -> Maybe Value -> Text -> IO EvalResult -runExec cp pactdbenv eData eCode = do - execMsg <- buildExecParsedCode maxBound {- use latest parser version -} eData eCode - evalTransactionM cmdenv cmdst $ - applyExec' 0 defaultInterpreter execMsg [] [] h' permissiveNamespacePolicy - where - h' = H.toUntypedHash (H.hash "" :: H.PactHash) - cmdenv :: TransactionEnv logger (BlockEnv logger) - cmdenv = TransactionEnv - { _txMode = Transactional - , _txDbEnv = pactdbenv - , _txLogger = cpLogger cp - , _txGasLogger = Nothing - , _txPublicData = noPublicData - , _txSpvSupport = noSPVSupport - , _txNetworkId = Nothing - , _txGasPrice = 0.0 - , _txRequestKey = RequestKey h' - , _txGasLimit = 0 - , _txExecutionConfig = emptyExecutionConfig - , _txQuirkGasFee = Nothing - , _txTxFailuresCounter = Nothing - } - cmdst = TransactionState mempty mempty 0 Nothing (_geGasModel freeGasEnv) mempty - -runCont :: Logger logger => Checkpointer logger -> PactDbEnv (BlockEnv logger) -> PactId -> Int -> IO EvalResult -runCont cp pactdbenv pactId step = do - evalTransactionM cmdenv cmdst $ - applyContinuation' 0 defaultInterpreter contMsg [] h' permissiveNamespacePolicy - where - contMsg = ContMsg pactId step False (toLegacyJson Null) Nothing - - h' = H.toUntypedHash (H.hash "" :: H.PactHash) - cmdenv = TransactionEnv - { _txMode = Transactional - , _txDbEnv = pactdbenv - , _txLogger = cpLogger cp - , _txGasLogger = Nothing - , _txPublicData = noPublicData - , _txSpvSupport = noSPVSupport - , _txNetworkId = Nothing - , _txGasPrice = 0.0 - , _txRequestKey = RequestKey h' - , _txGasLimit = 0 - , _txExecutionConfig = emptyExecutionConfig - , _txQuirkGasFee = Nothing - , _txTxFailuresCounter = Nothing - } - cmdst = TransactionState mempty mempty 0 Nothing (_geGasModel freeGasEnv) mempty - --- -------------------------------------------------------------------------- -- --- Pact Utils - --- witnessing that we only use the PactDbEnv portion --- of the CurrentBlockDbEnv -cpReadFrom - :: Logger logger - => Checkpointer logger - -> Maybe BlockHeader - -> (PactDbEnv (BlockEnv logger) -> IO q) - -> IO q -cpReadFrom cp pc f = do - Checkpointer.readFrom - cp - (ParentHeader <$> pc) - Pact4T - (\env _blockHandle -> f $ (_cpPactDbEnv env)) >>= \case - NoHistory -> error $ unwords - [ "Chainweb.Test.Pact4.Checkpointer.cpReadFrom:" - , "parent header missing from the database" - ] - Historical r -> return r - --- allowing a straightforward list of blocks to be passed to the API, --- and only exposing the PactDbEnv part of the block context -cpRestoreAndSave - :: (Logger logger, Monoid q) - => Checkpointer logger - -> Maybe BlockHeader - -> [(BlockHeader, PactDbEnv (BlockEnv logger) -> IO q)] - -> IO q -cpRestoreAndSave cp pc blks = snd <$> Checkpointer.restoreAndSave cp (ParentHeader <$> pc) - (traverse Stream.yield - [Pact4RunnableBlock $ \dbEnv _ -> (,bh) <$> (fun $ _cpPactDbEnv dbEnv) | (bh, fun) <- blks]) - --- | fabricate a `BlockHeader` for a block given its hash and its parent. -childOf :: Maybe BlockHeader -> BlockHash -> BlockHeader -childOf m bhsh = case m of - Just bh -> bh - & blockHash .~ bhsh - & blockParent .~ view blockHash bh - & blockHeight .~ view blockHeight bh + 1 - Nothing -> genesisBlockHeader testVer testChainId - & blockHash .~ bhsh - --- initialize a block env without actually restoring the checkpointer, before --- genesis. -simpleBlockEnvInit - :: (Logger logger) - => logger - -> (PactDb (BlockEnv logger) -> BlockEnv logger -> (MVar (BlockEnv logger) -> IO ()) -> IO a) - -> IO a -simpleBlockEnvInit logger f = withTempSQLiteConnection chainwebPragmas $ \sqlenv -> - f chainwebPactDb (blockEnv sqlenv) (\_ -> Pact5.initSchema sqlenv) - where - blockEnv sqlenv = BlockEnv - (mkBlockHandlerEnv testVer testChainId (BlockHeight 0) sqlenv DoNotPersistIntraBlockWrites logger) - (initBlockState defaultModuleCacheLimit (TxId 0)) - -{- this should be moved to pact -} -begin :: PactDb e -> Method e (Maybe TxId) -begin pactdb = _beginTx pactdb Transactional - -{- this should be moved to pact -} -commit :: PactDb e -> Method e [TxLogJson] -commit pactdb = _commitTx pactdb - -loadModule :: IO (ModuleName, ModuleData Ref, PersistModuleData) -loadModule = do - (r,s) <- execScript' (Script False fn) fn - case r of - Left a -> throwFail $ "module load failed: " ++ show a - Right _ -> case preview (rEvalState . evalRefs . rsLoadedModules . ix mn) s of - Just (md,_) -> case traverse (traverse toPersistDirect) md of - Right md' -> return (mn,md,md') - Left e -> throwFail $ "toPersistDirect failed: " ++ show e - Nothing -> throwFail $ "Failed to find module 'simple': " ++ - show (view (rEvalState . evalRefs . rsLoadedModules) s) - where - mn = ModuleName "simple" Nothing - fn = "test/pact/simple.repl" - -nativeLookup :: NativeDefName -> Maybe (Term Name) -nativeLookup (NativeDefName n) = case SHM.lookup n nativeDefs of - Just (Direct t) -> Just t - _ -> Nothing - -tIntList :: [Int] -> Term Name -tIntList = toTList (TyPrim TyInteger) noInfo . map toTerm - -tStringList :: [Text] -> Term Name -tStringList = toTList (TyPrim TyString) noInfo . map toTerm - -toTerm' :: ToTerm a => a -> Term Name -toTerm' = toTerm - -defFree :: Text -defFree = T.unlines - [ "(module ezfree G (defcap G () true) (defun ALLOW () true))" - , "(define-namespace 'free (create-user-guard (ALLOW)) (create-user-guard (ALLOW)))" - ] - -defModule :: Text -> Text -defModule idx = T.unlines - [ " ;;" - , "" - , "(module m" <> idx <> " G" - , " (defcap G () true)" - , " (defschema sch col:integer)" - , "" - , " (deftable tbl:{sch})" - , "" - , " (defun insertTbl (a i)" - , " (insert tbl a { 'col: i }))" - , "" - , " (defun updateTbl (a i)" - , " (update tbl a { 'col: i}))" - , "" - , " (defun weirdUpdateTbl (a i)" - , " (update tbl a { 'col: 0})" - , " (update tbl a { 'col: i}))" - , "" - , " (defun readTbl ()" - , " (sort (map (at 'col)" - , " (select tbl (constantly true)))))" - , "" - , " (defpact dopact (n)" - , " (step { 'name: n, 'value: 1 })" - , " (step { 'name: n, 'value: 2 }))" - , "" - , ")" - , "(create-table tbl)" - , "(readTbl)" - , "(insertTbl \"a\" 1)" - ] - -tablecode :: Text -tablecode = T.unlines - [ "(namespace 'free)" - , "(define-keyset \"free.table-admin-keyset\"" - , " (read-keyset \"test-keyset\"))" - , "" - , "(module table-example \"free.table-admin-keyset\"" - , "" - , " (defschema test-schema" - , " content:string)" - , "" - , " (deftable test-table:{test-schema})" - , "" - , " (defun add-row (row:string content:string)" - , " (insert test-table row {" - , " \"content\": content" - , " })" - , " )" - , " (defun read-table ()" - , " (select test-table (constantly true))" - , " )" - , ")" - , "" - , "(create-table test-table)" - ] diff --git a/test/unit/Chainweb/Test/Pact4/ModuleCacheOnRestart.hs b/test/unit/Chainweb/Test/Pact4/ModuleCacheOnRestart.hs deleted file mode 100644 index ec98b22b49..0000000000 --- a/test/unit/Chainweb/Test/Pact4/ModuleCacheOnRestart.hs +++ /dev/null @@ -1,306 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} - -module Chainweb.Test.Pact4.ModuleCacheOnRestart (tests) where - -import Control.Concurrent.MVar.Strict -import Control.DeepSeq (NFData) -import Control.Lens -import Control.Monad -import Control.Monad.IO.Class - -import qualified Data.Map.Strict as M -import Data.List (intercalate) -import qualified Data.Text as T - -import GHC.Generics - -import Test.Tasty.HUnit -import Test.Tasty - -import System.LogLevel - --- pact imports - -import Pact.Types.Runtime (mdModule) -import Pact.Types.Term -import qualified Pact.Utils.StableHashMap as SHM - --- chainweb imports - -import Chainweb.BlockHeader -import Chainweb.ChainId -import Chainweb.Graph -import Chainweb.Logger -import Chainweb.Miner.Pact - -import Chainweb.Pact.PactService -import Chainweb.Pact.Types -import Chainweb.Payload -import Chainweb.Payload.PayloadStore -import Chainweb.Time -import Chainweb.Test.Cut -import Chainweb.Test.Cut.TestBlockDb -import Chainweb.Test.Utils -import Chainweb.Test.Pact4.Utils(getPWOByHeader) -import Chainweb.Test.TestVersions(fastForkingCpmTestVersion) -import Chainweb.Utils -import Chainweb.Version -import Chainweb.WebBlockHeaderDB - -import Chainweb.Storage.Table.RocksDB -import qualified Chainweb.Pact4.ModuleCache as Pact4 -import Chainweb.Pact.Backend.Types - -testVer :: ChainwebVersion -testVer = fastForkingCpmTestVersion singletonChainGraph - -testChainId :: ChainId -testChainId = unsafeChainId 0 - -type RewindPoint = (BlockHeader, PayloadWithOutputs) - -data RewindData = RewindData - { afterV4 :: RewindPoint - , beforeV4 :: RewindPoint - , v3Cache :: SHM.StableHashMap ModuleName (Maybe ModuleHash) - } deriving Generic - -instance NFData RewindData - -tests :: RocksDb -> TestTree -tests rdb = - withResource' (newMVar mempty) $ \iom -> - withResource' newEmptyMVar $ \rewindDataM -> - withResourceT (mkTestBlockDb testVer rdb) $ \bdbio -> - withResourceT withTempSQLiteResource $ \ioSqlEnv -> - independentSequentialTestGroup "Chainweb.Test.Pact4.ModuleCacheOnRestart" - [ testCaseSteps "testInitial" $ withPact' bdbio ioSqlEnv iom testInitial - , testCaseSteps "testRestart1" $ withPact' bdbio ioSqlEnv iom testRestart - , testCaseSteps "testDoUpgrades" $ withPact' bdbio ioSqlEnv iom (testCoinbase bdbio) - , testCaseSteps "testRestart2" $ withPact' bdbio ioSqlEnv iom testRestart - , testCaseSteps "testV3" $ withPact' bdbio ioSqlEnv iom (testV3 bdbio rewindDataM) - , testCaseSteps "testRestart3"$ withPact' bdbio ioSqlEnv iom testRestart - , testCaseSteps "testV4" $ withPact' bdbio ioSqlEnv iom (testV4 bdbio rewindDataM) - , testCaseSteps "testRestart4" $ withPact' bdbio ioSqlEnv iom testRestart - , testCaseSteps "testRewindAfterFork" $ withPact' bdbio ioSqlEnv iom (testRewindAfterFork bdbio rewindDataM) - , testCaseSteps "testRewindBeforeFork" $ withPact' bdbio ioSqlEnv iom (testRewindBeforeFork bdbio rewindDataM) - , testCaseSteps "testCw217CoinOnly" $ withPact' bdbio ioSqlEnv iom $ - testCw217CoinOnly bdbio rewindDataM - , testCaseSteps "testRestartCw217" $ - withPact' bdbio ioSqlEnv iom testRestart - ] - -type CacheTest logger tbl = - (PactServiceM logger tbl () - ,IO (MVar ModuleInitCache) -> ModuleInitCache -> Assertion) - --- | Do genesis load, snapshot cache. -testInitial - :: (CanReadablePayloadCas tbl, Logger logger, logger ~ GenericLogger) - => CacheTest logger tbl -testInitial = (initPayloadState,snapshotCache) - --- | Do restart load, test results of 'initialPayloadState' against snapshotted cache. -testRestart - :: (CanReadablePayloadCas tbl, Logger logger, logger ~ GenericLogger) - => CacheTest logger tbl -testRestart = (initPayloadState,checkLoadedCache) - where - checkLoadedCache ioa initCache = do - a <- ioa >>= readMVar - (justModuleHashes a) `assertNoCacheMismatch` (justModuleHashes initCache) - --- | Run coinbase to do upgrade to v2, snapshot cache. -testCoinbase - :: (CanReadablePayloadCas tbl, Logger logger, logger ~ GenericLogger) - => IO TestBlockDb - -> CacheTest logger tbl -testCoinbase iobdb = (initPayloadState >> doCoinbase,snapshotCache) - where - genHeight = genesisHeight testVer testChainId - doCoinbase = do - bdb <- liftIO iobdb - bip <- throwIfNoHistory =<< execNewBlock mempty noMiner NewBlockFill - (ParentHeader (genesisBlockHeader testVer testChainId)) - let pwo = forAnyPactVersion finalizeBlock bip - void $ liftIO $ addTestBlockDb bdb (succ genHeight) (Nonce 0) (offsetBlockTime second) testChainId pwo - nextH <- liftIO $ getParentTestBlockDb bdb testChainId - void $ execValidateBlock mempty nextH (CheckablePayloadWithOutputs pwo) - -testV3 - :: (CanReadablePayloadCas tbl, Logger logger, logger ~ GenericLogger) - => IO TestBlockDb - -> IO (MVar RewindData) - -> CacheTest logger tbl -testV3 iobdb rewindM = (go,grabAndSnapshotCache) - where - go = do - initPayloadState - void $ doNextCoinbase iobdb - void $ doNextCoinbase iobdb - hpwo <- doNextCoinbase iobdb - liftIO (rewindM >>= \rewind -> putMVar rewind $ RewindData hpwo hpwo mempty) - grabAndSnapshotCache ioa initCache = do - rewindM >>= \rewind -> modifyMVar_ rewind $ \old -> pure $ old { v3Cache = justModuleHashes initCache } - snapshotCache ioa initCache - -testV4 - :: (CanReadablePayloadCas tbl, Logger logger, logger ~ GenericLogger) - => IO TestBlockDb - -> IO (MVar RewindData) - -> CacheTest logger tbl -testV4 iobdb rewindM = (go,snapshotCache) - where - go = do - initPayloadState - -- at the upgrade/fork point - void $ doNextCoinbase iobdb - -- just after the upgrade/fork point - afterV4' <- doNextCoinbase iobdb - rewind <- liftIO rewindM - liftIO $ modifyMVar_ rewind $ \old -> pure $ old { afterV4 = afterV4' } - void $ doNextCoinbase iobdb - void $ doNextCoinbase iobdb - -testRewindAfterFork - :: (CanReadablePayloadCas tbl, Logger logger, logger ~ GenericLogger) - => IO TestBlockDb - -> IO (MVar RewindData) - -> CacheTest logger tbl -testRewindAfterFork iobdb rewindM = (go, checkLoadedCache) - where - go = do - initPayloadState - liftIO rewindM >>= liftIO . readMVar >>= rewindToBlock . afterV4 - void $ doNextCoinbase iobdb - void $ doNextCoinbase iobdb - checkLoadedCache ioa initCache = do - a <- ioa >>= readMVar - case M.lookup 6 initCache of - Nothing -> assertFailure "Cache not found at height 6" - Just c -> (justModuleHashes a) `assertNoCacheMismatch` (justModuleHashes' c) - -testRewindBeforeFork - :: (CanReadablePayloadCas tbl, Logger logger, logger ~ GenericLogger) - => IO TestBlockDb - -> IO (MVar RewindData) - -> CacheTest logger tbl -testRewindBeforeFork iobdb rewindM = (go, checkLoadedCache) - where - go = do - initPayloadState - liftIO rewindM >>= liftIO . readMVar >>= rewindToBlock . beforeV4 - void $ doNextCoinbase iobdb - void $ doNextCoinbase iobdb - checkLoadedCache ioa initCache = do - a <- ioa >>= readMVar - case (M.lookup 5 initCache, M.lookup 4 initCache) of - (Just c, Just d) -> do - (justModuleHashes a) `assertNoCacheMismatch` (justModuleHashes' c) - v3c <- rewindM >>= \rewind -> fmap v3Cache (readMVar rewind) - assertNoCacheMismatch v3c (justModuleHashes' d) - _ -> assertFailure "Failed to lookup either block 4 or 5." - -testCw217CoinOnly - :: (Logger logger, CanReadablePayloadCas cas, logger ~ GenericLogger) - => IO TestBlockDb - -> IO (MVar RewindData) - -> CacheTest logger cas -testCw217CoinOnly iobdb _rewindM = (go, go') - where - go = do - initPayloadState - void $ doNextCoinbaseN_ 8 iobdb - - go' ioa initCache = do - snapshotCache ioa initCache - case M.lookup 20 initCache of - Just a -> assertEqual "module init cache contains only coin" ["coin"] (Pact4.moduleCacheKeys a) - Nothing -> assertFailure "failed to lookup block at 20" - -assertNoCacheMismatch - :: SHM.StableHashMap ModuleName (Maybe ModuleHash) - -> SHM.StableHashMap ModuleName (Maybe ModuleHash) - -> Assertion -assertNoCacheMismatch c1 c2 = assertBool msg $ c1 == c2 - where - showCache = intercalate "\n" . map show . SHM.toList - msg = mconcat - [ - "Module cache mismatch, found: \n" - , showCache c1 - , "\n expected: \n" - , showCache c2 - ] - -rewindToBlock :: (Logger logger) => CanReadablePayloadCas tbl => RewindPoint -> PactServiceM logger tbl () -rewindToBlock (rewindHeader, pwo) = void $ execValidateBlock mempty rewindHeader (CheckablePayloadWithOutputs pwo) - -doNextCoinbase :: (Logger logger, CanReadablePayloadCas tbl) => IO TestBlockDb -> PactServiceM logger tbl (BlockHeader, PayloadWithOutputs) -doNextCoinbase iobdb = do - bdb <- liftIO iobdb - prevH <- liftIO $ getParentTestBlockDb bdb testChainId - -- we have to execValidateBlock on `prevH` block height to update the parent header - pwo' <- liftIO $ getPWOByHeader prevH bdb - _ <- execValidateBlock mempty prevH (CheckablePayloadWithOutputs pwo') - - bip <- throwIfNoHistory =<< execNewBlock mempty noMiner NewBlockFill (ParentHeader prevH) - let prevH' = forAnyPactVersion (fromJuste . _blockInProgressParentHeader) bip - let pwo = forAnyPactVersion finalizeBlock bip - liftIO $ ParentHeader prevH @?= prevH' - void $ liftIO $ addTestBlockDb bdb (succ $ view blockHeight prevH) (Nonce 0) (offsetBlockTime second) testChainId pwo - nextH <- liftIO $ getParentTestBlockDb bdb testChainId - (valPWO, _g) <- execValidateBlock mempty nextH (CheckablePayloadWithOutputs pwo) - return (nextH, valPWO) - -doNextCoinbaseN_ - :: (Logger logger, CanReadablePayloadCas cas) - => Int - -> IO TestBlockDb - -> PactServiceM logger cas (BlockHeader, PayloadWithOutputs) -doNextCoinbaseN_ n iobdb = fmap last $ replicateM n $ doNextCoinbase iobdb - --- | Interfaces can't be upgraded, but modules can, so verify hash in that case. -justModuleHashes :: ModuleInitCache -> SHM.StableHashMap ModuleName (Maybe ModuleHash) -justModuleHashes = justModuleHashes' . snd . last . M.toList - -justModuleHashes' :: Pact4.ModuleCache -> SHM.StableHashMap ModuleName (Maybe ModuleHash) -justModuleHashes' = - fmap (preview (_1 . mdModule . _MDModule . mHash)) . Pact4.moduleCacheToHashMap - -initPayloadState - :: (CanReadablePayloadCas tbl, Logger logger, logger ~ GenericLogger) - => PactServiceM logger tbl () -initPayloadState = initialPayloadState testVer testChainId - -snapshotCache :: IO (MVar ModuleInitCache) -> ModuleInitCache -> IO () -snapshotCache iomcache initCache = do - mcache <- iomcache - modifyMVar_ mcache (const (pure initCache)) - -withPact' - :: (Logger logger, logger ~ GenericLogger) - => IO TestBlockDb - -> IO SQLiteEnv - -> IO (MVar ModuleInitCache) - -> CacheTest logger RocksDbTable - -> (String -> IO ()) - -> Assertion -withPact' bdbio ioSqlEnv r (ps, cacheTest) tastylog = do - bdb <- bdbio - bhdb <- getWebBlockHeaderDb (_bdbWebBlockHeaderDb bdb) testChainId - let pdb = _bdbPayloadDb bdb - sqlEnv <- ioSqlEnv - T2 _ pstate <- withPactService - testVer testChainId logger Nothing bhdb pdb sqlEnv testPactServiceConfig ps - cacheTest r (_psInitCache pstate) - where - logger = genericLogger Quiet (tastylog . T.unpack) diff --git a/test/unit/Chainweb/Test/Pact4/NoCoinbase.hs b/test/unit/Chainweb/Test/Pact4/NoCoinbase.hs index f1d13dc076..9084404991 100644 --- a/test/unit/Chainweb/Test/Pact4/NoCoinbase.hs +++ b/test/unit/Chainweb/Test/Pact4/NoCoinbase.hs @@ -24,7 +24,7 @@ import Test.Tasty.HUnit -- internal modules import Chainweb.Pact4.NoCoinbase -import Chainweb.Payload +import Chainweb.Pact.Payload tests :: TestTree tests = testGroup "Chainweb.Test.Pact4.NoCoinbase" diff --git a/test/unit/Chainweb/Test/Pact4/PactExec.hs b/test/unit/Chainweb/Test/Pact4/PactExec.hs deleted file mode 100644 index 67d3573115..0000000000 --- a/test/unit/Chainweb/Test/Pact4/PactExec.hs +++ /dev/null @@ -1,659 +0,0 @@ -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE NumericUnderscores #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE ViewPatterns #-} - --- | --- Module: Chainweb.Test.Pact --- Copyright: Copyright © 2018 Kadena LLC. --- License: See LICENSE file --- Maintainer: Mark Nichols --- Stability: experimental --- --- Unit test for Pact execution in Chainweb - -module Chainweb.Test.Pact4.PactExec -( tests -) where - -import Control.Lens hiding ((.=)) -import Control.Exception.Safe (tryAny) -import Control.Monad -import Data.Aeson -import qualified Data.ByteString.Lazy.Char8 as BL -import qualified Data.List as L -import Data.String -import Data.Text (Text, pack) -import qualified Data.Vector as V -import qualified Data.Yaml as Y - -import GHC.Generics (Generic) - -import Test.Tasty -import Test.Tasty.HUnit - --- internal modules - -import Chainweb.BlockHeader -import Chainweb.BlockHeaderDB (BlockHeaderDb) -import Chainweb.ChainId -import Chainweb.Graph hiding (KnownGraph(Pair)) -import Chainweb.Logger -import Chainweb.Miner.Pact -import Chainweb.Pact.PactService -import Chainweb.Pact.PactService.Checkpointer -import Chainweb.Pact.PactService.Pact4.ExecBlock -import Chainweb.Pact.Types -import Chainweb.Payload -import Chainweb.Payload.PayloadStore -import Chainweb.Payload.PayloadStore.InMemory (newPayloadDb) -import Chainweb.Storage.Table.RocksDB (RocksDb) -import Chainweb.Test.Pact4.Utils -import Chainweb.Test.Utils -import Chainweb.Test.TestVersions -import qualified Chainweb.Pact4.Transaction as Pact4 -import qualified Chainweb.Pact4.Types as Pact4 -import Chainweb.Version (ChainwebVersion(..), PactVersionT(..)) -import Chainweb.Version.Utils (someChainId) -import Chainweb.Utils hiding (check) - -import Pact.Types.Command -import Pact.Types.Hash -import Pact.Types.PactValue -import Pact.Types.Persistence -import Pact.Types.Pretty - -import qualified Pact.JSON.Encode as J -import Data.Functor.Product -import qualified Data.Aeson as Aeson -import qualified Data.Text.Lazy.Encoding as TL -import qualified Data.Text.Lazy as TL - -testVersion :: ChainwebVersion -testVersion = slowForkingCpmTestVersion petersenChainGraph - -testEventsVersion :: ChainwebVersion -testEventsVersion = fastForkingCpmTestVersion singletonChainGraph - -cid :: ChainId -cid = someChainId testVersion - -tests :: TestTree -tests = - withResource' newPayloadDb $ \pdb -> - withResourceT withRocksResource $ \rocksIO -> - testGroup label - - -- The test pact context evaluates the test code at block height 1. - -- fungible-v2 is installed at that block height 1. Because applying the - -- update twice results in an validation failures, we have to run each test on - -- a fresh pact environment. Unfortunately, that's a bit slow. - [ withPactCtxSQLite logger testVersion (bhdbIO testVersion rocksIO) pdb testPactServiceConfig $ - \ctx -> execTest testVersion ctx testReq2 - , withPactCtxSQLite logger testVersion (bhdbIO testVersion rocksIO) pdb testPactServiceConfig $ - \ctx -> execTest testVersion ctx testReq3 - , withPactCtxSQLite logger testVersion (bhdbIO testVersion rocksIO) pdb testPactServiceConfig $ - \ctx -> execTest testVersion ctx testReq4 - , withPactCtxSQLite logger testVersion (bhdbIO testVersion rocksIO) pdb testPactServiceConfig $ - \ctx -> execTest testVersion ctx testReq5 - , withPactCtxSQLite logger testEventsVersion (bhdbIO testEventsVersion rocksIO) pdb testPactServiceConfig $ - \ctx -> execTxsTest testEventsVersion ctx "testTfrGas" testTfrGas - , withPactCtxSQLite logger testVersion (bhdbIO testVersion rocksIO) pdb testPactServiceConfig $ - \ctx -> execTxsTest testVersion ctx "testGasPayer" testGasPayer - , withPactCtxSQLite logger testVersion (bhdbIO testVersion rocksIO) pdb testPactServiceConfig $ - \ctx -> execTxsTest testVersion ctx "testContinuationGasPayer" testContinuationGasPayer - , withPactCtxSQLite logger testVersion (bhdbIO testVersion rocksIO) pdb testPactServiceConfig $ - \ctx -> execTxsTest testVersion ctx "testExecGasPayer" testExecGasPayer - , withPactCtxSQLite logger testVersion (bhdbIO testVersion rocksIO) pdb testPactServiceConfig $ - \ctx -> execTest testVersion ctx testReq6 - , withPactCtxSQLite logger testVersion (bhdbIO testVersion rocksIO) pdb testPactServiceConfig $ - \ctx -> execTxsTest testVersion ctx "testTfrNoGasFails" testTfrNoGasFails - , withPactCtxSQLite logger testVersion (bhdbIO testVersion rocksIO) pdb testPactServiceConfig $ - \ctx -> execTxsTest testVersion ctx "testBadSenderFails" testBadSenderFails - , withPactCtxSQLite logger testVersion (bhdbIO testVersion rocksIO) pdb testPactServiceConfig $ - \ctx -> execTxsTest testVersion ctx "testFailureRedeem" testFailureRedeem - , withPactCtxSQLite logger testVersion (bhdbIO testVersion rocksIO) pdb testPactServiceConfig $ - \ctx -> execLocalTest ctx "testAllowReadsLocalFails" testAllowReadsLocalFails - , withPactCtxSQLite logger testVersion (bhdbIO testVersion rocksIO) pdb allowReads $ - \ctx -> execLocalTest ctx "testAllowReadsLocalSuccess" testAllowReadsLocalSuccess - ] - where - bhdbIO :: ChainwebVersion -> IO RocksDb -> IO BlockHeaderDb - bhdbIO v rocksIO = do - rdb <- rocksIO - let genesisHeader = genesisBlockHeader v cid - testBlockHeaderDb rdb genesisHeader - - label = "Chainweb.Test.Pact4.PactExec" - allowReads = testPactServiceConfig { _pactAllowReadsInLocal = True } - - logger = dummyLogger - --- -------------------------------------------------------------------------- -- --- Pact test datatypes - -type RunTest a = IO (TestResponse a) -> TestTree - --- | A test request is comprised of a list of commands, a textual discription, --- and an test runner function, that turns an IO acttion that produces are --- 'TestResponse' into a 'TestTree'. --- -data TestRequest = TestRequest - { _trCmds :: ![TestSource] - , _trDisplayStr :: !String - , _trEval :: !(RunTest TestSource) - } - - -data TestSource = File FilePath | Code String - deriving (Show, Generic, ToJSON) - -data TestResponse a = TestResponse - { _trOutputs :: ![(a, CommandResult Hash)] - , _trCoinBaseOutput :: !(CommandResult Hash) - } - deriving (Generic, Show) - -type TxsTest = (IO (V.Vector Pact4.Transaction), Either String (TestResponse String) -> Assertion) - --- -------------------------------------------------------------------------- -- --- sample data - -testReq2 :: TestRequest -testReq2 = TestRequest - { _trCmds = [ File "test1.pact" ] - , _trEval = checkSuccessOnly' "load module test1.pact" - , _trDisplayStr = "Loads a pact module" - } - -testReq3 :: TestRequest -testReq3 = TestRequest - { _trCmds = [ Code "(create-table test1.accounts)" ] - , _trEval = fileCompareTxLogs "create-table" - , _trDisplayStr = "Creates tables" - } - -testReq4 :: TestRequest -testReq4 = TestRequest - { _trCmds = [ Code "(test1.create-global-accounts)" ] - , _trEval = fileCompareTxLogs "create-accounts" - , _trDisplayStr = "Creates two accounts" - } - -testReq5 :: TestRequest -testReq5 = TestRequest - { _trCmds = [ Code "(test1.transfer \"Acct1\" \"Acct2\" 1.00)" ] - , _trEval = fileCompareTxLogs "transfer-accounts" - , _trDisplayStr = "Transfers from one account to another" - } - -testReq6 :: TestRequest -testReq6 = TestRequest - { _trCmds = - [ Code "(+ 1 1)" - , File "test1.pact" - , Code "(create-table test1.accounts)" - , Code "(test1.create-global-accounts)" - , Code "(test1.transfer \"Acct1\" \"Acct2\" 1.00)" - ] - , _trEval = checkSuccessOnly' "load test1.pact, create table, transfer" - , _trDisplayStr = "Transfers from one account to another" - } - - -assertResultFail :: Show a => HasCallStack => String -> String -> Either String a -> Assertion -assertResultFail msg expectErr (Left e) = assertSatisfies msg e ((L.isInfixOf expectErr).show) -assertResultFail msg _ (Right a) = assertFailure $ msg ++ ", received: " ++ show a - -checkResultSuccess :: HasCallStack => ([PactResult] -> Assertion) -> Either String (TestResponse String) -> Assertion -checkResultSuccess _ (Left e) = assertFailure $ "Expected success, got: " ++ show e -checkResultSuccess test (Right (TestResponse outs _)) = test $ map (_crResult . snd) outs - -checkPactResultSuccess :: HasCallStack => String -> PactResult -> (PactValue -> Assertion) -> Assertion -checkPactResultSuccess _ (PactResult (Right pv)) test = test pv -checkPactResultSuccess msg (PactResult (Left e)) _ = assertFailure $ msg ++ ": expected tx success, got " ++ show e - -checkPactResultSuccessLocal :: HasCallStack => String -> (PactValue -> Assertion) -> PactResult -> Assertion -checkPactResultSuccessLocal msg test r = checkPactResultSuccess msg r test - -checkPactResultFailure :: HasCallStack => String -> String -> PactResult -> Assertion -checkPactResultFailure msg _ (PactResult (Right pv)) = assertFailure $ msg ++ ": expected tx failure, got " ++ show pv -checkPactResultFailure msg expectErr (PactResult (Left e)) = assertSatisfies msg e ((L.isInfixOf expectErr).show) - -testTfrNoGasFails :: TxsTest -testTfrNoGasFails = - (V.singleton <$> tx, - assertResultFail "Expected missing (GAS) failure" "Keyset failure") - where - tx = buildCwCmd "testTfrNoGas" testVersion - $ set cbSigners - [ mkEd25519Signer' sender00 - [ mkTransferCap "sender00" "sender01" 1.0 ] - ] - $ set cbRPC (mkExec' "(coin.transfer \"sender00\" \"sender01\" 1.0)") - $ defaultCmd - -testTfrGas :: TxsTest -testTfrGas = (V.singleton <$> tx,test) - where - tx = buildCwCmd "testTfrGas" testEventsVersion $ set cbSigners - [ mkEd25519Signer' sender00 - [ mkTransferCap "sender00" "sender01" 1.0 - , mkGasCap - ] - ] - $ set cbRPC (mkExec' "(coin.transfer \"sender00\" \"sender01\" 1.0)") - $ defaultCmd - test (Left e) = assertFailure $ "Expected success, got " ++ show e - test (Right (TestResponse [(_,cr)] _)) = do - checkPactResultSuccess "transfer succeeds" (_crResult cr) $ \pv -> - assertEqual "transfer succeeds" (pString "Write succeeded") pv - e <- mkTransferEvent "sender00" "sender01" 1.0 "coin" "_S6HOO3J8-dEusvtnjSF4025dAxKu6eFSIOZocQwimA" - assertEqual "event found" [e] (_crEvents cr) - test r = assertFailure $ "expected single test response: " ++ show r - -testBadSenderFails :: TxsTest -testBadSenderFails = - (V.singleton <$> tx, - assertResultFail "Expected failure on bad sender" - "row not found: some-unknown-sender") - where - tx = buildCwCmd "testBadSenderFails" testVersion - $ set cbSigners [ mkEd25519Signer' sender00 [] ] - $ set cbSender "some-unknown-sender" - $ set cbRPC (mkExec' "(+ 1 2)") - $ defaultCmd - -testGasPayer :: TxsTest -testGasPayer = (txs,checkResultSuccess test) - where - loadCode = fmap V.fromList $ do - - impl <- loadGP - forM [ impl, setupUser, fundGasAcct ] $ \rpc -> - buildCwCmd "testGasPayer" testVersion $ - set cbSigners [s01] $ - set cbSender "sender01" $ - set cbRPC rpc $ - defaultCmd - - where - - loadGP = (`mkExec` mkKeySetData "gas-payer-operate" [sender01]) <$> - getPactCode (File "../../pact/gas-payer/gas-payer-v1-reference.pact") - - setupUser = mkExec - "(gas-payer-v1-reference.fund-user \"sender00\" (read-keyset \"sender00\") 100.0)" $ - mkKeySetData "sender00" [sender00] - - fundGasAcct = mkExec' - "(coin.transfer-create \"sender01\" \"gas-payer\" (gas-payer-v1-reference.create-gas-payer-guard) 100.0)" - - s01 = mkEd25519Signer' sender01 - [ mkTransferCap "sender01" "gas-payer" 100.0 - , mkGasCap - , mkCapability "user.gas-payer-v1-reference" "FUND_USER" [] - ] - - - runPaidTx = fmap V.singleton $ buildCwCmd "testGasPayer" testVersion $ - set cbSigners - [mkEd25519Signer' sender00 - [mkCapability "user.gas-payer-v1-reference" "GAS_PAYER" - [pString "sender00",pInteger 10_000,pDecimal 0.01]]] $ - set cbRPC (mkExec' "(+ 1 2)") $ - defaultCmd - - txs = do - l <- loadCode - r <- runPaidTx - return $! l <> r - - test [impl,setupUser,fundGasAcct,paidTx] = do - checkPactResultSuccess "impl" impl $ - assertEqual "impl" (pString "TableCreated") - checkPactResultSuccess "setupUser" setupUser $ - assertEqual "setupUser" (pString "Write succeeded") - checkPactResultSuccess "fundGasAcct" fundGasAcct $ - assertEqual "fundGasAcct" (pString "Write succeeded") - checkPactResultSuccess "paidTx" paidTx $ - assertEqual "paidTx" (pDecimal 3) - test r = assertFailure $ "Expected 4 results, got: " ++ show r - - -testContinuationGasPayer :: TxsTest -testContinuationGasPayer = (txs,checkResultSuccess test) - where - setupExprs = do - implCode <- getPactCode (File "../pact/continuation-gas-payer.pact") - return [ implCode - , "(coin.transfer-create \"sender00\" \"cont-gas-payer\" (gas-payer-for-cont.create-gas-payer-guard) 100.0)" - , "(simple-cont-module.some-two-step-pact)" - , "(coin.get-balance \"cont-gas-payer\")" ] - - setupTest = fmap V.fromList $ do - setupExprs' <- setupExprs - forM setupExprs' $ \se -> buildCwCmd "testContinuationGasPayer" testVersion $ - set cbSigners - [ mkEd25519Signer' sender00 - [ mkTransferCap "sender00" "cont-gas-payer" 100.0 - , mkGasCap - ]] $ - set cbRPC (mkExec' se) $ - defaultCmd - - contPactId = "toj9L2EGOyUUkFQCniHv8qGy8sStXDmaWSpVB3XKEuE" - - runStepTwoWithGasPayer = fmap V.singleton $ buildCwCmd "testContinuationGasPayer" testVersion $ - set cbSigners - [ mkEd25519Signer' sender01 - [ mkCapability "user.gas-payer-for-cont" "GAS_PAYER" - [pString "sender01",pInteger 10_000,pDecimal 0.01] - ]] $ - set cbSender "cont-gas-payer" $ - set cbRPC (mkCont $ mkContMsg (fromString contPactId) 1) $ - defaultCmd - - balanceCheck = fmap V.singleton $ buildCwCmd "testContinuationGasPayer2" testVersion $ - set cbSigners [mkEd25519Signer' sender00 []] $ - set cbRPC (mkExec' "(coin.get-balance \"cont-gas-payer\")") $ - defaultCmd - - txs = do - s <- setupTest - assertEqual "pact ID correct" (Just $ "\"" <> contPactId <> "\"") $ - preview (ix 2 . cmdHash . to show) s - r <- runStepTwoWithGasPayer - b <- balanceCheck - return $! s <> r <> b - - test [impl,fundGasAcct,contFirstStep,balCheck1,paidSecondStep,balCheck2] = do - checkPactResultSuccess "impl" impl $ assertEqual "impl" - (pString "Loaded module user.simple-cont-module, hash pCtVh0IDPvRIdVFXxznBFTwsZcwbIcYAnfv7yzr4wRI") - checkPactResultSuccess "fundGasAcct" fundGasAcct $ assertEqual "fundGasAcct" - (pString "Write succeeded") - checkPactResultSuccess "contFirstStep" contFirstStep $ assertEqual "contFirstStep" - (pString "Step One") - checkPactResultSuccess "balCheck1" balCheck1 $ - assertEqual "balCheck1" (pDecimal 100) - checkPactResultSuccess "paidSecondStep" paidSecondStep $ - assertEqual "paidSecondStep" - (pString "Step Two") - checkPactResultSuccess "balCheck2" balCheck2 $ - assertEqual "balCheck2" (pDecimal 99.999_4) - test r = assertFailure $ "Expected 6 results, got: " ++ show r - -testExecGasPayer :: TxsTest -testExecGasPayer = (txs,checkResultSuccess test) - where - setupExprs = do - implCode <- getPactCode (File "../pact/exec-gas-payer.pact") - return [ implCode - , "(coin.transfer-create \"sender00\" \"exec-gas-payer\" (gas-payer-for-exec.create-gas-payer-guard) 100.0)" - , "(coin.get-balance \"exec-gas-payer\")" ] - setupTest = fmap V.fromList $ do - setupExprs' <- setupExprs - forM setupExprs' $ \se -> buildCwCmd "testExecGasPayer" testVersion $ - set cbSigners - [ mkEd25519Signer' sender00 - [ mkTransferCap "sender00" "exec-gas-payer" 100.0 - , mkGasCap - ]] $ - set cbRPC (mkExec' se) $ - defaultCmd - - runPaidTx = fmap V.singleton $ buildCwCmd "testExecGasPayer" testVersion $ - set cbSigners - [mkEd25519Signer' sender01 - [mkCapability "user.gas-payer-for-exec" "GAS_PAYER" - [pString "sender01",pInteger 10_000,pDecimal 0.01]]] $ - set cbSender "exec-gas-payer" $ - set cbRPC (mkExec' "(+ 1 2)") $ - defaultCmd - - balanceCheck = fmap V.singleton $ buildCwCmd "testExecGasPayer" testVersion $ - set cbSigners [mkEd25519Signer' sender00 []] $ - set cbRPC (mkExec' "(coin.get-balance \"exec-gas-payer\")") $ - defaultCmd - - txs = do - s <- setupTest - r <- runPaidTx - b <- balanceCheck - return $! s <> r <> b - - test [impl,fundGasAcct,balCheck1,paidTx,balCheck2] = do - checkPactResultSuccess "impl" impl $ assertEqual "impl" - (pString "Loaded module user.gas-payer-for-exec, hash _S7ASfb_Lvr5wmjERG_XwPUoojW6GHBWI2u0W6jmID0") - checkPactResultSuccess "fundGasAcct" fundGasAcct $ assertEqual "fundGasAcct" - (pString "Write succeeded") - checkPactResultSuccess "balCheck1" balCheck1 $ assertEqual "balCheck1" (pDecimal 100) - checkPactResultSuccess "paidTx" paidTx $ assertEqual "paidTx" (pDecimal 3) - checkPactResultSuccess "balCheck2" balCheck2 $ assertEqual "balCheck2" (pDecimal 99.999_4) - test r = assertFailure $ "Expected 6 results, got: " ++ show r - -testFailureRedeem :: TxsTest -testFailureRedeem = (txs,checkResultSuccess test) - where - txs = fmap V.fromList $ forM exps $ \e -> buildCwCmd "testFailureRedeem" testVersion $ - set cbSigners [mkEd25519Signer' sender00 []] $ - set cbGasPrice 0.01 $ - set cbGasLimit 1000 $ - set cbRPC (mkExec' e) $ - defaultCmd - - exps = - ["(coin.get-balance \"sender00\")" - ,"(coin.get-balance \"miner\")" - ,"(enforce false \"forced error\")" - ,"(coin.get-balance \"sender00\")" - ,"(coin.get-balance \"miner\")"] - test [sbal0,mbal0,ferror,sbal1,mbal1] = do - -- sender 00 first is 100000000 - full gas debit during tx (1) - checkPactResultSuccess "sender bal 0" sbal0 $ - assertEqual "sender bal 0" (pDecimal 99_999_990) - -- miner first is reward + tx gas for [0] - checkPactResultSuccess "miner bal 0" mbal0 $ - assertEqual "miner bal 0" (pDecimal 2.504523) - -- this should reward 10 more to miner - checkPactResultFailure "forced error" "forced error" ferror - -- sender 00 second is down epsilon size costs - -- from [0,1] + 10 for error + 10 full gas debit during tx ~ 99999980 - checkPactResultSuccess "sender bal 1" sbal1 $ - assertEqual "sender bal 1" (pDecimal 99_999_979.6) - -- miner second is up 10 from error plus epsilon from [1,2,3] ~ 12 - checkPactResultSuccess "miner bal 1" mbal1 $ - assertEqual "miner bal 1" (pDecimal 12.904523) - test r = assertFailure $ "Expected 5 results, got: " ++ show r - - -checkLocalSuccess :: HasCallStack => (PactResult -> Assertion) -> Either String (CommandResult Hash) -> Assertion -checkLocalSuccess _ (Left e) = assertFailure $ "Expected success, got: " ++ show e -checkLocalSuccess test (Right cr) = test $ _crResult cr - -testAllowReadsLocalFails :: LocalTest -testAllowReadsLocalFails = (tx,test) - where - tx = buildCwCmd "testAllowReadsLocalFails" testVersion $ - set cbRPC (mkExec' "(read coin.coin-table \"sender00\")") $ - defaultCmd - test = checkLocalSuccess $ - checkPactResultFailure "testAllowReadsLocalFails" "Enforce non-upgradeability" - -testAllowReadsLocalSuccess :: LocalTest -testAllowReadsLocalSuccess = (tx,test) - where - tx = buildCwCmd "testAllowReadsLocalSuccess" testVersion $ - set cbRPC (mkExec' "(at 'balance (read coin.coin-table \"sender00\"))") $ - defaultCmd - test = checkLocalSuccess $ - checkPactResultSuccessLocal "testAllowReadsLocalSuccess" $ - assertEqual "sender00 bal" (pDecimal 100_000_000.0) - - --- -------------------------------------------------------------------------- -- --- Utils - -execTest - :: (Logger logger) - => ChainwebVersion - -> WithPactCtxSQLite logger tbl - -> TestRequest - -> TestTree -execTest v runPact request = _trEval request $ do - cmdStrs <- mapM getPactCode $ _trCmds request - trans <- mkCmds cmdStrs - results <- runPact $ (throwIfNoHistory =<<) $ - readFrom (Just $ ParentHeader $ genesisBlockHeader v cid) $ - SomeBlockM $ Pair - (execTransactions defaultMiner - trans (Pact4.EnforceCoinbaseFailure True) (Pact4.CoinbaseUsePrecompiled True) Nothing Nothing - >>= throwCommandInvalidError - ) - (error "Pact5") - - let outputs = V.toList $ snd <$> _transactionPairs results - return $ TestResponse - (zip (_trCmds request) (hashPact4TxLogs <$> outputs)) - (hashPact4TxLogs $ _transactionCoinbase results) - where - mkCmds cmdStrs = - fmap V.fromList $ forM (zip cmdStrs [0..]) $ \(code,n :: Int) -> - buildCwCmd ("1" <> sshow n) testVersion $ - set cbSigners [mkEd25519Signer' sender00 []] $ - set cbGasPrice 0.01 $ - set cbTTL 1_000_000 $ - set cbRPC (mkExec code $ mkKeySetData "test-admin-keyset" [sender00]) $ - defaultCmd - -execTxsTest - :: (Logger logger) - => ChainwebVersion - -> WithPactCtxSQLite logger tbl - -> String - -> TxsTest - -> TestTree -execTxsTest v runPact name (trans',check) = testCase name (go >>= check) - where - go = do - trans <- trans' - results' <- tryAllSynchronous $ runPact $ (throwIfNoHistory =<<) $ - readFrom (Just $ ParentHeader $ genesisBlockHeader v cid) $ - SomeBlockM $ Pair - (execTransactions defaultMiner trans - (Pact4.EnforceCoinbaseFailure True) (Pact4.CoinbaseUsePrecompiled True) Nothing Nothing - >>= throwCommandInvalidError - ) - (error "Pact5") - case results' of - Right results -> Right <$> do - let outputs = V.toList $ snd <$> _transactionPairs results - tcode = _pNonce . Pact4.payloadObj . _cmdPayload - inputs = map (showPretty . tcode) $ V.toList trans - return $ TestResponse - (zip inputs (hashPact4TxLogs <$> outputs)) - (hashPact4TxLogs $ _transactionCoinbase results) - Left e -> return $ Left $ show e - -type LocalTest = (IO Pact4.Transaction,Either String (CommandResult Hash) -> Assertion) - -execLocalTest - :: (Logger logger, CanReadablePayloadCas tbl) - => WithPactCtxSQLite logger tbl - -> String - -> LocalTest - -> TestTree -execLocalTest runPact name (trans',check) = testCase name (go >>= check) - where - go = do - trans <- trans' - results' <- tryAny $ runPact $ - execLocal (Pact4.unparseTransaction trans) Nothing Nothing Nothing - case results' of - Right (preview _MetadataValidationFailure -> Just e) -> - return $ Left $ show e - Right (preview _LocalTimeout -> Just ()) -> - return $ Left "LocalTimeout" - Right (preview _LocalResultLegacy -> Just cr) -> do - Just decodedCr <- return $ Aeson.decode (TL.encodeUtf8 $ TL.fromStrict $ J.getJsonText cr) - return $ Right decodedCr - Right (preview _LocalResultWithWarns -> Just (cr, _)) -> do - Just decodedCr <- return $ Aeson.decode (TL.encodeUtf8 $ TL.fromStrict $ J.getJsonText cr) - return $ Right decodedCr - Right _ -> error "unknown local result" - Left e -> - return $ Left $ show e - -getPactCode :: TestSource -> IO Text -getPactCode (Code str) = return (pack str) -getPactCode (File filePath) = pack <$> readFile' (testPactFilesDir ++ filePath) - -checkSuccessOnly :: CommandResult Hash -> Assertion -checkSuccessOnly cr = case _crResult cr of - PactResult (Right _) -> return () - r -> assertFailure $ "Failure status returned: " ++ show r - -checkSuccessOnly' :: String -> IO (TestResponse TestSource) -> TestTree -checkSuccessOnly' msg f = testCase msg $ f >>= \case - TestResponse res@(_:_) _ -> checkSuccessOnly (snd $ last res) - TestResponse res _ -> fail (show res) -- TODO - - --- | A test runner for golden tests. --- -fileCompareTxLogs :: String -> IO (TestResponse TestSource) -> TestTree -fileCompareTxLogs label respIO = golden label $ do - resp <- respIO - return $ BL.fromStrict $ Y.encode - $ coinbase (_trCoinBaseOutput resp) - : (result <$> _trOutputs resp) - where - result (cmd, out) = object - [ "output" .= J.toJsonViaEncode (_crLogs out) - , "cmd" .= cmd - ] - coinbase out = object - [ "output" .= J.toJsonViaEncode (_crLogs out) - , "cmd" .= ("coinbase" :: String) - ] - - -_showValidationFailure :: IO () -_showValidationFailure = do - txs <- fmap V.singleton $ buildCwCmd "nonce" testVersion $ - set cbSigners [mkEd25519Signer' sender00 []] $ - set cbRPC (mkExec' "(coin.transfer \"sender00\" \"sender01\" 1.0)") $ - defaultCmd - let cr1 = CommandResult - { _crReqKey = RequestKey pactInitialHash - , _crTxId = Nothing - , _crResult = PactResult $ Right $ pString "hi" - , _crGas = 0 - , _crLogs = Just [encodeTxLog $ TxLog "Domain" "Key" (object [ "stuff" .= True ])] - , _crContinuation = Nothing - , _crMetaData = Nothing - , _crEvents = [] - } - outs1 = Transactions - { _transactionPairs = V.zip txs (V.singleton cr1) - , _transactionCoinbase = cr1 - } - miner = defaultMiner - header = genesisBlockHeader testVersion $ someChainId testVersion - pwo = toPayloadWithOutputs Pact4T miner outs1 - cr2 = set crGas 1 cr1 - outs2 = Transactions - { _transactionPairs = V.zip txs (V.singleton cr2) - , _transactionCoinbase = cr2 - } - r = validateHashes header (CheckablePayloadWithOutputs pwo) miner outs2 - - BL.putStrLn $ case r of - Left e -> J.encode $ J.text (sshow e) - Right x -> encode x diff --git a/test/unit/Chainweb/Test/Pact4/PactMultiChainTest.hs b/test/unit/Chainweb/Test/Pact4/PactMultiChainTest.hs deleted file mode 100644 index b5eff22709..0000000000 --- a/test/unit/Chainweb/Test/Pact4/PactMultiChainTest.hs +++ /dev/null @@ -1,1834 +0,0 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE ImportQualifiedPost #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE NumericUnderscores #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE ViewPatterns #-} - -module Chainweb.Test.Pact4.PactMultiChainTest -( tests -) where - -import Control.Concurrent.MVar -import Control.Lens hiding ((.=)) -import Control.Monad -import Control.Monad.Catch -import Control.Monad.Reader -import Data.Aeson (Value, object, (.=)) -import qualified Data.ByteString.Base64.URL as B64U -import qualified Data.HashMap.Strict as HM -import Data.IORef -import Data.List(isPrefixOf) -import Data.List qualified as List -import qualified Data.Map as M -import Data.Maybe -import Data.Set (Set) -import Data.Set qualified as Set -import qualified Data.Text as T -import qualified Data.Vector as V -import Test.Tasty -import Test.Tasty.HUnit - --- internal modules - -import Pact.Types.Capability -import Pact.Types.Command -import Pact.Types.Continuation -import Pact.Types.Gas -import Pact.Types.Hash -import Pact.Types.Lang(_LString) -import Pact.Types.PactError -import Pact.Types.PactValue -import Pact.Types.Pretty -import Pact.Types.RPC -import Pact.Types.Runtime (PactEvent) -import Pact.Types.SPV -import Pact.Types.Term - -import Chainweb.BlockCreationTime -import Chainweb.BlockHeader -import Chainweb.BlockHeight -import Chainweb.ChainId -import Chainweb.Cut -import Chainweb.Mempool.Mempool -import Chainweb.Miner.Pact -import Chainweb.Pact.Backend.Types -import Chainweb.Pact.Types -import qualified Chainweb.Pact4.Transaction as Pact4 -import Chainweb.Pact4.TransactionExec (listErrMsg) -import Chainweb.Payload -import Chainweb.Payload.PayloadStore (lookupPayloadWithHeight) -import Chainweb.SPV.CreateProof -import Chainweb.Storage.Table.RocksDB -import Chainweb.Test.Cut -import Chainweb.Test.Cut.TestBlockDb -import Chainweb.Test.Pact4.Utils -import Chainweb.Test.Utils -import Chainweb.Test.TestVersions -import Chainweb.Time -import Chainweb.Utils -import Chainweb.Version -import Chainweb.WebPactExecutionService - - -testVersion :: ChainwebVersion -testVersion = slowForkingCpmTestVersion petersen - -cid :: ChainId -cid = unsafeChainId 9 - -- several tests in this file expect chain 9 - -data MultiEnv = MultiEnv - { _menvBdb :: !TestBlockDb - , _menvPact :: !WebPactExecutionService - , _menvPacts :: !(HM.HashMap ChainId (SQLiteEnv, PactExecutionService)) - , _menvCompactedPacts :: !(HM.HashMap ChainId (SQLiteEnv, PactExecutionService)) - , _menvMpa :: !(ChainMap (IORef MemPoolAccess)) - , _menvMiner :: !Miner - , _menvChainId :: !ChainId - } - -instance HasChainwebVersion MultiEnv where - _chainwebVersion = _chainwebVersion . _menvBdb - -makeLenses ''MultiEnv - -type PactTestM = ReaderT MultiEnv IO - -newtype MempoolCmdBuilder = MempoolCmdBuilder - { _mempoolCmdBuilder :: ChainId -> BlockCreationTime -> CmdBuilder - } - --- | Block filler. A 'Nothing' result means "skip this filler". -newtype MempoolBlock = MempoolBlock - { _mempoolBlock :: ChainId -> BlockCreationTime -> Maybe [MempoolCmdBuilder] - } - --- | Mempool with an ordered list of fillers. -newtype PactMempool = PactMempool - { _pactMempool :: [MempoolBlock] - } - deriving (Semigroup, Monoid) - - --- | Pair a builder with a test -data PactTxTest = PactTxTest - { _pttBuilder :: MempoolCmdBuilder - , _pttTest :: CommandResult Hash -> Assertion - } - -tests :: RocksDb -> TestTree -tests rdb = testGroup testName - [ test generousConfig "pact4coin3UpgradeTest" pact4coin3UpgradeTest - , test generousConfig "pact42UpgradeTest" pact42UpgradeTest - , test generousConfig "minerKeysetTest" minerKeysetTest - , test timeoutConfig "txTimeoutTest" txTimeoutTest - , test generousConfig "chainweb213Test" chainweb213Test - , test generousConfig "pact43UpgradeTest" pact43UpgradeTest - , test generousConfig "pact431UpgradeTest" pact431UpgradeTest - , test generousConfig "chainweb215Test" chainweb215Test - , test generousConfig "chainweb216Test" chainweb216Test - , test generousConfig "pact45UpgradeTest" pact45UpgradeTest - , test generousConfig "pact46UpgradeTest" pact46UpgradeTest - , test generousConfig "chainweb219UpgradeTest" chainweb219UpgradeTest - , test generousConfig "pactLocalDepthTest" pactLocalDepthTest - , test generousConfig "pact48UpgradeTest" pact48UpgradeTest - , test generousConfig "pact49UpgradeTest" pact49UpgradeTest - , test generousConfig "pact410UpgradeTest" pact410UpgradeTest - , test generousConfig "chainweb223Test" chainweb223Test - , test generousConfig "compactAndSyncTest" compactAndSyncTest - , test generousConfig "compactionCompactsUnmodifiedTables" compactionCompactsUnmodifiedTables - , quirkTest rdb - , test generousConfig "checkTransferCreate" checkTransferCreate - ] - - where - testName = "Chainweb.Test.Pact4.PactMultiChainTest" - -- This is way more than what is used in production, but during testing - -- we can be generous. - generousConfig = testPactServiceConfig { _pactNewBlockGasLimit = 300_000 } - timeoutConfig = testPactServiceConfig - { _pactNewBlockGasLimit = 300_000_000 - , _pactTxTimeLimit = Just 10_000 - } - - test pactConfig tname f = - withResourceT (mkTestBlockDb testVersion rdb) $ \bdbIO -> do - testCaseSteps tname $ \step -> do - bdb <- bdbIO - mempools <- onAllChains testVersion $ \_chain -> do - r <- newIORef mempty - return (r, delegateMemPoolAccess r) - let logger = hunitDummyLogger step - withWebPactExecutionServiceCompaction logger testVersion pactConfig bdb (snd <$> mempools) $ \(pact,pacts,_cPact,cPacts) -> - runReaderT f $ - MultiEnv bdb pact pacts cPacts (fst <$> mempools) noMiner cid - -minerKeysetTest :: PactTestM () -minerKeysetTest = do - - -- run past genesis, upgrades - runToHeight 24 - - -- run block 4 - local (set menvMiner badMiner) $ do - void runCut' - - -- run block 5 (fork for chainweb213) - r <- try $ runCut' - assertSatisfies "badMiner fails after fork" r $ \case - Left (CoinbaseFailure (Pact4CoinbaseFailure t)) -> "Invalid miner key" `T.isInfixOf` t - _ -> False - - where - - badMiner = Miner (MinerId "miner") $ MinerKeys $ mkKeySet ["bad-bad-bad"] "keys-all" - -txTimeoutTest :: PactTestM () -txTimeoutTest = do - -- get access to `enumerate` - runToHeight 20 - - -- we inline some of runBlockTest here because its assertions - -- don't make sense for tx timeout - let pts = - [ buildBasicGas 400 $ mkExec' "(+ 1 1)" - , buildBasicGas 10_000 $ mkExec' $ foldr - (\(_ :: Int) expr -> "(map (lambda (x) (+ x 1))" <> expr <> ")") - "(enumerate 1 1000)" - [1..6_000] -- make a huge nested tx - , buildBasicGas 400 $ mkExec' "(+ 2 2)" - ] - chid <- view menvChainId - - mempoolBadlistRef <- setPactMempool chid - $ PactMempool - $ List.singleton - $ MempoolBlock $ \_ _ -> pure pts - - blockBefore <- currentCut <&> (^?! (cutMap . ix chid)) - - liftIO $ do - badlisted <- readIORef mempoolBadlistRef - assertEqual "number of badlisted transactions is 0 before runCut'" 0 (Set.size badlisted) - - runCut' - - blockAfter <- currentCut <&> (^?! (cutMap . ix chid)) - - -- Ideally, we want to check the actual hash, but the DSL in this module - -- doesn't make that possible - liftIO $ do - badlisted <- readIORef mempoolBadlistRef - assertEqual "number of badlisted transactions is 1 after runCut'" 1 (Set.size badlisted) - assertEqual "block is still made despite timeout" (succ (view blockHeight blockBefore)) (view blockHeight blockAfter) - - rs <- txResults - liftIO $ assertEqual "number of transactions in block should be one (1) when second transaction times out" 1 (length rs) - -chainweb213Test :: PactTestM () -chainweb213Test = do - - -- run past genesis, upgrades - runToHeight 24 - - -- run block 25 - runBlockTest - [ PactTxTest buildModCmd1 $ - assertTxGas "Old gas cost" 47 - , PactTxTest (buildSimpleCmd' "(list 1 2 3)") $ - assertTxFailure "list failure 1_1" - listErrMsg - , PactTxTest buildDbMod $ - assertTxSuccess "mod db installs" $ - pString "TableCreated" - , PactTxTest (buildSimpleCmd' "(free.dbmod.fkeys)") $ - assertTxGas "fkeys gas cost 1" 205 - , PactTxTest (buildSimpleCmd' "(free.dbmod.ffolddb)") $ - assertTxGas "ffolddb gas cost 1" 206 - , PactTxTest (buildSimpleCmd' "(free.dbmod.fselect)") $ - assertTxGas "fselect gas cost 1" 206 - ] - - - -- run block 26 - runBlockTest - [ PactTxTest buildModCmd2 $ - assertTxGas "New gas cost" 60056 - , PactTxTest (buildSimpleCmd' "(list 1 2 3)") $ - assertTxFailure "list failure 2_1" - "Gas limit (50000) exceeded: 1000004" - , PactTxTest (buildSimpleCmd' "(free.dbmod.fkeys)") $ - assertTxGas "fkeys gas cost 2" 40005 - , PactTxTest (buildSimpleCmd' "(free.dbmod.ffolddb)") $ - assertTxGas "ffolddb gas cost 2" 40006 - , PactTxTest (buildSimpleCmd' "(free.dbmod.fselect)") $ - assertTxGas "fselect gas cost 2" 40006 - ] - - - where - - buildSimpleCmd' code = buildBasicGas 50000 - $ mkExec' code - buildModCmd1 = buildBasic - $ mkExec' $ mconcat ["(namespace 'free)", "(module mtest G (defcap G () true) (defun a () true))"] - buildModCmd2 = buildBasicGas 70000 - $ mkExec' $ mconcat ["(namespace 'free)", "(module mtest2 G (defcap G () true) (defun a () false))"] - buildDbMod = buildBasicGas 70000 - $ mkExec' $ mconcat - [ "(namespace 'free)" - , "(module dbmod G (defcap G () true)" - , " (defschema sch i:integer) (deftable tbl:{sch})" - , " (defun fkeys () (keys tbl))" - , " (defun ffolddb () (fold-db tbl (lambda (a b) true) (constantly true)))" - , " (defun fselect () (select tbl (constantly true))))" - , "(create-table tbl)" - ] - -pactLocalDepthTest :: PactTestM () -pactLocalDepthTest = do - runToHeight 53 - runBlockTest - [ PactTxTest (buildCoinXfer "(coin.transfer 'sender00 'sender01 1.0)") $ - assertTxGas "Coin transfer pre-fork" 1574 - ] - runBlockTest - [ PactTxTest (buildCoinXfer "(coin.transfer 'sender00 'sender01 1.0)") $ - assertTxGas "Coin post-fork" 1574 - ] - - runLocalWithDepth "0" (Just $ RewindDepth 0) cid getSender00Balance >>= \r -> - checkLocalResult r $ assertTxSuccess "Should get the current balance" (pDecimal 99_999_997.6852) - - -- checking that `Just $ RewindDepth 0` has the same behaviour as `Nothing` - runLocalWithDepth "1" Nothing cid getSender00Balance >>= \r -> - checkLocalResult r $ assertTxSuccess "Should get the current balance as well" (pDecimal 99_999_997.6852) - - runLocalWithDepth "2" (Just $ RewindDepth 1) cid getSender00Balance >>= \r -> - checkLocalResult r $ assertTxSuccess "Should get the balance one block before" (pDecimal 99_999_998.8426) - - runLocalWithDepth "3" (Just $ RewindDepth 2) cid getSender00Balance >>= \r -> - checkLocalResult r $ assertTxSuccess "Should get the balance two blocks before" (pDecimal 100_000_000) - - -- the genesis depth - runLocalWithDepth "5" (Just $ RewindDepth 55) cid getSender00Balance >>= \r -> - checkLocalResult r $ assertTxSuccess "Should get the balance at the genesis block" (pDecimal 100000000) - - -- local rewinding past genesis should be the same as rewinding to genesis - runLocalWithDepth "6" (Just $ RewindDepth 56) cid getSender00Balance >>= \r -> - checkLocalResult r $ assertTxSuccess "Should get the balance at the genesis block" (pDecimal 100000000) - - where - checkLocalResult r checkResult = case r of - Right (preview _Pact4LocalResultLegacy -> Just cr) -> checkResult cr - res -> liftIO $ assertFailure $ "Expected LocalResultLegacy, but got: " ++ show res - getSender00Balance = set cbGasLimit 700 $ set cbRPC (mkExec' "(coin.get-balance \"sender00\")") $ defaultCmd - buildCoinXfer code = buildBasic' - (set cbSigners [mkEd25519Signer' sender00 coinCaps] . set cbGasLimit 3000) - $ mkExec' code - where - coinCaps = [ mkGasCap, mkTransferCap "sender00" "sender01" 1.0 ] - -pact45UpgradeTest :: PactTestM () -pact45UpgradeTest = do - runToHeight 53 -- 2 before fork - runBlockTest - [ PactTxTest - (buildBasicGas 70_000 $ tblModule "tbl") $ - assertTxSuccess "mod53 table created" $ pString "TableCreated" - ] - runBlockTest - [ PactTxTest (buildSimpleCmd "(enforce false 'hi)") $ - assertTxFailure "Should fail with the error from the enforce" "hi" - , PactTxTest (buildSimpleCmd "(enforce true (format \"{}-{}\" [12345, 657859]))") $ - assertTxGas "Enforce pre-fork evaluates the string with gas" 25 - , PactTxTest (buildSimpleCmd "(enumerate 0 10) (str-to-list 'hi) (make-list 10 'hi)") $ - assertTxGas "List functions pre-fork gas" 10 - , PactTxTest - (buildBasicGas 70_000 $ tblModule "Tbl") $ - assertTxSuccess "mod53 table update succeeds" $ pString "TableCreated" - , PactTxTest (buildCoinXfer "(coin.transfer 'sender00 'sender01 1.0)") $ - assertTxGas "Coin transfer pre-fork" 1574 - ] - -- chainweb217 fork - runBlockTest - [ PactTxTest (buildSimpleCmd "(+ 1 \'clearlyanerror)") $ - assertTxFailure "Should replace tx error with empty error" "" - , PactTxTest (buildSimpleCmd "(enforce true (format \"{}-{}\" [12345, 657859]))") $ - assertTxGas "Enforce post fork does not eval the string" (15 + coinTxBuyTransferGas) - , PactTxTest (buildSimpleCmd "(enumerate 0 10) (str-to-list 'hi) (make-list 10 'hi)") $ - assertTxGas "List functions post-fork change gas" (40 + coinTxBuyTransferGas) - , PactTxTest - (buildBasicGas 70_000 $ tblModule "tBl") $ - assertTxFailure "mod53 table update fails after fork" "" - , PactTxTest (buildCoinXfer "(coin.transfer 'sender00 'sender01 1.0)") $ - assertTxGas "Coin post-fork" 700 - ] - -- run local to check error - lr <- runLocal "0" cid $ set cbGasLimit 70_000 $ set cbRPC (tblModule "tBl") $ defaultCmd - assertLocalFailure "mod53 table update error" - (pretty $ show $ PactDuplicateTableError "free.mod53_tBl") - lr - - where - tblModule tn = mkExec' $ T.replace "$TABLE$" tn - " (namespace 'free) \ - \ (module mod53 G \ - \ (defcap G () true) \ - \ (defschema sch s:string) \ - \ (deftable $TABLE$:{sch})) \ - \ (create-table $TABLE$)" - buildCoinXfer code = buildBasic' - (set cbSigners [mkEd25519Signer' sender00 coinCaps] . set cbGasLimit 3000) - $ mkExec' code - where - coinCaps = [ mkGasCap, mkTransferCap "sender00" "sender01" 1.0 ] - coinTxBuyTransferGas = 206 - buildSimpleCmd code = buildBasicGas 3000 - $ mkExec' code - -runLocal :: T.Text -> ChainId -> CmdBuilder -> PactTestM (Either PactException LocalResult) -runLocal nonce cid' cmd = runLocalWithDepth nonce Nothing cid' cmd - -runLocalWithDepth :: T.Text -> Maybe RewindDepth -> ChainId -> CmdBuilder -> PactTestM (Either PactException LocalResult) -runLocalWithDepth nonce depth cid' cmd = do - pact <- getPactService cid' - cwCmd <- buildCwCmd nonce testVersion cmd - liftIO $ try @_ @PactException $ _pactLocal pact Nothing Nothing depth (Pact4.unparseTransaction cwCmd) - -getPactService :: ChainId -> PactTestM PactExecutionService -getPactService cid' = do - HM.lookup cid' <$> view menvPacts >>= \case - Just (_, pact) -> return pact - Nothing -> liftIO $ assertFailure $ "No pact service found at chain id " ++ show cid' - -assertLocalFailure - :: (HasCallStack, MonadIO m) - => String - -> Doc - -> Either PactException LocalResult - -> m () -assertLocalFailure s d lr = - liftIO $ assertEqual s (Just d) $ - lr ^? _Right . _Pact4LocalResultLegacy . crResult . to _pactResult . _Left . to peDoc - -assertLocalSuccess - :: (HasCallStack, MonadIO m) - => String - -> PactValue - -> Either PactException LocalResult - -> m () -assertLocalSuccess s pv lr = - liftIO $ assertEqual s (Just pv) $ - lr ^? _Right . _Pact4LocalResultLegacy . crResult . to _pactResult . _Right - -pact43UpgradeTest :: PactTestM () -pact43UpgradeTest = do - - -- run past genesis, upgrades - runToHeight 29 - - runBlockTest - [ PactTxTest buildMod $ - assertTxGas "Old gas cost" 120323 - , PactTxTest buildModPact $ - assertTxFailure - "Should not resolve new pact native: continue" - "Cannot resolve \"continue\"" - , PactTxTest (buildSimpleCmd "(create-principal (read-keyset 'k))") $ - assertTxFailure - "Should not resolve new pact native: create-principal" - "Cannot resolve create-principal" - , PactTxTest (buildSimpleCmd "(validate-principal (read-keyset 'k) \"k:368820f80c324bbc7c2b0610688a7da43e39f91d118732671cd9c7500ff43cca\")") $ - assertTxFailure - "Should not resolve new pact natives: validate-principal" - "Cannot resolve validate-principal" - , PactTxTest (buildXSend []) $ - assertTxSuccess "xsend success" $ - pObject [ ("amount",pDecimal 0.0123) - , ("receiver",pString "sender00") - , ("receiver-guard",pKeySet sender00Ks) - ] - ] - - tx30_4 <- txResult 4 - - runBlockTest - [ PactTxTest buildMod $ - assertTxGas "Old gas cost" 120287 - , PactTxTest buildModPact $ - assertTxSuccess - "Should resolve continue in a module defn" - (pString "Loaded module free.nestedMod, hash fDd0G7zvGar3ax2q0I0F9dISRq7Pjop5rUXOeokNIOU") - , PactTxTest (buildSimpleCmd "(free.modB.chain)") $ - assertTxSuccess - "Should resolve names properly post-fork" - -- Note: returns LDecimal because of toPactValueLenient in interpret - (pDecimal 11) - , PactTxTest (buildSimpleCmd "(free.modB.get-test)") $ - assertTxSuccess - "Should resolve names properly post-fork" - (pString "hello") - , PactTxTest (buildSimpleCmd "(create-principal (read-keyset 'k))") $ - assertTxSuccess - "Should resolve create-principal properly post-fork" - (pString "k:368820f80c324bbc7c2b0610688a7da43e39f91d118732671cd9c7500ff43cca") - , PactTxTest (buildSimpleCmd "(validate-principal (read-keyset 'k) \"k:368820f80c324bbc7c2b0610688a7da43e39f91d118732671cd9c7500ff43cca\")") $ - assertTxSuccess - "Should resolve validate-principal properly post-fork" - (pBool True) - ] - - resetMempool - runToHeight 33 - - xproof <- buildXProof cid 30 4 tx30_4 - - withChain chain0 $ runBlockTest - [ PactTxTest (buildXReceive xproof) $ - assertTxSuccess "xreceive success" (pString "Write succeeded") - ] - - where - - buildSimpleCmd code = buildBasicGas 1000 - $ mkExec code - $ mkKeySetData "k" [sender00] - buildModPact = buildBasicGas 70000 - $ mkExec' (mconcat - [ "(namespace 'free)" - , "(module nestedMod G" - , " (defcap G () true)" - , " (defpact test:string () (step \"1\") (step \"2\") (step \"3\"))" - , " (defpact test-nested:string () (step (test)) (step (continue (test))) (step (continue (test))))" - , ")" - ]) - buildMod = buildBasicGas 130000 - $ mkExec (mconcat - [ "(namespace 'free)" - , "(module modA G" - , " (defcap G () true)" - , " (defun func:integer (x:integer) (+ 1 x))" - , " (defun func2:integer (x:integer) (+ (func x) (func x)))" - , " (defconst test:string \"hi\")" - , ")" - , "(module modB G" - , " (defcap G () true)" - , " (defun chain:integer () (modA.func 10))" - , " (defconst test:string \"hello\")" - , " (defun get-test() test)" - , ")" - ]) - $ mkKeySetData "k" [sender00] - -chainweb215Test :: PactTestM () -chainweb215Test = do - - -- run past genesis, upgrades - runToHeight 30 -- 1->30 - - -- execute pre-fork xchain transfer (blocc0) - runBlockTest - [ PactTxTest xsend $ \cr -> do - evs <- mkSendEvents 0.0416 v4Hash - assertTxEvents "Transfer events @ block 31" evs cr - ] - send0 <- txResult 0 - - -- run past v5 upgrade, build proof of pre-fork xchain for tx31_0, save cut - resetMempool - runToHeight 34 - savedCut <- currentCut - runToHeight 41 - - xproof <- buildXProof cid 31 0 send0 - - let blockSend42 = - [ PactTxTest xsend $ \cr -> do - evs <- mkSendEvents 0.0419 v5Hash - assertTxEvents "Transfer events @ block 42 - post-fork send" evs cr - ] - blockRecv42 = - [ PactTxTest (buildXReceive xproof) $ \cr -> do - evs <- mkRecdEvents v5Hash v4Hash - assertTxEvents "Transfer events @ block 42" evs cr - ] - - void $ setPactMempool cid $ PactMempool - [ testsToBlock blockSend42 ] - - void $ setPactMempool chain0 $ PactMempool - [ testsToBlock blockRecv42 ] - - runCut' - withChain cid $ testCurrentBlock blockSend42 - withChain chain0 $ testCurrentBlock blockRecv42 - - send1 <- withChain cid $ txResult 0 - - currCut <- currentCut - - -- rewind to saved cut 43 - syncTo savedCut - runToHeight 43 - - -- resume on original cut - syncTo currCut - - -- run until post-fork xchain proof exists - resetMempool - runToHeight 50 - savedCut1 <- currentCut - runToHeight 52 - - xproof1 <- buildXProof cid 42 0 send1 - - withChain chain0 $ runBlockTest - [ PactTxTest (buildXReceive xproof1) $ \cr -> do - evs <- mkRecdEvents v5Hash v5Hash - assertTxEvents "Transfer events @ block 53" evs cr - ] - - -- rewind to saved cut 50 - syncTo savedCut1 - runToHeight 53 - - where - xsend = buildXSend - [ mkGasCap - , mkXChainTransferCap "sender00" "sender00" 0.0123 "0" - ] - - v4Hash = "BjZW0T2ac6qE_I5X8GE4fal6tTqjhLTC7my0ytQSxLU" - v5Hash = "rE7DU8jlQL9x_MPYuniZJf5ICBTAEHAIFQCB4blofP4" - - mkSendEvents cbCost h = sequence - [ mkTransferEvent "sender00" "NoMiner" cbCost "coin" h - , mkTransferXChainEvent "sender00" "sender00" 0.0123 "coin" h "0" - , mkTransferEvent "sender00" "" 0.0123 "coin" h - , mkXYieldEvent "sender00" "sender00" 0.0123 sender00Ks "pact" h "0" "0" - ] - - mkRecdEvents h h' = sequence - [ mkTransferEvent "sender00" "NoMiner" 0.0249 "coin" h - , mkTransferEvent "" "sender00" 0.0123 "coin" h - , mkTransferXChainRecdEvent "" "sender00" 0.0123 "coin" h (toText cid) - , mkXResumeEvent "sender00" "sender00" 0.0123 sender00Ks "pact" h' (toText cid) "0" - ] - -pact431UpgradeTest :: PactTestM () -pact431UpgradeTest = do - - -- run past genesis, upgrades - runToHeight 34 - - -- run block 35, pre fork - runBlockTest - [ PactTxTest describeModule $ - assertTxSuccess "describe-module legacy success" - $ pBool True - , PactTxTest isPrincipal $ - assertTxFailure "Should not resolve new pact native: is-principal" - "Cannot resolve is-principal" - , PactTxTest typeOfPrincipal $ - assertTxFailure "Should not resolve new pact native: typeof-principal" - "Cannot resolve typeof-principal" - , PactTxTest enforcePactVersion $ - assertTxSuccess "Enforce pact version passes pre-fork" - $ pBool True - , PactTxTest pactVersion $ - assertTxSuccess "Pact version is 4.2.1 for compat pre-fork" - $ pString "4.2.1" - ] - - -- run block 36, post fork - runBlockTest - [ PactTxTest describeModule $ - assertTxFailure "Should fail to execute describe-module" - "Operation only permitted in local execution mode" - , PactTxTest isPrincipal $ - assertTxSuccess "Should resolve new pact native: is-principal" - $ pBool True - , PactTxTest typeOfPrincipal $ - assertTxSuccess "Should resolve new pact native: typeof-principal" - $ pString "k:" - , PactTxTest enforcePactVersion $ - assertTxFailure "Should fail to execute enforce-pact-version" - "Operation only permitted in local execution mode" - , PactTxTest pactVersion $ - assertTxFailure "Should fail to execute pact-version" - "Operation only permitted in local execution mode" - ] - - - where - isPrincipal = - buildSimpleCmd "(is-principal (create-principal (read-keyset 'k)))" - typeOfPrincipal = - buildSimpleCmd "(typeof-principal (create-principal (read-keyset 'k)))" - enforcePactVersion = - buildSimpleCmd "(enforce-pact-version \"4.2.1\")" - pactVersion = - buildSimpleCmd "(pact-version)" - buildSimpleCmd code = buildBasicGas 1000 - $ mkExec code - $ mkKeySetData "k" [sender00] - describeModule = buildBasicGas 100000 - $ mkExec' (mconcat - [ "(namespace 'free)" - , "(module mod G" - , " (defcap G () true)" - , " (defun f () true)" - , ")" - , "(describe-module \"free.mod\") true" - ]) - - -pact42UpgradeTest :: PactTestM () -pact42UpgradeTest = do - - -- run past genesis, upgrades - runToHeight 3 - - -- run block 4 - runBlockTest - [ PactTxTest buildNewNatives420FoldDbCmd $ - assertTxFailure - "Should not resolve new pact natives" - "Cannot resolve fold-db" - , PactTxTest buildNewNatives420ZipCmd $ - assertTxFailure - "Should not resolve new pact natives" - "Cannot resolve zip" - , PactTxTest buildFdbCmd $ - assertTxSuccess - "Load fdb module" - (pString "Write succeeded") - ] - - cbResult >>= assertTxEvents "Coinbase events @ block 4" [] - - -- run block 5 - - -- runBlockTest - -- [ PactTxTest buildNewNatives420FoldDbCmd $ - -- assertTxSuccess - -- "Should resolve fold-db pact native" $ - -- pList [pObject [("a", pInteger 1),("b",pInteger 1)] - -- ,pObject [("a", pInteger 2),("b",pInteger 2)]] - -- , PactTxTest buildNewNatives420ZipCmd $ - -- assertTxSuccess - -- "Should resolve zip pact native" $ - -- pList $ pInteger <$> [5,7,9] - -- ] - - cbResult >>= assertTxEvents "Coinbase events @ block 5" [] - - where - - buildFdbCmd = buildBasic - $ mkExec' $ mconcat ["(namespace 'free)", moduleDeclaration, inserts] - where - moduleDeclaration = - "(module fdb G (defcap G () true) (defschema fdb-test a:integer b:integer) (deftable fdb-tbl:{fdb-test}))" - inserts = - mconcat - [ - "(create-table free.fdb.fdb-tbl)" - , "(insert free.fdb.fdb-tbl 'b {'a:2, 'b:2})" - , "(insert free.fdb.fdb-tbl 'd {'a:4, 'b:4})" - , "(insert free.fdb.fdb-tbl 'c {'a:3, 'b:3})" - , "(insert free.fdb.fdb-tbl 'a {'a:1, 'b:1})" - ] - - buildNewNatives420FoldDbCmd = buildBasic - $ mkExec' - "(let* ((qry (lambda (k o) (< k \"c\"))) (consume (lambda (k o) o))) (fold-db free.fdb.fdb-tbl (qry) (consume)))" - - - buildNewNatives420ZipCmd = buildBasic - $ mkExec' "(zip (+) [1 2 3] [4 5 6])" - -chainweb216Test :: PactTestM () -chainweb216Test = do - -- This test should handles for format and try as well as - -- keyset format changes and disallowances across fork boundaries. - -- - -- Namely, to test keys properly, we should: - -- - -- 1. Make sure keys defined before and after - -- fork boundaries pass enforcement. - -- - -- 2. Keys defined after the fork are only - -- definable if a namespace is present. - -- - - -- run past genesis, upgrades - runToHeight 52 - - runBlockTest - [ PactTxTest (buildSimpleCmd formatGas) $ - assertTxGas "Pre-fork format gas" 11 - , PactTxTest (buildSimpleCmd tryGas) $ - assertTxGas "Pre-fork try" 9 - , PactTxTest (buildSimpleCmd defineNonNamespacedPreFork) $ - assertTxSuccess - "Should pass when defining a non-namespaced keyset" - (pBool True) - , PactTxTest (buildSimpleCmd defineNamespacedPreFork) $ - -- Note, keysets technically are not namespaced pre-fork, the new parser isn't applied - assertTxSuccess - "Should pass when defining a \"namespaced\" keyset pre fork" - (pBool True) - ] - - runBlockTest - [ PactTxTest (buildSimpleCmd formatGas) $ - assertTxGas "Post-fork format gas increase" 38 - , PactTxTest (buildSimpleCmd tryGas) $ - assertTxGas "Post-fork try should charge a bit more gas" 10 - , PactTxTest (buildSimpleCmd defineNonNamespacedPostFork1) $ - assertTxFailure - "Should fail when defining a non-namespaced keyset post fork" - "Mismatching keyset namespace" - , PactTxTest (buildSimpleCmd defineNamespacedPostFork) $ - assertTxSuccess - "Pass when defining a namespaced keyset post fork" - (pBool True) - , PactTxTest (buildSimpleCmd enforceNamespacedFromPreFork) $ - assertTxSuccess - "Should work in enforcing a namespaced keyset created prefork" - (pBool True) - , PactTxTest (buildSimpleCmd enforceNonNamespacedFromPreFork) $ - assertTxSuccess - "Should work in enforcing a non-namespaced keyset created prefork" - (pBool True) - , PactTxTest (buildSimpleCmd defineNonNamespacedPostFork2) $ - assertTxFailure - "Should fail in defining a keyset outside a namespace" - "Cannot define a keyset outside of a namespace" - , PactTxTest buildModCommand $ - assertTxSuccess - "Should succeed in deploying a module guarded by a namespaced keyset" - (pString "Loaded module free.m1, hash nOHaU-gPtmZTj6ZA3VArh-r7LEiwVUMN_RLJeW2hNv0") - , PactTxTest (buildSimpleCmd rotateLegacyPostFork) $ - assertTxSuccess - "Should succeed in rotating and enforcing a legacy keyset" - (pBool True) - , PactTxTest (buildSimpleCmd rotateNamespacedPostFork) $ - assertTxSuccess - "Should succeed in rotating and enforcing a namespaced keyset" - (pBool True) - ] - - runBlockTest - [ PactTxTest (buildSimpleCmd "(free.m1.f)") $ - assertTxSuccess - "Should call a module with a namespaced keyset correctly" - (pDecimal 1) - , PactTxTest (buildSimpleCmd "(^ \ - \ 15.034465284692086701747761395233132973944448512421004399685858401206740385711739229018307610943234609057822959334669087436253689423614206061665462283698768757790600552385430913941421707844383369633809803959413869974997415115322843838226312287673293352959835 \ - \ 3.466120406090666777582519661568003549307295836842780244500133445635634490670936927006970368136648330889718447039413255137656971927890831071689768359173260960739254160211017410322799793419223796996260056081828170546988461285168124170297427792046640116184356)") $ - assertTxSuccess - "musl exponentiation regression" - (pDecimal 12020.67042599064370733685791492462158203125) - ] - - - where - defineNonNamespacedPreFork = mconcat - [ "(define-keyset \'k123)" - , "(enforce-guard (keyset-ref-guard \'k123))" - ] - defineNamespacedPreFork = mconcat - [ "(define-keyset \"free.k123\")" - , "(enforce-guard (keyset-ref-guard \"free.k123\"))" - ] - defineNonNamespacedPostFork1 = mconcat - [ "(namespace 'free)" - , "(define-keyset \'k456)" - ] - defineNonNamespacedPostFork2 = mconcat - [ "(define-keyset \'k456)" - ] - defineNamespacedPostFork = mconcat - [ "(namespace 'free)" - , "(define-keyset \"free.k456\")" - , "(enforce-guard (keyset-ref-guard \"free.k456\"))" - ] - rotateLegacyPostFork = mconcat - [ "(namespace 'free)" - , "(define-keyset \"k123\" (read-keyset 'k456))" - , "(enforce-guard (keyset-ref-guard \"k123\"))" - ] - rotateNamespacedPostFork = mconcat - [ "(namespace 'free)" - , "(define-keyset \"free.k123\" (read-keyset 'k456))" - , "(enforce-guard (keyset-ref-guard \"free.k123\"))" - ] - defineModulePostFork = mconcat - [ "(namespace 'free)" - , "(module m1 \"free.k456\" (defun f () 1))" - ] - enforceNamespacedFromPreFork = "(enforce-guard (keyset-ref-guard \"free.k123\"))" - enforceNonNamespacedFromPreFork = "(enforce-guard (keyset-ref-guard \"k123\"))" - tryGas = "(try (+ 1 1) (enforce false \"abc\"))" - formatGas = "(format \"{}-{}\" [1234567, 890111213141516])" - - - buildModCommand = buildBasicGas 70000 - $ mkExec' defineModulePostFork - - buildSimpleCmd code = buildBasicGas 10000 - $ mkExec code - $ object - [ "k123" .= map fst [sender00] - , "k456" .= map fst [sender00] - , "free.k123" .= map fst [sender00] - , "free.k456" .= map fst [sender00]] - - -pact46UpgradeTest :: PactTestM () -pact46UpgradeTest = do - - -- run past genesis, upgrades - runToHeight 58 - - -- Note: no error messages on-chain, so the error message is empty - runBlockTest - [ PactTxTest pointAddTx $ - assertTxFailure - "Should not resolve new pact native: point-add" - "" - , PactTxTest scalarMulTx $ - assertTxFailure - "Should not resolve new pact native: scalar-mult" - "" - , PactTxTest pairingTx $ - assertTxFailure - "Should not resolve new pact native: pairing-check" - "" - ] - - runBlockTest - [ PactTxTest pointAddTx $ - assertTxSuccess - "Should resolve point-add properly post-fork" - (pObject [("x", pInteger 1368015179489954701390400359078579693043519447331113978918064868415326638035) - , ("y", pInteger 9918110051302171585080402603319702774565515993150576347155970296011118125764)]) - , PactTxTest scalarMulTx $ - assertTxSuccess - "Should resolve scalar-mult properly post-fork" - (pObject [("x", pInteger 1) - , ("y", pInteger 2)]) - , PactTxTest pairingTx $ - assertTxSuccess - "Should resolve scalar-mult properly post-fork" - (pBool True) - ] - where - pointAddTx = buildBasicGas 10000 - $ mkExec' (mconcat - [ "(point-add 'g1 {'x:1, 'y:2} {'x:1, 'y:2})" - ]) - scalarMulTx = buildBasicGas 10000 - $ mkExec' (mconcat - [ "(scalar-mult 'g1 {'x: 1, 'y: 2} 1)" - ]) - pairingTx = buildBasicGas 30000 - $ mkExec' (mconcat - [ "(pairing-check [{'x: 1, 'y: 2}] [{'x:[0, 0], 'y:[0, 0]}])" - ]) - - -chainweb219UpgradeTest :: PactTestM () -chainweb219UpgradeTest = do - - -- run past genesis, upgrades - runToHeight 69 - - -- Block 70, pre-fork, no errors on chain - runBlockTest - [ PactTxTest addErrTx $ - assertTxFailure - "Should fail on + with incorrect argument types" - "" - , PactTxTest mapErrTx $ - assertTxFailure - "Should fail on map with the second argument not being a list" - "" - , PactTxTest nativeDetailsTx $ - assertTxSuccessWith - "Should print native details on chain" - (pString nativeDetailsMsg) - (over (_PLiteral . _LString) (T.take (T.length nativeDetailsMsg))) - , PactTxTest fnDetailsTx $ - assertTxSuccessWith - "Should display function preview string" - (pString fnDetailsMsg) - (over (_PLiteral . _LString) (T.take (T.length fnDetailsMsg))) - , PactTxTest decTx $ - assertTxFailure - "Should not resolve new pact native: dec" - -- Should be cannot resolve dec, but no errors pre-fork. - "" - , PactTxTest runIllTypedFunction $ - assertTxSuccess - "User function return value types should not be checked before the fork" - (pDecimal 1.0) - , PactTxTest tryReadString $ - assertTxFailure - "read-* errors are not recoverable before the fork" - "" - , PactTxTest tryReadInteger $ - assertTxFailure - "read-* errors are not recoverable before the fork" - "" - , PactTxTest tryReadKeyset $ - assertTxFailure - "read-* errors are not recoverable before the fork" - "" - , PactTxTest tryReadMsg $ - assertTxFailure - "read-* errors are not recoverable before the fork" - "" - ] - - -- Block 71, post-fork, errors should return on-chain but different - runBlockTest - [ PactTxTest addErrTx $ - assertTxFailureWith - "Should error with the argument types in +" - (isPrefixOf "Invalid arguments in call to +, received arguments of type" . show) - , PactTxTest mapErrTx $ - assertTxFailure - "Should fail on map with the second argument not being a list" - "map: expecting list, received argument of type: string" - , PactTxTest nativeDetailsTx $ - assertTxFailure - "Should print native details on chain" - "Cannot display native function details in non-repl context" - , PactTxTest fnDetailsTx $ - assertTxFailure - "Should not display function preview string" - "Cannot display function details in non-repl context" - , PactTxTest decTx $ - assertTxSuccess - "Should resolve new pact native: dec" - (pDecimal 1) - , PactTxTest runIllTypedFunction $ - assertTxSuccess - "User function return value types should not be checked after the fork" - (pDecimal 1.0) - , PactTxTest tryReadString $ - assertTxSuccess - "read-* errors are recoverable after the fork" - (pDecimal 1.0) - , PactTxTest tryReadInteger $ - assertTxSuccess - "read-* errors are recoverable after the fork" - (pDecimal 1.0) - , PactTxTest tryReadKeyset $ - assertTxSuccess - "read-* errors are recoverable after the fork" - (pDecimal 1.0) - , PactTxTest tryReadMsg $ - assertTxSuccess - "read-* errors are recoverable after the fork" - (pDecimal 1.0) - ] - - -- run local on RTC check - lr <- runLocal "0" cid $ set cbGasLimit 70_000 $ set cbRPC runIllTypedFunctionExec $ defaultCmd - assertLocalSuccess - "User function return value types should not be checked in local" - (pDecimal 1.0) - lr - - where - addErrTx = buildBasicGas 10_000 - $ mkExec' (mconcat - [ "(+ 1 \"a\")" - ]) - mapErrTx = buildBasicGas 10_000 - $ mkExec' (mconcat - [ "(map (+ 1) \"a\")" - ]) - decTx = buildBasicGas 10_000 - $ mkExec' "(dec 1)" - nativeDetailsMsg = "native `=` Compare alike terms for equality" - nativeDetailsTx = buildBasicGas 10_000 - $ mkExec' (mconcat - [ "=" - ]) - fnDetailsMsg = "(defun coin.transfer:string" - fnDetailsTx = buildBasicGas 10_000 - $ mkExec' (mconcat - [ "coin.transfer" - ]) - runIllTypedFunction = buildBasicGas 70_000 runIllTypedFunctionExec - runIllTypedFunctionExec = mkExec' (mconcat - [ "(namespace 'free)" - , "(module m g (defcap g () true)" - , " (defun foo:string () 1))" - , "(m.foo)" - ]) - tryReadInteger = buildBasicGas 1000 - $ mkExec' "(try 1 (read-integer \"somekey\"))" - tryReadString = buildBasicGas 1000 - $ mkExec' "(try 1 (read-string \"somekey\"))" - tryReadKeyset = buildBasicGas 1000 - $ mkExec' "(try 1 (read-keyset \"somekey\"))" - tryReadMsg = buildBasicGas 1000 - $ mkExec' "(try 1 (read-msg \"somekey\"))" - -pact48UpgradeTest :: PactTestM () -pact48UpgradeTest = do - runToHeight 83 - - -- run block 84 (before the pact48 fork) - runBlockTest - [ PactTxTest runConcat $ assertTxGas "Old concat gas cost" 222 - , PactTxTest runFormat $ assertTxGas "Old format gas cost" 229 - , PactTxTest runReverse $ assertTxGas "Old reverse gas cost" 4223 - ] - - -- run block 85 (after the pact 48 fork) - runBlockTest - [ PactTxTest runConcat $ assertTxGas "New concat gas cost" 271 - , PactTxTest runFormat $ assertTxGas "New format gas cost" 224 - , PactTxTest runReverse $ assertTxGas "New reverse gas cost" 4263 - ] - - where - runConcat = buildBasicGas 10000 $ mkExec' "(concat [\"hello\", \"world\"])" - runFormat = buildBasicGas 10000 $ mkExec' "(format \"{}\" [1,2,3])" - runReverse = buildBasicGas 10000 $ mkExec' "(reverse (enumerate 1 4000))" - -pact49UpgradeTest :: PactTestM () -pact49UpgradeTest = do - runToHeight 97 - - -- Run block 98. - -- WebAuthn is not yet a valid PPK scheme, so this transaction - -- is not valid for insertion into the mempool. - expectInvalid - "WebAuthn should not yet be supported" - [ webAuthnSignedTransaction - ] - - -- run block 99 (before the pact-4.9 fork) - runBlockTest - [ PactTxTest base64DecodeNonCanonical $ - assertTxSuccess - "Non-canonical messages decode before pact-4.9" - (pString "d") - , PactTxTest base64DecodeBadPadding $ assertTxFailure "decoding illegally padded string" "Could not decode string: Base64URL decode failed: invalid padding near offset 16" - ] - - -- run block 100 (after the pact-4.9 fork) - runBlockTest - [ PactTxTest base64DecodeNonCanonical $ - assertTxFailure "decoding non-canonical message" "Could not decode string: Could not base64-decode string" - , PactTxTest base64DecodeBadPadding $ assertTxFailure "decoding illegally padded string" "Could not decode string: Could not base64-decode string" - - , PactTxTest webAuthnSignedTransaction $ - assertTxSuccess - "WebAuthn signatures should be valid now" - (pDecimal 3) - - ] - - where - webAuthnSignedTransaction = buildBasicGasWebAuthnBareSigner 1000 $ mkExec' "(+ 1 2)" - base64DecodeNonCanonical = buildBasicGas 10000 $ mkExec' "(base64-decode \"ZE==\")" - base64DecodeBadPadding = buildBasicGas 10000 $ mkExec' "(base64-decode \"aGVsbG8gd29ybGQh%\")" - -pact410UpgradeTest :: PactTestM () -pact410UpgradeTest = do - runToHeight 110 - - expectInvalid - "WebAuthn prefixed keys should not yet be supported in signatures" - [ prefixedSigned - ] - runBlockTest [ - PactTxTest poseidonTx $ - assertTxFailure "Should not resolve new pact native: poseidon-hash-hack-a-chain" - "Cannot resolve poseidon-hash-hack-a-chain" - ] - - runToHeight 120 - runBlockTest - [ PactTxTest prefixedSigned $ - assertTxSuccess - "Prefixed WebAuthn signers should be legal" - (pDecimal 1) - - , PactTxTest prefixedSignerPrefixedKey $ - assertTxSuccess - "WebAuthn prefixed keys should be enforceable with prefixed signers" - (pBool True) - - , PactTxTest bareSignerPrefixedKey $ - assertTxFailure' - "WebAuthn prefixed keys should not be enforceable with bare signers" - "Keyset failure (keys-all): [WEBAUTHN...]" - - , PactTxTest definePrefixedKeySet $ - assertTxSuccess - "WebAuthn prefixed keys should be enforceable after defining them" - (pBool True) - - , PactTxTest prefixedSignerPrefixedKeyCreatePrincipal $ - assertTxSuccess - "WebAuthn prefixed keys in a keyset should be possible to make into w: principals" - (pString "w:XrscJ2X8aFxFF7oilzFyjQuA1mUN8jgwdxbAd8rt21M:keys-all") - - , PactTxTest prefixedSignerPrefixedKeyValidatePrincipal $ - assertTxSuccess - "WebAuthn prefixed keys in a keyset should be possible to make into *valid* w: principals" - (pBool True) - - , PactTxTest prefixedSignerBareKey $ - assertTxFailure' - "WebAuthn bare keys should throw an error when read" - "Invalid keyset" - - , PactTxTest invalidPrefixedKey $ - assertTxFailure' - "Invalid WebAuthn prefixed keys should throw an error when read" - "Invalid keyset" - - , PactTxTest poseidonTx $ - assertTxSuccess "Should resolve new pact native: poseidon-hash-hack-a-chain" - (pDecimal 18586133768512220936620570745912940619677854269274689475585506675881198879027) - ] - - where - poseidonTx = buildBasic $ mkExec' "(poseidon-hash-hack-a-chain 1)" - prefixedSigned = buildBasicGasWebAuthnPrefixedSigner 1000 $ mkExec' "1" - - prefixedSignerBareKey = buildBasicGasWebAuthnPrefixedSigner 1000 $ mkExec - "(enforce-keyset (read-keyset 'k))" - (mkKeyEnvData "a4010103272006215820c18831c6f15306d6271e154842906b68f26c1af79b132dde6f6add79710303bf") - - bareSignerPrefixedKey = buildBasicGasWebAuthnBareSigner 1000 $ mkExec - "(enforce-keyset (read-keyset 'k))" - (mkKeyEnvData "WEBAUTHN-a4010103272006215820c18831c6f15306d6271e154842906b68f26c1af79b132dde6f6add79710303bf") - - prefixedSignerPrefixedKey = buildBasicGasWebAuthnPrefixedSigner 1000 $ mkExec - "(enforce-keyset (read-keyset 'k))" - (mkKeyEnvData "WEBAUTHN-a4010103272006215820c18831c6f15306d6271e154842906b68f26c1af79b132dde6f6add79710303bf") - - definePrefixedKeySet = buildBasicGasWebAuthnPrefixedSigner 1000 $ mkExec - "(namespace 'free) (define-keyset \"free.edmund\" (read-keyset 'k)) (enforce-keyset \"free.edmund\")" - (mkKeyEnvData "WEBAUTHN-a4010103272006215820c18831c6f15306d6271e154842906b68f26c1af79b132dde6f6add79710303bf") - - prefixedSignerPrefixedKeyCreatePrincipal = buildBasicGasWebAuthnPrefixedSigner 1000 $ mkExec - "(create-principal (read-keyset 'k))" - (mkKeyEnvData "WEBAUTHN-a4010103272006215820c18831c6f15306d6271e154842906b68f26c1af79b132dde6f6add79710303bf") - - prefixedSignerPrefixedKeyValidatePrincipal = buildBasicGasWebAuthnPrefixedSigner 1000 $ mkExec - "(let ((ks (read-keyset 'k))) (validate-principal ks (create-principal ks)))" - (mkKeyEnvData "WEBAUTHN-a4010103272006215820c18831c6f15306d6271e154842906b68f26c1af79b132dde6f6add79710303bf") - - -- This hardcoded public key is the same as the valid one above, except that the first - -- character is changed. CBOR parsing will fail. - invalidPrefixedKey = buildBasicGas 1000 $ mkExec - "(read-keyset 'k)" - (mkKeyEnvData "WEBAUTHN-a401010327200add79710303bf") - - mkKeyEnvData :: String -> Value - mkKeyEnvData key = object [ "k" .= [key] ] - -chainweb223Test :: PactTestM () -chainweb223Test = do - - -- run past genesis, upgrades - runToHeight 120 - - let sender00KAccount = "k:" <> fst sender00 - -- run pre-fork, where rotating principals is allowed - -- runBlockTest - -- [ PactTxTest - -- (buildBasic' - -- (set cbGasLimit 10000 . - -- set cbSigners [mkEd25519Signer' sender00 [mkGasCap, mkCoinCap "ROTATE" [pString sender00KAccount]]] - -- ) $ mkExec - -- (T.unlines - -- [ "(coin.create-account (read-msg 'sender00KAcct) (read-keyset 'sender00))" - -- ,"(coin.rotate (read-msg 'sender00KAcct) (read-keyset 'sender01))" - -- ]) - -- (object ["sender00" .= [fst sender00], "sender00KAcct" .= sender00KAccount, "sender01" .= [fst sender01]])) - -- (assertTxSuccess "should allow rotating principals before fork" (pString "Write succeeded")) - -- ] - - -- run post-fork, where rotating principals is only allowed to get back to - -- their original guards - runBlockTest - [ - -- PactTxTest - -- (buildBasic' - -- (set cbGasLimit 10000 . - -- set cbSigners [mkEd25519Signer' sender00 [mkGasCap], mkEd25519Signer' sender01 [mkCoinCap "ROTATE" [pString sender00KAccount]]] - -- ) $ mkExec - -- "(coin.rotate (read-msg 'sender00KAcct) (read-keyset 'sender00))" - -- (object ["sender00" .= [fst sender00], "sender00KAcct" .= sender00KAccount, "sender01" .= [fst sender01]])) - -- (assertTxSuccess "should allow rotating principals back after fork" (pString "Write succeeded")) - PactTxTest - (buildBasic' - (set cbGasLimit 10000 . - set cbSigners [mkEd25519Signer' sender00 [mkGasCap, mkCoinCap "ROTATE" [pString sender00KAccount]]] - ) $ mkExec - "(coin.rotate (read-msg 'sender00KAcct) (read-keyset 'sender01))" - (object ["sender00" .= [fst sender00], "sender00KAcct" .= sender00KAccount, "sender01" .= [fst sender01]])) - (assertTxFailure "should not allow rotating principals after fork" "It is unsafe for principal accounts to rotate their guard") - ] - -compactAndSyncTest :: PactTestM () -compactAndSyncTest = do - -- start with all forks on. - let start = latestBehaviorAt testVersion - runToHeight start - -- we want to run a transaction but it doesn't matter what it does, as long - -- as it gets on-chain and thus affects the Pact state. - -- note that this is a decimal because we're parsing the CommandResult out of the payload, and - -- the json codec treats all numbers as decimals unless in a `{"int": }` object. - runBlockTest - [ PactTxTest (buildBasic $ mkExec' "1") (assertTxSuccess "should allow innocent transaction" (pDecimal 1)) - ] - -- save the cut with the tx, we'll return to it after compaction - cutWithTx <- currentCut - withCompacted start $ syncTo cutWithTx - -compactionCompactsUnmodifiedTables :: PactTestM () -compactionCompactsUnmodifiedTables = do - let start = latestBehaviorAt testVersion - runToHeight start - runBlockTest - -- create table - [ PactTxTest - (buildBasicGas 70_000 $ mkExec' $ mconcat - [ "(namespace 'free)" - , "(module dbmod G (defcap G () true)" - , " (defschema sch i:integer)" - , " (deftable tbl:{sch})" - , " (defun do-write () (insert tbl 'key {'i: 2})))" - , "(create-table tbl)" - ] - ) (assertTxSuccess "should create a table" (pString "TableCreated")) - ] - -- empty block, this regression requires an extra block before - -- any modifications - runBlockTest [] - - -- write to table - runBlockTest - [ PactTxTest - (buildBasic $ mkExec' "(free.dbmod.do-write)") - (assertTxSuccess "should write to that table" (pString "Write succeeded")) - ] - - -- grab current cut so that we can fast-forward to here after - -- compaction - afterWrite <- currentCut - - -- compact to the empty block, before we've written to the table but after - -- creating it - withCompacted (start + 2) $ do - -- fast forward to after we did the write, expecting the write to not fail - -- due to a duplicate row - syncTo afterWrite - -checkTransferCreate :: PactTestM () -checkTransferCreate = do - runToHeight 114 - runBlockTest - -- create table - [ PactTxTest - (buildBasic' (set cbSigners [mkEd25519Signer' sender00 coinCaps] . set cbGasLimit 70000) $ mkExec (mconcat - [ "(namespace 'free)" - -- , "(module dbmod G (defcap G () true)" - -- , " (defschema sch i:integer)" - -- , " (deftable tbl:{sch})" - -- , " (defun do-write () (insert tbl 'key {'i: 2})))" - , "(coin.transfer-create 'sender00 'sender01 (read-keyset 'test-keyset) 1.0)" - ]) (mkKeySetData "test-keyset" [sender01]) - ) (assertTxSuccess "should create a table" (pString "Write succeeded")) - ] - where - coinCaps = [ mkGasCap, mkTransferCap "sender00" "sender01" 1.0 ] - -quirkTest :: RocksDb -> TestTree -quirkTest rdb = do - let v = quirkedGasInstantCpmTestVersion petersen - let mempoolCmdBuilder = - buildBasic (mkExec' "(+ 1 2)") - withResourceT (mkTestBlockDb v rdb) $ \bdbIO -> - testCaseSteps "quirkTest" $ \step -> do - bdb <- bdbIO - mempools <- onAllChains v $ \_cid -> do - r <- newIORef mempty - return (r, delegateMemPoolAccess r) - let logger = hunitDummyLogger step - withWebPactExecutionService logger v testPactServiceConfig bdb (snd <$> mempools) $ \(pact,pacts) -> - flip runReaderT (MultiEnv bdb pact pacts pacts (fst <$> mempools) noMiner cid) $ do - -- run the command once without it being quirked, to establish - -- a baseline gas value - local (menvChainId .~ unsafeChainId 0) $ do - runBlockTest - [ PactTxTest mempoolCmdBuilder $ - assertTxGas "not-quirked gas" 219 - ] - runBlockTest - [ PactTxTest mempoolCmdBuilder $ - assertTxGas "quirked gas" 1 - ] - -pact4coin3UpgradeTest :: PactTestM () -pact4coin3UpgradeTest = do - - -- run past genesis, upgrades - runToHeight 6 - - -- run block 7 - runBlockTest - [ PactTxTest buildHashCmd $ \cr -> do - assertTxSuccess "Hash of coin @ block 7" - (pString "ut_J_ZNkoyaPUEJhiwVeWnkSQn9JT9sQCWKdjjVVrWo") - cr - assertTxEvents "Events for tx 0 @ block 7" [] cr - , PactTxTest (buildXSend []) $ - assertTxEvents "Events for tx 1 @ block 7" [] - , PactTxTest buildNewNatives40Cmd $ - assertTxFailure - "Should not resolve new pact natives" - "Cannot resolve distinct" - , PactTxTest badKeyset $ - assertTxSuccess - "Should allow bad keys" $ - pKeySet $ mkKeySet ["badkey"] "keys-all" - ] - - assertTxEvents "Coinbase events @ block 7" [] =<< cbResult - send0 <- txResult 1 - - -- run past v3 upgrade, pact 4 switch - resetMempool - runToHeight 18 - savedCut <- currentCut - runToHeight 21 - - -- block 22 - -- get proof - xproof <- buildXProof cid 7 1 send0 - cont <- buildCont send0 - - let v3Hash = "1os_sLAUYvBzspn5jjawtRpJWiH1WPfhyNraeVvSIwU" - block22 = - [ PactTxTest buildHashCmd $ \cr -> do - gasEv0 <- mkTransferEvent "sender00" "NoMiner" 0.0106 "coin" v3Hash - assertTxSuccess "Hash of coin @ block 22" (pString v3Hash) cr - assertTxEvents "Events for tx0 @ block 22" [gasEv0] cr - , PactTxTest buildReleaseCommand $ \cr -> do - gasEv1 <- mkTransferEvent "sender00" "NoMiner" 0.0425 "coin" v3Hash - allocTfr <- mkTransferEvent "" "allocation00" 1000000.0 "coin" v3Hash - allocEv <- mkEvent "RELEASE_ALLOCATION" [pString "allocation00",pDecimal 1000000.0] - "coin" v3Hash - assertTxEvents "Events for tx1 @ block 22" [gasEv1,allocEv,allocTfr] cr - , PactTxTest (buildXSend []) $ \cr -> do - gasEv2 <- mkTransferEvent "sender00" "NoMiner" 0.0369 "coin" v3Hash - sendTfr <- mkTransferEvent "sender00" "" 0.0123 "coin" v3Hash - yieldEv <- mkXYieldEvent "sender00" "sender00" 0.0123 sender00Ks "pact" v3Hash "0" "0" - assertTxEvents "Events for tx2 @ block 22" [gasEv2,sendTfr, yieldEv] cr - , PactTxTest buildNewNatives40Cmd $ - assertTxSuccess - "Should resolve enumerate pact native" - (pList $ pInteger <$> [1..10]) - , PactTxTest badKeyset $ - assertTxFailure - "Should not allow bad keys" - "Invalid keyset" - , PactTxTest cont $ - assertTxFailure' - "Attempt to continue xchain on same chain fails" - "yield provenance" - ] - block22_0 = - [ PactTxTest (buildXReceive xproof) $ \cr -> do - -- test receive XChain events - gasEvRcv <- mkTransferEvent "sender00" "NoMiner" 0.0247 "coin" v3Hash - rcvTfr <- mkTransferEvent "" "sender00" 0.0123 "coin" v3Hash - assertTxEvents "Events for txRcv" [gasEvRcv,rcvTfr] cr - ] - - void $ setPactMempool cid $ PactMempool - [ testsToBlock block22 ] - void $ setPactMempool chain0 $ PactMempool - [ testsToBlock block22_0 ] - runCut' - withChain cid $ do - testCurrentBlock block22 - cbEv <- mkTransferEvent "" "NoMiner" 2.304523 "coin" v3Hash - assertTxEvents "Coinbase events @ block 22" [cbEv] =<< cbResult - withChain chain0 $ testCurrentBlock block22_0 - - -- rewind to savedCut (cut 18) - syncTo savedCut - runToHeight 22 - - where - - buildHashCmd = buildBasic - $ mkExec' "(at 'hash (describe-module 'coin))" - - badKeyset = buildBasic - $ mkExec "(read-keyset 'ks)" $ object ["ks" .= ["badkey"::T.Text]] - - buildNewNatives40Cmd = buildBasic - $ mkExec' (mconcat expressions) - where - expressions = - [ - "(distinct [1 1 2 2 3 3])" - , "(concat [\"this\" \"is\" \"a\" \"test\"])" - , "(str-to-list \"test\")" - , "(enumerate 1 10)" - ] - - buildReleaseCommand = buildBasic' - (set cbSigners [ mkEd25519Signer' sender00 [] - , mkEd25519Signer' allocation00KeyPair []]) - $ mkExec' "(coin.release-allocation 'allocation00)" - - buildCont sendTx = do - pid <- getPactId sendTx - return $ buildBasic $ mkCont (mkContMsg pid 1) - - - --- ========================================================= --- --- Fixture --- --- ========================================================= - - --- | Sets mempool with block fillers. A matched filler --- (returning a 'Just' result) is executed and removed from the list. --- Fillers are tested in order. -setPactMempool :: ChainId -> PactMempool -> PactTestM (IORef (Set TransactionHash)) -setPactMempool = setPactMempool' Nothing - -setPactMempool' :: Maybe BlockHeader -> ChainId -> PactMempool -> PactTestM (IORef (Set TransactionHash)) -setPactMempool' fakeParentBh chain (PactMempool fs) = do - mpa <- view menvMpa - mpsRef <- liftIO $ newIORef fs - badTxs <- liftIO $ newIORef Set.empty - v <- view chainwebVersion - liftIO $ writeIORef (mpa ^?! atChain chain) $ mempty { - mpaGetBlock = \_ -> go v mpsRef, - mpaBadlistTx = \txs -> modifyIORef' badTxs (\hashes -> foldr Set.insert hashes txs) - } - pure badTxs - where - go v ref mempoolPreBlockCheck bHeight bHash bCreationTime = do - mps <- readIORef ref - let runMps i = \case - [] -> return mempty - (mp:r) -> case _mempoolBlock mp chain bCreationTime of - Just bs -> do - writeIORef ref (take i mps ++ r) - let parentBct = fromMaybe bCreationTime (view blockCreationTime <$> fakeParentBh) - cmds <- fmap V.fromList $ forM bs $ \b -> - buildCwCmd (sshow bHash) v $ _mempoolCmdBuilder b chain parentBct - validationResults <- mempoolPreBlockCheck bHeight bHash $ - (fmap . fmap . fmap) _pcCode cmds - return $ V.fromList [ tOut | Right tOut <- V.toList validationResults ] - Nothing -> runMps (succ i) r - runMps 0 mps - -runCut' :: PactTestM () -runCut' = do - pact <- view menvPact - bdb <- view menvBdb - miner <- view menvMiner - liftIO $ runCut testVersion bdb pact (offsetBlockTime second) zeroNoncer miner - -resetMempool :: PactTestM () -resetMempool = do - mems <- view menvMpa - forM_ mems $ \ref -> - liftIO $ writeIORef ref mempty - -currentCut :: PactTestM Cut -currentCut = view menvBdb >>= liftIO . readMVar . _bdbCut - -syncTo :: Cut -> PactTestM () -syncTo c = do - pact <- view menvPact - bdb <- view menvBdb - - forM_ (chainIds testVersion) $ \cid' -> do - let - ph = case HM.lookup cid' (_cutMap c) of - Just h -> h - Nothing -> error $ "syncTo: can't find block header for " ++ show cid' - - -- reset the parent header using SyncToBlock - void $ liftIO $ _webPactSyncToBlock pact ph - - void $ liftIO $ swapMVar (_bdbCut bdb) c - -assertTxEvents :: (HasCallStack, MonadIO m) => String -> [PactEvent] -> CommandResult Hash -> m () -assertTxEvents msg evs = liftIO . assertEqual msg evs . _crEvents - -assertTxGas :: (HasCallStack, MonadIO m) => String -> Gas -> CommandResult Hash -> m () -assertTxGas msg g = liftIO . assertEqual msg g . _crGas - -assertTxSuccess - :: HasCallStack - => MonadIO m - => String - -> PactValue - -> CommandResult Hash - -> m () -assertTxSuccess msg r tx = do - liftIO $ assertEqual msg (Just r) - (tx ^? crResult . to _pactResult . _Right) - -assertTxSuccessWith - :: (HasCallStack, MonadIO m) - => String - -> PactValue - -> (PactValue -> PactValue) - -> CommandResult Hash - -> m () -assertTxSuccessWith msg r f tx = do - liftIO $ assertEqual msg (Just r) - (tx ^? crResult . to _pactResult . _Right . to f) - --- | Exact match on error doc -assertTxFailure :: (HasCallStack, MonadIO m) => String -> Doc -> CommandResult Hash -> m () -assertTxFailure msg d tx = - liftIO $ assertEqual msg (Just d) - (tx ^? crResult . to _pactResult . _Left . to peDoc) - -assertTxFailureWith - :: (HasCallStack, MonadIO m) - => String - -> (Doc -> Bool) - -> CommandResult Hash -> m () -assertTxFailureWith msg f tx = do - let mresult = tx ^? crResult . to _pactResult . _Left . to peDoc - liftIO $ assertBool (msg <> ". Tx Result: " <> show mresult) $ maybe False f mresult - --- | Partial match on show of error doc -assertTxFailure' :: (HasCallStack, MonadIO m) => String -> T.Text -> CommandResult Hash -> m () -assertTxFailure' msg needle tx = - liftIO $ assertSatisfies msg - (tx ^? crResult . to _pactResult . _Left . to peDoc) $ \case - Nothing -> False - Just d -> T.isInfixOf needle (sshow d) - --- | Run a single mempool block on current chain with tests for each tx. --- Limitations: can only run a single-chain, single-refill test for --- a given cut height. -runBlockTest :: HasCallStack => [PactTxTest] -> PactTestM () -runBlockTest pts = do - chid <- view menvChainId - void $ setPactMempool chid $ PactMempool [testsToBlock pts] - runCut' - testCurrentBlock pts - --- | Convert tests to block for specified chain. -testsToBlock :: [PactTxTest] -> MempoolBlock -testsToBlock pts = MempoolBlock $ \_ _ -> - pure $ map _pttBuilder pts - --- | No tests in this list should even be submitted to the mempool, --- they should be rejected early. -expectInvalid :: String -> [MempoolCmdBuilder] -> PactTestM () -expectInvalid msg pts = do - chid <- view menvChainId - void $ setPactMempool chid $ PactMempool [MempoolBlock $ \_ _ -> Just pts] - _ <- runCut' - rs <- txResults - liftIO $ assertEqual msg mempty rs - --- | Run tests on current cut and chain. -testCurrentBlock :: HasCallStack => [PactTxTest] -> PactTestM () -testCurrentBlock pts = do - rs <- txResults - liftIO $ assertEqual "Result length should equal transaction length" (length pts) (length rs) - zipWithM_ go pts (V.toList rs) - where - go :: PactTxTest -> CommandResult Hash -> PactTestM () - go (PactTxTest _ t) cr = liftIO $ t cr - --- | Run cuts to block height. -runToHeight :: BlockHeight -> PactTestM () -runToHeight bhi = do - chid <- view menvChainId - bh <- getHeader chid - when (view blockHeight bh < bhi) $ do - runCut' - runToHeight bhi - -buildXSend :: [SigCapability] -> MempoolCmdBuilder -buildXSend caps = MempoolCmdBuilder $ \chain bct -> - set cbSigners [mkEd25519Signer' sender00 caps] - $ set cbChainId chain - $ set cbCreationTime (toTxCreationTime $ _bct bct) - $ set cbRPC - (mkExec - "(coin.transfer-crosschain 'sender00 'sender00 (read-keyset 'k) \"0\" 0.0123)" $ - mkKeySetData "k" [sender00]) - $ defaultCmd - -chain0 :: ChainId -chain0 = unsafeChainId 0 - -withChain :: ChainId -> PactTestM a -> PactTestM a -withChain c = local (set menvChainId c) - -buildXProof - :: ChainId - -> BlockHeight - -> Int - -> CommandResult l - -> PactTestM (ContProof, PactId) -buildXProof scid bh i sendTx = do - bdb <- view menvBdb - proof <- liftIO $ ContProof . B64U.encode . encodeToByteString <$> - createTransactionOutputProof_ (_bdbWebBlockHeaderDb bdb) (_bdbPayloadDb bdb) chain0 scid bh i - pid <- getPactId sendTx - return (proof,pid) - -getPactId :: CommandResult l -> PactTestM PactId -getPactId = fromMaybeM (userError "no continuation") . - preview (crContinuation . _Just . pePactId) - -buildXReceive - :: (ContProof, PactId) - -> MempoolCmdBuilder -buildXReceive (proof,pid) = buildBasic $ - mkCont ((mkContMsg pid 1) { _cmProof = Just proof }) - -signWebAuthn00Prefixed :: CmdBuilder -> CmdBuilder -signWebAuthn00Prefixed = - set cbSigners [mkWebAuthnSigner' sender02WebAuthnPrefixed [] - ,mkEd25519Signer' sender00 [] - ] - -signWebAuthn00 :: CmdBuilder -> CmdBuilder -signWebAuthn00 = - set cbSigners [mkWebAuthnSigner' sender02WebAuthn [] - ,mkEd25519Signer' sender00 [] - ] - -signSender00 :: CmdBuilder -> CmdBuilder -signSender00 = set cbSigners [mkEd25519Signer' sender00 []] - -buildBasic - :: PactRPC T.Text - -> MempoolCmdBuilder -buildBasic = buildBasic' id - -buildBasicGas :: GasLimit -> PactRPC T.Text -> MempoolCmdBuilder -buildBasicGas g = buildBasic' (set cbGasLimit g) - --- | Build with specified setter to mutate defaults. -buildBasic' - :: (CmdBuilder -> CmdBuilder) - -> PactRPC T.Text - -> MempoolCmdBuilder -buildBasic' f r = MempoolCmdBuilder $ \chain bct -> - f $ signSender00 - $ set cbChainId chain - $ set cbCreationTime (toTxCreationTime $ _bct bct) - $ set cbRPC r - $ defaultCmd - -buildBasicWebAuthnBareSigner' - :: (CmdBuilder -> CmdBuilder) - -> PactRPC T.Text - -> MempoolCmdBuilder -buildBasicWebAuthnBareSigner' f r = MempoolCmdBuilder $ \chain bct -> - f $ signWebAuthn00 - $ set cbChainId chain - $ set cbCreationTime (toTxCreationTime $ _bct bct) - $ set cbRPC r - $ defaultCmd - -buildBasicWebAuthnPrefixedSigner' - :: (CmdBuilder -> CmdBuilder) - -> PactRPC T.Text - -> MempoolCmdBuilder -buildBasicWebAuthnPrefixedSigner' f r = MempoolCmdBuilder $ \chain bct -> - f $ signWebAuthn00Prefixed - $ set cbChainId chain - $ set cbCreationTime (toTxCreationTime $ _bct bct) - $ set cbRPC r - $ defaultCmd - -buildBasicGasWebAuthnPrefixedSigner :: GasLimit -> PactRPC T.Text -> MempoolCmdBuilder -buildBasicGasWebAuthnPrefixedSigner g = buildBasicWebAuthnPrefixedSigner' (set cbGasLimit g) - -buildBasicGasWebAuthnBareSigner :: GasLimit -> PactRPC T.Text -> MempoolCmdBuilder -buildBasicGasWebAuthnBareSigner g = buildBasicWebAuthnBareSigner' (set cbGasLimit g) - --- | Get output on latest cut for chain -getPWO :: ChainId -> PactTestM (PayloadWithOutputs,BlockHeader) -getPWO chid = do - (TestBlockDb _ pdb _) <- view menvBdb - h <- getHeader chid - Just pwo <- liftIO $ lookupPayloadWithHeight pdb (Just $ view blockHeight h) (view blockPayloadHash h) - return (pwo,h) - -getHeader :: ChainId -> PactTestM BlockHeader -getHeader chid = do - (TestBlockDb _ _ cmv) <- view menvBdb - c <- liftIO $ readMVar cmv - fromMaybeM (userError $ "chain lookup failed for " ++ show chid) $ HM.lookup chid (_cutMap c) - --- | Get tx at index from output -txResult :: HasCallStack => Int -> PactTestM (CommandResult Hash) -txResult i = txResults >>= \rs -> case preview (ix i) rs of - Nothing -> - liftIO $ assertFailure $ "no tx at " ++ show i - Just r -> return r - -txResults :: HasCallStack => PactTestM (V.Vector (CommandResult Hash)) -txResults = do - chid <- view menvChainId - (o,_h) <- getPWO chid - forM (_payloadWithOutputsTransactions o) $ \(_,txo) -> - decodeStrictOrThrow @_ @(CommandResult Hash) (_transactionOutputBytes txo) - --- | Get coinbase from output -cbResult :: PactTestM (CommandResult Hash) -cbResult = do - chid <- view menvChainId - (o,_h) <- getPWO chid - liftIO $ - decodeStrictOrThrow @_ @(CommandResult Hash) (_coinbaseOutput $ _payloadWithOutputsCoinbase o) - --- Compact and return a new MultiEnv -withCompacted :: BlockHeight -> PactTestM x -> PactTestM x -withCompacted height pt = do - srcDbs <- fmap (M.fromList . HM.toList) $ view menvPacts - targetDbs <- fmap (M.fromList . HM.toList) $ view menvCompactedPacts - let dbs :: M.Map ChainId (SQLiteEnv, SQLiteEnv) - dbs = M.intersectionWith (\e1 e2 -> (fst e1, fst e2)) srcDbs targetDbs - forM_ (M.toList dbs) $ \(_, (srcDb, targetDb)) -> do - liftIO $ sigmaCompact srcDb targetDb height - - targetPacts <- view menvCompactedPacts - local (\me -> me & menvPacts .~ targetPacts) pt diff --git a/test/unit/Chainweb/Test/Pact4/PactReplay.hs b/test/unit/Chainweb/Test/Pact4/PactReplay.hs deleted file mode 100644 index 0c5ffaa0a5..0000000000 --- a/test/unit/Chainweb/Test/Pact4/PactReplay.hs +++ /dev/null @@ -1,364 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE MultiWayIf #-} -{-# LANGUAGE NumericUnderscores #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} - -module Chainweb.Test.Pact4.PactReplay where - -import Control.Monad (forM_, unless, void) -import Control.Monad.Catch -import Control.Monad.Reader -import Control.Monad.State -import Control.Lens - -import Data.IORef -import qualified Data.Text as T -import qualified Data.Vector as V -import Data.Word - -import System.Timeout - -import Test.Tasty -import Test.Tasty.HUnit - --- chainweb imports - -import Chainweb.BlockCreationTime -import Chainweb.BlockHeader -import Chainweb.BlockHeaderDB.Internal (unsafeInsertBlockHeaderDb) -import Chainweb.Graph -import Chainweb.Test.Cut.TestBlockDb -import Chainweb.Test.Utils -import Chainweb.Miner.Pact - -import Chainweb.Pact.Service.BlockValidation -import Chainweb.Pact.Service.PactQueue -import Chainweb.Pact.Types -import Chainweb.Payload -import Chainweb.Payload.PayloadStore -import Chainweb.Test.Pact4.Utils -import Chainweb.Test.TestVersions -import Chainweb.Time -import Chainweb.TreeDB -import Chainweb.Utils hiding (len) -import Chainweb.Version -import Chainweb.Version.Utils - -import Chainweb.BlockHeaderDB.Internal (_chainDbCas, RankedBlockHeader(..)) - -import Chainweb.Storage.Table -import Chainweb.Storage.Table.RocksDB - -import Pact.Types.Exp(ParsedCode(..)) -import Data.Either -import Chainweb.Pact.Backend.Types - -testVer :: ChainwebVersion -testVer = instantCpmTestVersion petersenChainGraph - -cid :: ChainId -cid = someChainId testVer - -tests :: RocksDb -> TestTree -tests rdb = - withDelegateMempool $ \dmp -> - let mp = snd <$> dmp - mpio = fst <$> dmp - in - independentSequentialTestGroup label - [ withPactTestBlockDb testVer cid rdb mp (forkLimit $ RewindLimit 100_000) - (testCase "initial-playthrough" . firstPlayThrough mpio genblock) - , withPactTestBlockDb testVer cid rdb mp (forkLimit $ RewindLimit 100_000) - (testCase "service-init-after-fork" . serviceInitializationAfterFork mpio genblock) - , withPactTestBlockDb testVer cid rdb mp (forkLimit $ RewindLimit 100_000) - (testCaseSteps "on-restart" . onRestart mpio) - , withPactTestBlockDb testVer cid rdb mp (forkLimit $ RewindLimit 100_000) - (testCase "reject-dupes" . testDupes mpio genblock) - , let deepForkLimit = RewindLimit 4 - in withPactTestBlockDb testVer cid rdb mp (forkLimit deepForkLimit) - (testCaseSteps "deep-fork-limit" . testDeepForkLimit mpio deepForkLimit) - ] - where - genblock = genesisBlockHeader testVer cid - label = "Chainweb.Test.Pact4.PactReplay" - - forkLimit fl = testPactServiceConfig { _pactReorgLimit = fl } - - -onRestart - :: IO (IORef MemPoolAccess) - -> IO (SQLiteEnv, PactQueue, TestBlockDb) - -> (String -> IO ()) - -> Assertion -onRestart mpio iop step = do - setOneShotMempool mpio testMemPoolAccess - (_, _, bdb) <- iop - bhdb' <- getBlockHeaderDb cid bdb - block <- maxEntry bhdb' - step $ "max block has height " <> sshow (view blockHeight block) - let nonce = Nonce $ fromIntegral $ view blockHeight block - step "mine block on top of max block" - T3 _ b _ <- mineBlock (ParentHeader block) nonce iop - assertEqual "Invalid BlockHeight" 1 (view blockHeight b) - -testMemPoolAccess :: MemPoolAccess -testMemPoolAccess = mempty - { mpaGetBlock = \_g validate bh hash bct -> do - let (BlockCreationTime t) = bct - getTestBlock t validate bh hash - } - where - getTestBlock _ _ 1 _ = mempty - getTestBlock txOrigTime validate bHeight hash = do - let nonce = T.pack . show @(Time Micros) $ txOrigTime - tx <- buildCwCmd nonce testVer $ - set cbSigners [mkEd25519Signer' sender00 []] $ - set cbCreationTime (toTxCreationTime txOrigTime) $ - set cbRPC (mkExec' "1") $ - defaultCmd - let outtxs = V.singleton tx - oks <- validate bHeight hash $ (fmap . fmap . fmap) _pcCode outtxs - unless (V.all isRight oks) $ fail $ mconcat - [ "testMemPoolAccess: tx failed validation! input list: \n" - , show tx - , "\n\nouttxs: " - , show outtxs - , "\n\noks: " - , show [ fmap (bimap (sshow @_ @String) (const ())) oks ] - ] - return $ V.fromList [ t | Right t <- V.toList oks ] - -dupegenMemPoolAccess :: IO MemPoolAccess -dupegenMemPoolAccess = do - hs <- newIORef [] - return $ mempty - { mpaGetBlock = \_g validate bHeight bHash _parentHeader -> do - hs' <- readIORef hs - if bHeight `elem` hs' then return mempty else do - writeIORef hs (bHeight:hs') - outtxs <- fmap V.singleton $ - buildCwCmd "0" testVer $ - set cbSigners [mkEd25519Signer' sender00 []] $ - set cbRPC (mkExec' "1") $ - defaultCmd - oks <- validate bHeight bHash ((fmap . fmap . fmap) _pcCode outtxs) - unless (V.all isRight oks) $ fail $ mconcat - [ "dupegenMemPoolAccess: tx failed validation! input list: \n" - , show outtxs - , "\n\noks: " - , show [ fmap (bimap (sshow @_ @String) (const ())) oks ] - ] - return $ V.fromList $ [ t | Right t <- V.toList oks ] - } - --- | This is a regression test for correct initialization of the checkpointer --- during pact service initialization. --- --- Removing the call to 'initializeLatestBlock' in 'runPactService' causes --- this test to fail. --- -serviceInitializationAfterFork - :: IO (IORef MemPoolAccess) - -> BlockHeader - -> IO (SQLiteEnv, PactQueue, TestBlockDb) - -> Assertion -serviceInitializationAfterFork mpio genesisBlock iop = do - setOneShotMempool mpio testMemPoolAccess - nonceCounter <- newIORef (1 :: Word64) - mainlineblocks <- mineLine genesisBlock nonceCounter 10 - -- Delete latest block from block header db. This simulates the situation - -- when the latest block of the checkpointer gets orphaned during a restart - -- cycle. - pruneDbs - restartPact - let T3 _ line1 pwo1 = mainlineblocks !! 6 - (_, q, _) <- iop - -- reset the pact service state to line1 - void $ validateBlock line1 (CheckablePayloadWithOutputs pwo1) q - void $ mineLine line1 nonceCounter 4 - where - mineLine start ncounter len = - evalStateT (mapM (const go) [startHeight :: Word64 .. (startHeight + len)]) start - where - startHeight = fromIntegral $ view blockHeight start - go = do - pblock <- gets ParentHeader - n <- liftIO $ Nonce <$> readIORef ncounter - ret@(T3 _ newblock _) <- liftIO $ mineBlock pblock n iop - liftIO $ modifyIORef' ncounter succ - put newblock - return ret - - restartPact :: IO () - restartPact = do - (_, q, _) <- iop - submitRequestAndWait q CloseMsg - - pruneDbs = forM_ cids $ \c -> do - (_, _, dbs) <- iop - db <- getBlockHeaderDb c dbs - h <- maxEntry db - tableDelete (_chainDbCas db) (casKey $ RankedBlockHeader h) - - cids = chainIds testVer - -firstPlayThrough - :: IO (IORef MemPoolAccess) - -> BlockHeader - -> IO (SQLiteEnv, PactQueue, TestBlockDb) - -> Assertion -firstPlayThrough mpio genesisBlock iop = do - setOneShotMempool mpio testMemPoolAccess - nonceCounter <- newIORef (1 :: Word64) - mainlineblocks <- mineLine genesisBlock nonceCounter 7 - let T3 _ startline1 pwo1 = head mainlineblocks - let T3 _ startline2 pwo2 = mainlineblocks !! 1 - - (_, q, _) <- iop - - -- reset the pact service state to startline1 - void $ validateBlock startline1 (CheckablePayloadWithOutputs pwo1) q - - void $ mineLine startline1 nonceCounter 4 - - -- reset the pact service state to startline2 - void $ validateBlock startline2 (CheckablePayloadWithOutputs pwo2) q - - void $ mineLine startline2 nonceCounter 4 - where - mineLine start ncounter len = - evalStateT (mapM (const go) [startHeight :: Word64 .. (startHeight + len)]) start - where - startHeight = fromIntegral $ view blockHeight start - go = do - pblock <- gets ParentHeader - n <- liftIO $ Nonce <$> readIORef ncounter - ret@(T3 _ newblock _) <- liftIO $ mineBlock pblock n iop - liftIO $ modifyIORef' ncounter succ - put newblock - return ret - -testDupes - :: IO (IORef MemPoolAccess) - -> BlockHeader - -> IO (SQLiteEnv, PactQueue, TestBlockDb) - -> Assertion -testDupes mpio genesisBlock iop = do - setMempool mpio =<< dupegenMemPoolAccess - (T3 _ newblock payload) <- liftIO $ mineBlock (ParentHeader genesisBlock) (Nonce 1) iop - expectException newblock payload $ liftIO $ - mineBlock (ParentHeader newblock) (Nonce 3) iop - where - expectException newblock payload act = do - m <- wrap `catchAllSynchronous` h - maybe (return ()) (\msg -> assertBool msg False) m - where - wrap = do - (T3 _ newblock2 payload2) <- act - let msg = concat [ "expected exception on dupe block. new block header:\n" - , sshow newblock2 - , "\nnew payload: \n" - , sshow payload2 - , "\nprev block: \n" - , sshow newblock - , "\nprev payload: \n" - , sshow payload - ] - return $ Just msg - - h :: SomeException -> IO (Maybe String) - h _ = return Nothing - -testDeepForkLimit - :: IO (IORef MemPoolAccess) - -> RewindLimit - -> IO (SQLiteEnv, PactQueue,TestBlockDb) - -> (String -> IO ()) - -> Assertion -testDeepForkLimit mpio (RewindLimit deepForkLimit) iop step = do - setOneShotMempool mpio testMemPoolAccess - (_, q, bdb) <- iop - bhdb <- getBlockHeaderDb cid bdb - let pdb = _bdbPayloadDb bdb - step "query max db entry" - maxblock <- maxEntry bhdb - pd <- lookupPayloadWithHeight pdb (Just $ view blockHeight maxblock) (view blockPayloadHash maxblock) >>= \case - Nothing -> assertFailure "max block payload not found" - Just x -> return x - step $ "max block has height " <> sshow (view blockHeight maxblock) - nonceCounterMain <- newIORef (fromIntegral $ view blockHeight maxblock) - - -- mine the main line a bit more - step "mine (deepForkLimit + 1) many blocks on top of max block" - void $ mineLine maxblock nonceCounterMain (deepForkLimit + 1) - - step "try to rewind to max block" - try @_ @SomeException (validateBlock maxblock (CheckablePayloadWithOutputs pd) q) >>= \case - Left _ -> return () - _ -> assertBool msg False - - where - msg = "expected exception on a deep fork longer than " <> show deepForkLimit - - mineLine start ncounter len = - evalStateT (mapM (const go) [startHeight :: Word64 .. (startHeight + len)]) start - where - startHeight = fromIntegral $ view blockHeight start - go = do - pblock <- gets ParentHeader - n <- liftIO $ Nonce <$> readIORef ncounter - liftIO $ step $ "mine block on top of height " <> sshow (view blockHeight $ _parentHeader pblock) - ret@(T3 _ newblock _) <- liftIO $ mineBlock pblock n iop - liftIO $ modifyIORef' ncounter succ - put newblock - return ret - - -mineBlock - :: ParentHeader - -> Nonce - -> IO (SQLiteEnv, PactQueue, TestBlockDb) - -> IO (T3 ParentHeader BlockHeader PayloadWithOutputs) -mineBlock ph nonce iop = timeout 5000000 go >>= \case - Nothing -> error "PactReplay.mineBlock: Test timeout. Most likely a test case caused a pact service failure that wasn't caught, and the test was blocked while waiting for the result" - Just x -> return x - where - go = do - - -- assemble block without nonce and timestamp - (_, q, bdb) <- iop - bip <- throwIfNoHistory =<< newBlock noMiner NewBlockFill ph q - let payload = forAnyPactVersion finalizeBlock bip - - let - creationTime = BlockCreationTime - . add (TimeSpan 1_000_000) - . _bct . view blockCreationTime - $ _parentHeader ph - - let bh = newBlockHeader - (_versionForkNumber $ _chainwebVersion ph) - mempty - (_payloadWithOutputsPayloadHash payload) - nonce - creationTime - ph - - _ <- validateBlock bh (CheckablePayloadWithOutputs payload) q - - let pdb = _bdbPayloadDb bdb - addNewPayload pdb (succ $ view blockHeight $ _parentHeader ph) payload - - bhdb <- getBlockHeaderDb cid bdb - unsafeInsertBlockHeaderDb bhdb bh - - return $ T3 ph bh payload - -assertNotLeft :: (MonadThrow m, Exception e) => Either e a -> m a -assertNotLeft (Left l) = throwM l -assertNotLeft (Right r) = return r diff --git a/test/unit/Chainweb/Test/Pact4/PactSingleChainTest.hs b/test/unit/Chainweb/Test/Pact4/PactSingleChainTest.hs deleted file mode 100644 index 8b6ade4b43..0000000000 --- a/test/unit/Chainweb/Test/Pact4/PactSingleChainTest.hs +++ /dev/null @@ -1,1472 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DerivingVia #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE ImportQualifiedPost #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE NumericUnderscores #-} -{-# LANGUAGE OverloadedRecordDot #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE ViewPatterns #-} - -module Chainweb.Test.Pact4.PactSingleChainTest -( tests -) where - -import Control.Arrow ((&&&)) -import Control.Concurrent.Async(withAsync) -import Control.Concurrent.MVar -import Control.DeepSeq -import Control.Lens hiding ((.=), matching) -import Control.Monad -import Control.Monad.Catch -import Patience.Map qualified as PatienceM -import Patience.Map (Delta(..)) - -import Data.Aeson (object, (.=), Value(..)) -import qualified Data.ByteString.Lazy as BL -import Data.Either -import Data.Foldable -import qualified Data.HashMap.Strict as HM -import Data.Int -import Data.IORef -import qualified Data.List as List -import qualified Data.Map.Strict as M -import Data.Maybe (isJust, isNothing) -import Data.Ord -import qualified Data.Text as T -import Data.Text (Text) -import qualified Data.Text.Encoding as T -import qualified Data.Text.IO as T -import qualified Data.Vector as V -import qualified Database.SQLite3 as Lite -import qualified Streaming.Prelude as S - -import GHC.Stack - -import Test.Tasty -import Test.Tasty.HUnit - --- internal modules - -import Pact.Types.Command -import Pact.Types.Hash -import Pact.Types.Info -import Pact.Types.Persistence -import Pact.Types.PactError -import qualified Pact.Types.SQLite as Pact - -import Pact.JSON.Encode qualified as J -import Pact.JSON.Yaml - -import qualified Pact.Core.Persistence as PCore - -import Chainweb.BlockCreationTime -import Chainweb.BlockHash (BlockHash) -import Chainweb.BlockHeader.Internal -import Chainweb.BlockHeight (BlockHeight(..)) -import Chainweb.Graph -import Chainweb.Logger (genericLogger) -import Chainweb.Mempool.Mempool -import Chainweb.MerkleLogHash (unsafeMerkleLogHash) -import Chainweb.Miner.Pact -import Chainweb.Pact.Backend.PactState.GrandHash.Algorithm (computeGrandHash) -import Chainweb.Pact.Backend.PactState qualified as PS -import Chainweb.Pact.Service.BlockValidation hiding (local) -import Chainweb.Pact.Service.PactQueue (PactQueue, newPactQueue) -import Chainweb.Pact.Types -import Chainweb.Pact.PactService (runPactService) -import Chainweb.Pact.Utils (emptyPayload) -import Chainweb.Payload -import Chainweb.Test.Cut.TestBlockDb -import Chainweb.Test.Pact4.Utils -import Chainweb.Test.Utils -import Chainweb.Test.TestVersions -import Chainweb.Time -import qualified Chainweb.Pact4.Transaction as Pact4 -import Chainweb.Utils -import Chainweb.Version -import Chainweb.Version.Utils -import Chainweb.WebBlockHeaderDB (getWebBlockHeaderDb) - -import Chainweb.Storage.Table.RocksDB - -import System.LogLevel (LogLevel(..)) -import qualified Pact.Core.Names as PCore -import qualified Data.ByteString.Short as SB -import Text.Show.Pretty (ppShow) -import qualified Pact.Core.StableEncoding as PCore -import Chainweb.Pact.Backend.Types - -testVersion :: ChainwebVersion -testVersion = slowForkingCpmTestVersion petersenChainGraph - -cid :: ChainId -cid = someChainId testVersion - -genesisHeader :: BlockHeader -genesisHeader = genesisBlockHeader testVersion cid - - -tests :: RocksDb -> TestTree -tests rdb = testGroup testName - [ test $ goldenNewBlock "new-block-0" goldenMemPool - , test $ goldenNewBlock "empty-block-tests" (return mempty) - , test newBlockAndValidate - , test newBlockNoFill - , test newBlockAndContinue - , test newBlockAndValidationFailure - -- this test needs to see all of the writes done in the block; - -- it uses the BlockTxHistory Pact request to see them. - , testWithConf getHistory - testPactServiceConfig { _pactPersistIntraBlockWrites = PersistIntraBlockWrites } - , test testHistLookup1 - , test testHistLookup2 - , test testHistLookup3 - , test badlistNewBlockTest - , test mempoolCreationTimeTest - , test moduleNameFork - , test mempoolRefillTest - , test blockGasLimitTest - , testTimeout preInsertCheckTimeoutTest - , rewindPastMinBlockHeightFails rdb - , pactStateSamePreAndPostCompaction rdb - , compactionIsIdempotent rdb - , compactionUserTablesDropped rdb - , compactionGrandHashUnchanged rdb - , compactionDoesNotDisruptDuplicateDetection rdb - , compactionResilientToRowIdOrdering rdb - ] - where - testName = "Chainweb.Test.Pact4.PactSingleChainTest" - test = test' rdb - testWithConf = testWithConf' rdb - testTimeout = testTimeout' rdb - - testHistLookup1 = getHistoricalLookupNoTxs "sender00" - (assertSender00Bal 100_000_000 "check latest entry for sender00 after a no txs block") - testHistLookup2 = getHistoricalLookupNoTxs "randomAccount" - (assertEqual "Return Nothing if key absent after a no txs block" Nothing) - testHistLookup3 = getHistoricalLookupWithTxs "sender00" - (assertSender00Bal 9.999998042e7 "check latest entry for sender00 after block with txs") - -testWithConf' :: () - => RocksDb - -> (IO (IORef MemPoolAccess) -> IO (SQLiteEnv, PactQueue, TestBlockDb) -> TestTree) - -> PactServiceConfig - -> TestTree -testWithConf' rdb f conf = - withDelegateMempool $ \dm -> - withPactTestBlockDb testVersion cid rdb (snd <$> dm) conf $ - f (fst <$> dm) - -test' :: () - => RocksDb - -> (IO (IORef MemPoolAccess) -> IO (SQLiteEnv, PactQueue, TestBlockDb) -> TestTree) - -> TestTree -test' rdb f = testWithConf' rdb f testPactServiceConfig - -testTimeout' :: () - => RocksDb - -> (IO (IORef MemPoolAccess) -> IO (SQLiteEnv, PactQueue, TestBlockDb) -> TestTree) - -> TestTree -testTimeout' rdb f = testWithConf' rdb f (testPactServiceConfig { _pactPreInsertCheckTimeout = 1 }) - -forSuccess :: (NFData a, HasCallStack) => String -> IO (Either PactException a) -> IO a -forSuccess msg act = (`catchAllSynchronous` handler) $ do - r <- act - case r of - Left e -> assertFailure $ msg ++ ": got failure result: " ++ show e - Right v -> return v - where - handler e = assertFailure $ msg ++ ": exception thrown: " ++ show e - -runBlockE :: (HasCallStack) => PactQueue -> TestBlockDb -> TimeSpan Micros -> IO (Either PactException PayloadWithOutputs) -runBlockE q bdb timeOffset = do - ph <- getParentTestBlockDb bdb cid - bip <- throwIfNoHistory =<< newBlock noMiner NewBlockFill (ParentHeader ph) q - let nb = forAnyPactVersion finalizeBlock bip - let blockTime = add timeOffset $ _bct $ view blockCreationTime ph - forM_ (chainIds testVersion) $ \c -> do - let o | c == cid = nb - | otherwise = emptyPayload - addTestBlockDb bdb (succ $ view blockHeight ph) (Nonce 0) (\_ _ -> blockTime) c o - nextH <- getParentTestBlockDb bdb cid - try (validateBlock nextH (CheckablePayloadWithOutputs nb) q) - --- edmundn: why does any of this return PayloadWithOutputs instead of a --- list of Pact CommandResult? -runBlock :: (HasCallStack) => PactQueue -> TestBlockDb -> TimeSpan Micros -> IO PayloadWithOutputs -runBlock q bdb timeOffset = do - forSuccess "newBlockAndValidate: validate" $ - runBlockE q bdb timeOffset - -newBlockAndValidate :: IO (IORef MemPoolAccess) -> IO (SQLiteEnv, PactQueue, TestBlockDb) -> TestTree -newBlockAndValidate refIO reqIO = testCase "newBlockAndValidate" $ do - (_, q, bdb) <- reqIO - setOneShotMempool refIO =<< goldenMemPool - void $ runBlock q bdb second - -newBlockAndContinue :: IO (IORef MemPoolAccess) -> IO (SQLiteEnv, PactQueue, TestBlockDb) -> TestTree -newBlockAndContinue refIO reqIO = testCase "newBlockAndContinue" $ do - (_, q, bdb) <- reqIO - let mk = signSender00 . set cbGasPrice 0.01 . set cbTTL 1_000_000 - c1 <- buildCwCmd "1" testVersion $ - mk $ - set cbRPC (mkExec "(+ 1 2)" (object [])) $ - defaultCmd - c2 <- buildCwCmd "2" testVersion $ - mk $ - set cbRPC (mkExec "(+ 3 4)" (object [])) $ - defaultCmd - c3 <- buildCwCmd "3" testVersion $ - mk $ - set cbRPC (mkExec "(+ 5 6)" (object [])) $ - defaultCmd - setMempool refIO =<< mempoolOf - [ V.fromList [ c1 ] - , mempty - , V.fromList [ c2 ] - , mempty - , V.fromList [ c3 ] - ] - - -- TODO: assert? - ForPact4 bipStart <- throwIfNoHistory =<< newBlock noMiner NewBlockFill (ParentHeader genesisHeader) q - let ParentHeader ph = fromJuste $ _blockInProgressParentHeader bipStart - bipContinued <- throwIfNoHistory =<< continueBlock bipStart q - bipFinal <- throwIfNoHistory =<< continueBlock bipContinued q - -- we must make progress on the same parent header - assertEqual "same parent header after continuing block" - (_blockInProgressParentHeader bipStart) (_blockInProgressParentHeader bipContinued) - assertBool "made progress (1)" - (bipStart /= bipContinued) - assertEqual "same parent header after finishing block" - (_blockInProgressParentHeader bipContinued) (_blockInProgressParentHeader bipFinal) - assertBool "made progress (2)" - (bipContinued /= bipFinal) - let nbContinued = finalizeBlock bipFinal - -- add block to database - let blockTime = add second $ _bct $ view blockCreationTime ph - forM_ (chainIds testVersion) $ \c -> do - let o | c == cid = nbContinued - | otherwise = emptyPayload - addTestBlockDb bdb (succ $ view blockHeight ph) (Nonce 0) (\_ _ -> blockTime) c o - nextH <- getParentTestBlockDb bdb cid - -- a continued block must be valid - _ <- validateBlock nextH (CheckablePayloadWithOutputs nbContinued) q - - -- reset to parent - pactSyncToBlock ph q - setMempool refIO =<< mempoolOf - [ V.fromList - [ c1, c2, c3 ] - ] - bipAllAtOnce <- throwIfNoHistory =<< newBlock noMiner NewBlockFill (ParentHeader genesisHeader) q - let nbAllAtOnce = forAnyPactVersion finalizeBlock bipAllAtOnce - assertEqual "a continued block, and one that's all done at once, should be exactly equal" - nbContinued nbAllAtOnce - _ <- validateBlock nextH (CheckablePayloadWithOutputs nbAllAtOnce) q - - return () - -newBlockNoFill :: IO (IORef MemPoolAccess) - -> IO (SQLiteEnv, PactQueue, TestBlockDb) -> TestTree -newBlockNoFill refIO reqIO = testCase "newBlockNoFill" $ do - (_, q, _) <- reqIO - c1 <- buildCwCmd "1" testVersion $ - signSender00 $ - set cbGasPrice 0.01 $ - set cbTTL 1_000_000 $ - set cbRPC (mkExec "1" (object [])) $ - defaultCmd - setMempool refIO =<< mempoolOf [V.fromList [c1]] - noFillPwo <- fmap (forAnyPactVersion finalizeBlock) . throwIfNoHistory =<< - newBlock noMiner NewBlockEmpty (ParentHeader genesisHeader) q - assertEqual - "an unfilled newblock must have no transactions, even with a full mempool" - mempty - (_payloadWithOutputsTransactions noFillPwo) - fillPwo <- fmap (forAnyPactVersion finalizeBlock) . throwIfNoHistory =<< - newBlock noMiner NewBlockFill (ParentHeader genesisHeader) q - assertEqual - "an filled newblock has transactions with a full mempool" - 1 - (V.length $ _payloadWithOutputsTransactions fillPwo) - -newBlockAndValidationFailure :: IO (IORef MemPoolAccess) -> IO (SQLiteEnv, PactQueue, TestBlockDb) -> TestTree -newBlockAndValidationFailure refIO reqIO = testCase "newBlockAndValidationFailure" $ do - (_, q, bdb) <- reqIO - setOneShotMempool refIO =<< goldenMemPool - - bip <- throwIfNoHistory =<< newBlock noMiner NewBlockFill (ParentHeader genesisHeader) q - let nb = forAnyPactVersion finalizeBlock bip - let blockTime = add second $ _bct $ view blockCreationTime genesisHeader - forM_ (chainIds testVersion) $ \c -> do - let o | c == cid = nb - | otherwise = emptyPayload - addTestBlockDb bdb (succ $ view blockHeight genesisHeader) (Nonce 0) (\_ _ -> blockTime) c o - - nextH <- getParentTestBlockDb bdb cid - - let nextH' = nextH & blockPayloadHash .~ BlockPayloadHash (unsafeMerkleLogHash "0000000000000000000000000000001d") - let nb' = nb { _payloadWithOutputsOutputsHash = BlockOutputsHash (unsafeMerkleLogHash "0000000000000000000000000000001d")} - try (validateBlock nextH' (CheckablePayloadWithOutputs nb') q) >>= \case - Left BlockValidationFailure {} -> do - let txHash = SB.toShort "WgnuCg6L_l6lzbjWtBfMEuPtty_uGcNrUol5HGREO_o" - lookupRes <- lookupPactTxs Nothing (V.fromList [txHash]) q - assertEqual "The transaction from the latest block is not at the tip point" mempty lookupRes - - _ -> assertFailure "newBlockAndValidationFailure: expected BlockValidationFailure" - -toRowData :: HasCallStack => Value -> PCore.RowData -toRowData v = case PCore.decodeStable $ BL.toStrict encV of - Nothing -> error $ - "toRowData: failed to encode as row data. \n" <> show encV - Just r -> r - where - encV = J.encode v - -rewindPastMinBlockHeightFails :: () - => RocksDb - -> TestTree -rewindPastMinBlockHeightFails rdb = - compactionSetup "rewindPastMinBlockHeightFails" rdb testPactServiceConfig $ \cr -> do - replicateM_ 10 $ runBlock cr.srcPactQueue cr.blockDb second - - sigmaCompact cr.srcSqlEnv cr.targetSqlEnv (BlockHeight 5) - - -- Genesis block header; compacted away by now - let bh = genesisBlockHeader testVersion cid - - syncResult <- try (pactSyncToBlock bh cr.targetPactQueue) - case syncResult of - Left (BlockHeaderLookupFailure {}) -> do - return () - Left err -> do - assertFailure $ "Expected a BlockHeaderLookupFailure, but got: " ++ show err - Right _ -> do - assertFailure "Expected an exception, but didn't encounter one." - -pactStateSamePreAndPostCompaction :: () - => RocksDb - -> TestTree -pactStateSamePreAndPostCompaction rdb = - compactionSetup "pactStateSamePreAndPostCompaction" rdb testPactServiceConfig $ \cr -> do - let numBlocks :: Num a => a - numBlocks = 100 - - let makeTx :: Word -> BlockCreationTime -> IO Pact4.Transaction - makeTx nth bct = buildCwCmd (sshow (nth, bct)) testVersion - $ set cbSigners [mkEd25519Signer' sender00 [mkGasCap, mkTransferCap "sender00" "sender01" 1.0]] - $ set cbChainId cid - $ set cbCreationTime (toTxCreationTime $ _bct bct) - $ set cbRPC (mkExec' "(coin.transfer \"sender00\" \"sender01\" 1.0)") - $ defaultCmd - - replicateM_ numBlocks $ do - runTxInBlock_ cr.mempoolRef cr.srcPactQueue cr.blockDb - $ \n _ _ bct -> makeTx n bct - - statePreCompaction <- getLatestPactState cr.srcSqlEnv - sigmaCompact cr.srcSqlEnv cr.targetSqlEnv (BlockHeight numBlocks) - statePostCompaction <- getLatestPactState cr.targetSqlEnv - - comparePactStateBeforeAndAfter statePreCompaction statePostCompaction - -compactionIsIdempotent :: () - => RocksDb - -> TestTree -compactionIsIdempotent rdb = - -- This requires a bit more than 'compactionSetup', since we - -- are compacting more than once. - withResourceT (withTempDir "pact-dir") $ \twiceDir -> withSqliteDb cid twiceDir $ \twiceSqlEnvIO -> - compactionSetup "compactionIsIdempotent" rdb testPactServiceConfig $ \cr -> do - let numBlocks :: Num a => a - numBlocks = 100 - - let makeTx :: Word -> BlockCreationTime -> IO Pact4.Transaction - makeTx nth bct = buildCwCmd (sshow (nth, bct)) testVersion - $ set cbSigners [mkEd25519Signer' sender00 [mkGasCap, mkTransferCap "sender00" "sender01" 1.0]] - $ set cbChainId cid - $ set cbCreationTime (toTxCreationTime $ _bct bct) - $ set cbRPC (mkExec' "(coin.transfer \"sender00\" \"sender01\" 1.0)") - $ defaultCmd - - replicateM_ numBlocks $ do - runTxInBlock_ cr.mempoolRef cr.srcPactQueue cr.blockDb - $ \n _ _ bct -> makeTx n bct - - twiceSqlEnv <- twiceSqlEnvIO - let targetHeight = BlockHeight numBlocks - -- Compact 'src' into 'target' - sigmaCompact cr.srcSqlEnv cr.targetSqlEnv targetHeight - -- Get table contents of 'target' - statePostCompaction1 <- getPactUserTables cr.targetSqlEnv - -- Compact 'target' into 'twice' - sigmaCompact cr.targetSqlEnv twiceSqlEnv targetHeight - -- Get table state of 'twice' - statePostCompaction2 <- getPactUserTables twiceSqlEnv - - -- In order to use `comparePactStateBeforeAndAfter`, we need to ensure that the rows are properly compacted, - -- and then put them into a map. - let ensureIsCompactedAndSortRows :: M.Map Text [PactRow] -> IO (M.Map Text (M.Map Text PS.PactRowContents)) - ensureIsCompactedAndSortRows state = do - flip M.traverseWithKey state $ \_ rows -> do - let sortedRows = List.sort rows - assertBool "Each rowkey only has one entry" $ - List.sort (List.nubBy (\r1 r2 -> r1.rowKey == r2.rowKey) rows) == sortedRows - pure $ M.fromList $ List.map (\r -> (T.decodeUtf8 r.rowKey, PS.PactRowContents r.rowData r.txId)) sortedRows - - state1 <- ensureIsCompactedAndSortRows statePostCompaction1 - state2 <- ensureIsCompactedAndSortRows statePostCompaction2 - - comparePactStateBeforeAndAfter state1 state2 - -compactionDoesNotDisruptDuplicateDetection :: () - => RocksDb - -> TestTree -compactionDoesNotDisruptDuplicateDetection rdb = do - compactionSetup "compactionDoesNotDisruptDuplicateDetection" rdb testPactServiceConfig $ \cr -> do - let makeTx :: IO Pact4.Transaction - makeTx = buildCwCmd (sshow @Word 0) testVersion - $ set cbSigners [mkEd25519Signer' sender00 [mkGasCap, mkTransferCap "sender00" "sender01" 1.0]] - $ set cbRPC (mkExec' "(coin.transfer \"sender00\" \"sender01\" 1.0)") - $ defaultCmd - - e1 <- runTxInBlock cr.mempoolRef cr.srcPactQueue cr.blockDb (\_ _ _ _ -> makeTx) - assertBool "First tx submission succeeds" (isRight e1) - - sigmaCompact cr.srcSqlEnv cr.targetSqlEnv =<< PS.getLatestBlockHeight cr.srcSqlEnv - - e2 <- runTxInBlock cr.mempoolRef cr.targetPactQueue cr.blockDb (\_ _ _ _ -> makeTx) - assertBool "First tx submission fails" (all (null . _payloadWithOutputsTransactions) e2) - --- | Test that user tables created before the compaction height are kept, --- while those created after the compaction height are dropped. -compactionUserTablesDropped :: () - => RocksDb - -> TestTree -compactionUserTablesDropped rdb = - let - -- creating a module uses about 60k gas. this is - -- that plus some change. - gasLimit :: GasLimit - gasLimit = 70_000 - - pactCfg = testPactServiceConfig { - _pactNewBlockGasLimit = gasLimit - } - in - compactionSetup "compactionUserTablesDropped" rdb pactCfg $ \cr -> do - let numBlocks :: Num a => a - numBlocks = 100 - let halfwayPoint :: Integral a => a - halfwayPoint = numBlocks `div` 2 - - let createTable :: Word -> Text -> IO Pact4.Transaction - createTable n tblName = do - let tx = T.unlines - [ "(namespace 'free)" - , "(module m" <> sshow n <> " G" - , " (defcap G () true)" - , " (defschema empty-schema)" - , " (deftable " <> tblName <> ":{empty-schema})" - , ")" - , "(create-table " <> tblName <> ")" - ] - buildCwCmd (sshow n) testVersion - $ signSender00 - $ set cbGasLimit gasLimit - $ set cbRPC (mkExec tx (mkKeySetData "sender00" [sender00])) - $ defaultCmd - - let beforeTable = "test_before" - let afterTable = "test_after" - - supply <- newIORef @Word 0 - madeBeforeTable <- newIORef @Bool False - madeAfterTable <- newIORef @Bool False - replicateM_ numBlocks $ do - setMempool cr.mempoolRef $ mempty { - mpaGetBlock = \_ validate mBlockHeight mBlockHash _ -> do - let mkTable madeRef tbl = do - madeYet <- readIORef madeRef - if madeYet - then do - pure mempty - else do - n <- atomicModifyIORef' supply $ \a -> (a + 1, a) - tx <- createTable n tbl - writeIORef madeRef True - [Right t] <- - V.toList <$> validate mBlockHeight mBlockHash ((fmap . fmap . fmap) _pcCode $ V.singleton tx) - pure (V.singleton t) - - if mBlockHeight <= halfwayPoint - then do - mkTable madeBeforeTable beforeTable - else do - mkTable madeAfterTable afterTable - } - void $ runBlock cr.srcPactQueue cr.blockDb second - - let freeBeforeTbl = "free.m0_" <> beforeTable - let freeAfterTbl = "free.m1_" <> afterTable - - statePre <- getPactUserTables cr.srcSqlEnv - forM_ [freeBeforeTbl, freeAfterTbl] $ \tbl -> do - let msg = "Table " ++ T.unpack tbl ++ " should exist pre-compaction, but it doesn't." - assertBool msg (isJust (M.lookup tbl statePre)) - - sigmaCompact cr.srcSqlEnv cr.targetSqlEnv (BlockHeight halfwayPoint) - - statePost <- getPactUserTables cr.targetSqlEnv - flip assertBool (isJust (M.lookup freeBeforeTbl statePost)) $ - T.unpack beforeTable ++ " was dropped; it wasn't supposed to be." - - flip assertBool (isNothing (M.lookup freeAfterTbl statePost)) $ - T.unpack afterTable ++ " wasn't dropped; it was supposed to be." - -compactionGrandHashUnchanged :: () - => RocksDb - -> TestTree -compactionGrandHashUnchanged rdb = - compactionSetup "compactionGrandHashUnchanged" rdb testPactServiceConfig $ \cr -> do - setOneShotMempool cr.mempoolRef =<< goldenMemPool - - let numBlocks :: Num a => a - numBlocks = 100 - - let makeTx :: Word -> BlockCreationTime -> IO Pact4.Transaction - makeTx nth bct = buildCwCmd (sshow nth) testVersion - $ set cbSigners [mkEd25519Signer' sender00 [mkGasCap, mkTransferCap "sender00" "sender01" 1.0]] - $ set cbChainId cid - $ set cbCreationTime (toTxCreationTime $ _bct bct) - $ set cbRPC (mkExec' "(coin.transfer \"sender00\" \"sender01\" 1.0)") - $ defaultCmd - - replicateM_ numBlocks - $ runTxInBlock_ cr.mempoolRef cr.srcPactQueue cr.blockDb - $ \n _ _ bct -> makeTx n bct - - let targetHeight = BlockHeight numBlocks - - hashPreCompaction <- computeGrandHash (PS.getLatestPactStateAt cr.srcSqlEnv targetHeight) - sigmaCompact cr.srcSqlEnv cr.targetSqlEnv targetHeight - hashPostCompaction <- computeGrandHash (PS.getLatestPactStateAt cr.targetSqlEnv targetHeight) - - assertEqual "GrandHash pre- and post-compaction are the same" hashPreCompaction hashPostCompaction - -compactionResilientToRowIdOrdering :: () - => RocksDb - -> TestTree -compactionResilientToRowIdOrdering rdb = - compactionSetup "compactionResilientToRowIdOrdering" rdb testPactServiceConfig $ \cr -> do - - let numBlocks :: Num a => a - numBlocks = 100 - - -- Just run a bunch of blocks - setOneShotMempool cr.mempoolRef =<< goldenMemPool - let makeTx :: Word -> BlockCreationTime -> IO Pact4.Transaction - makeTx nth bct = buildCwCmd (sshow nth) testVersion - $ set cbSigners [mkEd25519Signer' sender00 [mkGasCap, mkTransferCap "sender00" "sender01" 1.0]] - $ set cbChainId cid - $ set cbCreationTime (toTxCreationTime $ _bct bct) - $ set cbRPC (mkExec' "(coin.transfer \"sender00\" \"sender01\" 1.0)") - $ defaultCmd - replicateM_ numBlocks - $ runTxInBlock_ cr.mempoolRef cr.srcPactQueue cr.blockDb - $ \n _ _ bct -> makeTx n bct - - -- Get the state after running the blocks but before doing anything else - statePreCompaction <- getLatestPactState cr.srcSqlEnv - - -- Reverse all of the rowids in the table. We get all the rows in txid DESC order, like so: - -- rk1, txid=100, rowid=100 - -- rk1, txid=99, rowid=99 - -- ... - -- - -- Then we reverse the rowids, so that the table looks like this: - -- rk1, txid=100, rowid=10_000 - -- rk1, txid=99, rowid=10_001 - -- ... - -- - -- Since the compaction algorithm orders by rowid DESC, it will get the rows in reverse order to how they were inserted. - -- If compaction still results in the same end state, this confirms that the compaction algorithm is resilient to rowid ordering. - e <- PS.qryStream cr.srcSqlEnv "SELECT rowkey, txid FROM [coin_coin-table] ORDER BY txid ASC" [] [Pact.RText, Pact.RInt] $ \rows -> do - Lite.withStatement cr.srcSqlEnv "UPDATE [coin_coin-table] SET rowid = ?3 WHERE rowkey = ?1 AND txid = ?2" $ \stmt -> do - flip S.mapM_ (S.zip (S.enumFrom @_ @(Down Int64) 10_000) rows) $ \(Down newRowId, row) -> case row of - [Pact.SText rowkey, Pact.SInt txid] -> do - Pact.bindParams stmt [Pact.SText rowkey, Pact.SInt txid, Pact.SInt newRowId] - stepThenReset stmt - - _ -> error "unexpected row shape" - assertBool "Didn't encounter a sqlite error during rowid shuffling" (isRight e) - - -- Compact to the tip - sigmaCompact cr.srcSqlEnv cr.targetSqlEnv (BlockHeight numBlocks) - - -- Get the state post-randomisation and post-compaction - statePostCompaction <- getLatestPactState cr.targetSqlEnv - - -- Same logic as in 'pactStateSamePreAndPostCompaction' - comparePactStateBeforeAndAfter statePreCompaction statePostCompaction - -comparePactStateBeforeAndAfter :: (Ord k, Eq a, Show k, Show a) => M.Map Text (M.Map k a) -> M.Map Text (M.Map k a) -> IO () -comparePactStateBeforeAndAfter statePreCompaction statePostCompaction = do - let stateDiff = M.filter (not . PatienceM.isSame) (PatienceM.diff statePreCompaction statePostCompaction) - when (not (null stateDiff)) $ do - T.putStrLn "" - forM_ (M.toList stateDiff) $ \(tbl, delta) -> do - T.putStrLn "" - T.putStrLn tbl - case delta of - Same _ -> do - pure () - Old x -> do - putStrLn $ "a pre-only value appeared in the pre- and post-compaction diff: " ++ show x - New x -> do - putStrLn $ "a post-only value appeared in the pre- and post-compaction diff: " ++ show x - Delta x1 x2 -> do - let daDiff = M.filter (not . PatienceM.isSame) (PatienceM.diff x1 x2) - forM_ daDiff $ \item -> do - case item of - Old x -> do - putStrLn $ "old: " ++ show x - New x -> do - putStrLn $ "new: " ++ show x - Same _ -> do - pure () - Delta x y -> do - putStrLn $ "old: " ++ show x - putStrLn $ "new: " ++ show y - putStrLn "" - assertFailure "pact state check failed" - - --- pactStateSamePreAndPostCompaction :: () --- => RocksDb --- -> TestTree --- pactStateSamePreAndPostCompaction rdb = --- compactionSetup "pactStateSamePreAndPostCompaction" rdb testPactServiceConfig $ \cr -> do --- let numBlocks :: Num a => a --- numBlocks = 100 - --- let makeTx :: Word -> BlockCreationTime -> IO Pact4.Transaction --- makeTx nth bct = buildCwCmd (sshow (nth, bct)) testVersion --- $ set cbSigners [mkEd25519Signer' sender00 [mkGasCap, mkTransferCap "sender00" "sender01" 1.0]] --- $ set cbChainId cid --- $ set cbCreationTime (toTxCreationTime $ _bct bct) --- $ set cbRPC (mkExec' "(coin.transfer \"sender00\" \"sender01\" 1.0)") --- $ defaultCmd - --- replicateM_ numBlocks $ do --- runTxInBlock_ cr.mempoolRef cr.pactQueue cr.blockDb --- $ \n _ _ bct -> makeTx n bct - --- let db = cr.sqlEnv - --- statePreCompaction <- getLatestPactState db --- compact Error [C.NoVacuum] cr.sqlEnv (C.Target (BlockHeight numBlocks)) - --- statePostCompaction <- getLatestPactState db - --- let stateDiff = M.filter (not . PatienceM.isSame) (PatienceM.diff statePreCompaction statePostCompaction) --- when (not (null stateDiff)) $ do --- T.putStrLn "" --- forM_ (M.toList stateDiff) $ \(tbl, delta) -> do --- T.putStrLn "" --- T.putStrLn tbl --- case delta of --- Same _ -> do --- pure () --- Old x -> do --- putStrLn $ "a pre-only value appeared in the pre- and post-compaction diff: " ++ show x --- New x -> do --- putStrLn $ "a post-only value appeared in the pre- and post-compaction diff: " ++ show x --- Delta x1 x2 -> do --- let daDiff = M.filter (not . PatienceM.isSame) (PatienceM.diff x1 x2) --- forM_ daDiff $ \item -> do --- case item of --- Old x -> do --- putStrLn $ "old: " ++ show x --- New x -> do --- putStrLn $ "new: " ++ show x --- Same _ -> do --- pure () --- Delta x y -> do --- putStrLn $ "old: " ++ show x --- putStrLn $ "new: " ++ show y --- putStrLn "" --- assertFailure "pact state check failed" - --- compactionIsIdempotent :: () --- => RocksDb --- -> TestTree --- compactionIsIdempotent rdb = --- compactionSetup "compactionIdempotent" rdb testPactServiceConfig $ \cr -> do --- let numBlocks :: Num a => a --- numBlocks = 100 - --- let makeTx :: Word -> BlockCreationTime -> IO Pact4.Transaction --- makeTx nth bct = buildCwCmd (sshow (nth, bct)) testVersion --- $ set cbSigners [mkEd25519Signer' sender00 [mkGasCap, mkTransferCap "sender00" "sender01" 1.0]] --- $ set cbChainId cid --- $ set cbCreationTime (toTxCreationTime $ _bct bct) --- $ set cbRPC (mkExec' "(coin.transfer \"sender00\" \"sender01\" 1.0)") --- $ defaultCmd - --- replicateM_ numBlocks $ do --- runTxInBlock_ cr.mempoolRef cr.pactQueue cr.blockDb --- $ \n _ _ bct -> makeTx n bct - --- let db = cr.sqlEnv - --- let compact h = --- compact Error [C.NoVacuum] cr.sqlEnv h - --- let compactionHeight = C.Target (BlockHeight numBlocks) --- compact compactionHeight --- statePostCompaction1 <- getPactUserTables db --- compact compactionHeight --- statePostCompaction2 <- getPactUserTables db - --- let stateDiff = M.filter (not . PatienceM.isSame) (PatienceM.diff statePostCompaction1 statePostCompaction2) --- when (not (null stateDiff)) $ do --- T.putStrLn "" --- forM_ (M.toList stateDiff) $ \(tbl, delta) -> do --- T.putStrLn "" --- T.putStrLn tbl --- case delta of --- Same _ -> do --- pure () --- Old x -> do --- putStrLn $ "a pre-only value appeared in the compaction idempotency diff: " ++ show x --- New x -> do --- putStrLn $ "a post-only value appeared in the compaction idempotency diff: " ++ show x --- Delta x1 x2 -> do --- let daDiff = PatienceL.pairItems (\a b -> rowKey a == rowKey b) (PatienceL.diff x1 x2) --- forM_ daDiff $ \item -> do --- case item of --- Old x -> do --- putStrLn $ "old: " ++ show x --- New x -> do --- putStrLn $ "new: " ++ show x --- Same _ -> do --- pure () --- Delta x y -> do --- putStrLn $ "old: " ++ show x --- putStrLn $ "new: " ++ show y --- putStrLn "" --- assertFailure "pact state check failed" - --- compactionDoesNotDisruptDuplicateDetection :: () --- => RocksDb --- -> TestTree --- compactionDoesNotDisruptDuplicateDetection rdb = do --- compactionSetup "compactionDoesNotDisruptDuplicateDetection" rdb testPactServiceConfig $ \cr -> do --- let makeTx :: IO Pact4.Transaction --- makeTx = buildCwCmd (sshow @Word 0) testVersion --- $ set cbSigners [mkEd25519Signer' sender00 [mkGasCap, mkTransferCap "sender00" "sender01" 1.0]] --- $ set cbRPC (mkExec' "(coin.transfer \"sender00\" \"sender01\" 1.0)") --- $ defaultCmd - --- let run = do --- runTxInBlock cr.mempoolRef cr.pactQueue cr.blockDb --- $ \_ _ _ _ -> makeTx - --- run >>= \e -> assertBool "First tx submission succeeds" (isRight e) --- compact Error [C.NoVacuum] cr.sqlEnv C.LatestUnsafe --- run >>= \e -> assertEqual "First tx submission fails" --- (V.null . _payloadWithOutputsTransactions <$> e) --- (Right True) - --- pure () - --- -- | Test that user tables created before the compaction height are kept, --- -- while those created after the compaction height are dropped. --- compactionUserTablesDropped :: () --- => RocksDb --- -> TestTree --- compactionUserTablesDropped rdb = --- let --- -- creating a module uses about 60k gas. this is --- -- that plus some change. --- gasLimit :: GasLimit --- gasLimit = 70_000 - --- pactCfg = testPactServiceConfig { --- _pactNewBlockGasLimit = gasLimit --- } --- in --- compactionSetup "compactionUserTablesDropped" rdb pactCfg $ \cr -> do --- let numBlocks :: Num a => a --- numBlocks = 100 --- let halfwayPoint :: Integral a => a --- halfwayPoint = numBlocks `div` 2 - --- let createTable :: Word -> Text -> IO Pact4.Transaction --- createTable n tblName = do --- let tx = T.unlines --- [ "(namespace 'free)" --- , "(module m" <> sshow n <> " G" --- , " (defcap G () true)" --- , " (defschema empty-schema)" --- , " (deftable " <> tblName <> ":{empty-schema})" --- , ")" --- , "(create-table " <> tblName <> ")" --- ] --- buildCwCmd (sshow n) testVersion --- $ signSender00 --- $ set cbGasLimit gasLimit --- $ set cbRPC (mkExec tx (mkKeySetData "sender00" [sender00])) --- $ defaultCmd - --- let beforeTable = "test_before" --- let afterTable = "test_after" - --- supply <- newIORef @Word 0 --- madeBeforeTable <- newIORef @Bool False --- madeAfterTable <- newIORef @Bool False --- replicateM_ numBlocks $ do --- setMempool cr.mempoolRef $ mempty { --- mpaGetBlock = \_ validate mBlockHeight mBlockHash _ -> do --- let mkTable madeRef tbl = do --- madeYet <- readIORef madeRef --- if madeYet --- then do --- pure mempty --- else do --- n <- atomicModifyIORef' supply $ \a -> (a + 1, a) --- tx <- createTable n tbl --- writeIORef madeRef True --- [Right t] <- --- V.toList <$> validate mBlockHeight mBlockHash ((fmap . fmap . fmap) _pcCode $ V.singleton tx) --- pure (V.singleton t) - --- if mBlockHeight <= halfwayPoint --- then do --- mkTable madeBeforeTable beforeTable --- else do --- mkTable madeAfterTable afterTable --- } --- void $ runBlock cr.pactQueue cr.blockDb second - --- let freeBeforeTbl = "free.m0_" <> beforeTable --- let freeAfterTbl = "free.m1_" <> afterTable - --- let db = cr.sqlEnv - --- statePre <- getPactUserTables db --- let assertExists tbl = do --- let msg = "Table " ++ T.unpack tbl ++ " should exist pre-compaction, but it doesn't." --- assertBool msg (isJust (M.lookup tbl statePre)) --- assertExists freeBeforeTbl --- assertExists freeAfterTbl - --- compact Error [C.NoVacuum] cr.sqlEnv (C.Target (BlockHeight halfwayPoint)) - --- statePost <- getPactUserTables db --- flip assertBool (isJust (M.lookup freeBeforeTbl statePost)) $ --- T.unpack beforeTable ++ " was dropped; it wasn't supposed to be." - --- flip assertBool (isNothing (M.lookup freeAfterTbl statePost)) $ --- T.unpack afterTable ++ " wasn't dropped; it was supposed to be." - --- compactionGrandHashUnchanged :: () --- => RocksDb --- -> TestTree --- compactionGrandHashUnchanged rdb = --- compactionSetup "compactionGrandHashUnchanged" rdb testPactServiceConfig $ \cr -> do --- setOneShotMempool cr.mempoolRef =<< goldenMemPool - --- let numBlocks :: Num a => a --- numBlocks = 100 - --- let makeTx :: Word -> BlockCreationTime -> IO Pact4.Transaction --- makeTx nth bct = buildCwCmd (sshow nth) testVersion --- $ set cbSigners [mkEd25519Signer' sender00 [mkGasCap, mkTransferCap "sender00" "sender01" 1.0]] --- $ set cbCreationTime (toTxCreationTime $ _bct bct) --- $ set cbRPC (mkExec' "(coin.transfer \"sender00\" \"sender01\" 1.0)") --- $ defaultCmd - --- replicateM_ numBlocks --- $ runTxInBlock_ cr.mempoolRef cr.pactQueue cr.blockDb --- $ \n _ _ blockHeader -> makeTx n blockHeader - --- let db = cr.sqlEnv --- let targetHeight = BlockHeight numBlocks - --- hashPreCompaction <- computeGrandHash (PS.getLatestPactStateAt db targetHeight) --- compact Error [C.NoVacuum] cr.sqlEnv (C.Target targetHeight) --- hashPostCompaction <- computeGrandHash (PS.getLatestPactStateAt db targetHeight) - --- assertEqual "GrandHash pre- and post-compaction are the same" hashPreCompaction hashPostCompaction - -getHistory :: IO (IORef MemPoolAccess) -> IO (SQLiteEnv, PactQueue, TestBlockDb) -> TestTree -getHistory refIO reqIO = testCase "getHistory" $ do - (_, q, bdb) <- reqIO - setOneShotMempool refIO =<< goldenMemPool - void $ runBlock q bdb second - h <- getParentTestBlockDb bdb cid - Historical (BlockTxHistory hist prevBals) <- pactBlockTxHistory h - (PCore.DUserTables (PCore.TableName "coin-table" (PCore.ModuleName "coin" Nothing))) - q - -- just check first one here - assertEqual "check first entry of history" - (Just [PCore.TxLog "coin_coin-table" "sender00" - (toRowData $ object - [ "guard" .= object - [ "pred" .= ("keys-all" :: T.Text) - , "keys" .= - ["368820f80c324bbc7c2b0610688a7da43e39f91d118732671cd9c7500ff43cca" :: T.Text] - ] - , "balance" .= Number 99_999_900.0 - ])]) - (M.lookup 10 hist) - -- and transaction txids - assertEqual "check txids" - [7,10,12,13,15,16,18,19,21,22,24,25,27,28,30,31,33,34,36,37,39,40,42] - (M.keys hist) - -- and last tx log change for accounts touched in given block - assertEqual "check previous balance" - (M.fromList - [(RowKey "sender00", - (PCore.TxLog "coin_coin-table" "sender00" - (toRowData $ object - [ "guard" .= object - [ "pred" .= ("keys-all" :: T.Text) - , "keys" .= - ["368820f80c324bbc7c2b0610688a7da43e39f91d118732671cd9c7500ff43cca" :: T.Text] - ] - , "balance" .= (Number 100000000.0) - ] - ) - ))]) - prevBals - -getHistoricalLookupNoTxs - :: T.Text - -> (Maybe (PCore.TxLog PCore.RowData) -> IO ()) - -> IO (IORef MemPoolAccess) - -> IO (SQLiteEnv, PactQueue, TestBlockDb) - -> TestTree -getHistoricalLookupNoTxs key assertF refIO reqIO = - testCase (T.unpack ("getHistoricalLookupNoTxs: " <> key)) $ do - (_, q, bdb) <- reqIO - setOneShotMempool refIO mempty - void $ runBlock q bdb second - h <- getParentTestBlockDb bdb cid - histLookup q h key >>= assertF - -getHistoricalLookupWithTxs - :: T.Text - -> (Maybe (PCore.TxLog PCore.RowData) -> IO ()) - -> IO (IORef MemPoolAccess) - -> IO (SQLiteEnv, PactQueue, TestBlockDb) - -> TestTree -getHistoricalLookupWithTxs key assertF refIO reqIO = - testCase (T.unpack ("getHistoricalLookupWithTxs: " <> key)) $ do - (_, q, bdb) <- reqIO - setOneShotMempool refIO =<< goldenMemPool - void $ runBlock q bdb second - h <- getParentTestBlockDb bdb cid - histLookup q h key >>= assertF - -histLookup :: PactQueue -> BlockHeader -> T.Text -> IO (Maybe (PCore.TxLog PCore.RowData)) -histLookup q bh k = - throwIfNoHistory =<< pactHistoricalLookup bh - (PCore.DUserTables (PCore.TableName "coin-table" (PCore.ModuleName "coin" Nothing))) - (PCore.RowKey k) q - -assertSender00Bal :: Rational -> String -> Maybe (PCore.TxLog PCore.RowData) -> Assertion -assertSender00Bal bal msg hist = - assertEqual msg - (Just (PCore.TxLog "coin_coin-table" "sender00" - (toRowData $ object - [ "guard" .= object - [ "pred" .= ("keys-all" :: T.Text) - , "keys" .= - ["368820f80c324bbc7c2b0610688a7da43e39f91d118732671cd9c7500ff43cca" :: T.Text] - ] - , "balance" .= Number (fromRational bal) - ]))) - hist - -signSender00 :: CmdBuilder -> CmdBuilder -signSender00 = set cbSigners [mkEd25519Signer' sender00 []] - --- this test relies on block gas errors being thrown before other Pact errors. -blockGasLimitTest :: HasCallStack => IO (IORef MemPoolAccess) -> IO (SQLiteEnv, PactQueue, TestBlockDb) -> TestTree -blockGasLimitTest _ reqIO = testCase "blockGasLimitTest" $ do - (_, q, _) <- reqIO - - let - useGas g = do - bigTx <- buildCwCmd "cmd" testVersion - $ set cbGasLimit g $ signSender00 $ set cbRPC (mkExec' "TESTING") defaultCmd - let - cr = CommandResult - (RequestKey (Hash "0")) Nothing - (PactResult $ Left $ PactError EvalError (Pact.Types.Info.Info Nothing) [] mempty) - (fromIntegral g) Nothing Nothing Nothing [] - block = Transactions - (V.singleton (bigTx, cr)) - (CommandResult (RequestKey (Hash "h")) Nothing - (PactResult $ Right $ pString "output") 0 Nothing Nothing Nothing []) - payload = toPayloadWithOutputs Pact4T noMiner block - bh = newBlockHeader - (_versionForkNumber testVersion) - mempty - (_payloadWithOutputsPayloadHash payload) - (Nonce 0) - (BlockCreationTime $ Time $ TimeSpan 0) - (ParentHeader $ genesisBlockHeader testVersion cid) - try $ validateBlock bh (CheckablePayloadWithOutputs payload) q - -- we consume slightly more than the maximum block gas limit and provoke an error. - useGas 2_000_001 >>= \case - Left (BlockGasLimitExceeded _) -> - return () - r -> - error $ "not a BlockGasLimitExceeded error: " <> ppShow r - -- we consume much more than the maximum block gas limit and expect an error. - useGas 3_000_000 >>= \case - Left (BlockGasLimitExceeded _) -> - return () - r -> - error $ "not a BlockGasLimitExceeded error: " <> ppShow r - -- we consume exactly the maximum block gas limit and expect no such error. - -- our block is otherwise invalid, so we do expect a validation error - useGas 2_000_000 >>= \case - Left (BlockGasLimitExceeded _) -> - error "consumed exactly block gas limit but errored" - Left (BlockValidationFailure _) -> - return () - Left err -> - error $ "failed with other error: " <> sshow err - Right _ -> - error "succeeded with invalid block" - -- we consume much less than the maximum block gas limit and expect no gas error. - -- again our block is otherwise invalid, so we do expect a validation error - useGas 1_000_000 >>= \case - Left (BlockGasLimitExceeded _) -> - error "consumed much less than block gas limit but errored" - Left (BlockValidationFailure _) -> - return () - Left err -> - error $ "failed with other error: " <> sshow err - Right _ -> - error "succeeded with invalid block" - -- we consume 1 gas and expect no gas error. again our block is otherwise - -- invalid, so we do expect an validation error. - -- we cannot consume 0 gas, or the coin contract will fail to buy gas. - useGas 1 >>= \case - Left (BlockGasLimitExceeded _) -> - error "consumed no gas but errored" - Left (BlockValidationFailure _) -> - return () - Left err -> - error $ "failed with other error: " <> sshow err - Right _ -> - error "succeeded with invalid block" - -mempoolRefillTest :: IO (IORef MemPoolAccess) -> IO (SQLiteEnv, PactQueue, TestBlockDb) -> TestTree -mempoolRefillTest mpRefIO reqIO = testCase "mempoolRefillTest" $ do - - (_, q, bdb) <- reqIO - supply <- newMVar (0 :: Int) - - mp supply [ ( 0, [goodTx, goodTx] ), ( 1, [badTx] ) ] - runBlock q bdb second >>= checkCount 2 - - mp supply [ ( 0, [goodTx, goodTx] ), ( 1, [goodTx, badTx] ) ] - runBlock q bdb second >>= checkCount 3 - - mp supply [ ( 0, [badTx, goodTx] ), ( 1, [goodTx, badTx] ) ] - runBlock q bdb second >>= checkCount 2 - - mp supply [ ( 0, [badTx] ), ( 1, [goodTx, goodTx] ) ] - runBlock q bdb second >>= checkCount 2 - - mp supply [ ( 0, [goodTx, goodTx] ), ( 1, [badTx, badTx] ) ] - runBlock q bdb second >>= checkCount 2 - - where - - checkCount :: HasCallStack => Int -> PayloadWithOutputs_ a -> Assertion - checkCount n = assertEqual "tx return count" n . V.length . _payloadWithOutputsTransactions - - mp supply txRefillMap = setMempool mpRefIO $ mempty { - mpaGetBlock = \BlockFill{..} validate bheight bhash bct -> - case M.lookup _bfCount (M.fromList txRefillMap) of - Nothing -> return mempty - Just txs -> do - tos <- validate bheight bhash =<< (fmap (V.fromList . (fmap . fmap . fmap) _pcCode) $ sequence $ map (next supply bct) txs) - return $ V.fromList [t | Right t <- V.toList tos] - } - - next supply bh f = do - i <- modifyMVar supply $ return . (succ &&& id) - f i bh - - goodTx i bct = buildCwCmd (sshow (i, bct)) testVersion - $ signSender00 - $ set cbChainId cid - $ set cbCreationTime (toTxCreationTime $ _bct bct) - $ set cbRPC (mkExec' "(+ 1 2)") - $ defaultCmd - - badTx i bct = buildCwCmd (sshow (i, bct)) testVersion - $ signSender00 - $ set cbSender "bad" - $ set cbChainId cid - $ set cbCreationTime (toTxCreationTime $ _bct bct) - $ set cbRPC (mkExec' "(+ 1 2)") - $ defaultCmd - -moduleNameFork :: IO (IORef MemPoolAccess) -> IO (SQLiteEnv, PactQueue, TestBlockDb) -> TestTree -moduleNameFork mpRefIO reqIO = testCase "moduleNameFork" $ do - - (_, q, bdb) <- reqIO - - -- install in free in block 1 - setOneShotMempool mpRefIO (moduleNameMempool "free" "test") - void $ runBlock q bdb second - - -- install in user in block 2 - setOneShotMempool mpRefIO (moduleNameMempool "user" "test") - void $ runBlock q bdb second - - -- do something else post-fork - setOneShotMempool mpRefIO (moduleNameMempool "free" "test2") - void $ runBlock q bdb second - setOneShotMempool mpRefIO (moduleNameMempool "user" "test2") - void $ runBlock q bdb second - - -- TODO this test doesn't actually validate, I turn on Debug and make sure it - -- goes well. - -moduleNameMempool :: T.Text -> T.Text -> MemPoolAccess -moduleNameMempool ns mn = mempty - { mpaGetBlock = \_ validate bheight bhash bct -> do - let txs = - [ "(namespace '" <> ns <> ") (module " <> mn <> " G (defcap G () (enforce false 'cannotupgrade)))" - , ns <> "." <> mn <> ".G" - ] - builtTxs <- fmap V.fromList $ forM (zip txs [0..]) $ \(code,n :: Int) -> - buildCwCmd ("1" <> sshow n) testVersion $ - signSender00 $ - set cbCreationTime (toTxCreationTime $ _bct bct) $ - set cbRPC (mkExec' code) $ - defaultCmd - tos <- validate bheight bhash $ (fmap . fmap . fmap) _pcCode builtTxs - return $ V.fromList [t | Right t <- V.toList tos ] - -- undefined - } - - -mempoolCreationTimeTest :: IO (IORef MemPoolAccess) -> IO (SQLiteEnv, PactQueue, TestBlockDb) -> TestTree -mempoolCreationTimeTest mpRefIO reqIO = testCase "mempoolCreationTimeTest" $ do - - (_, q, bdb) <- reqIO - - let start@(Time startSpan) :: Time Micros = Time (TimeSpan (Micros 100_000_000)) - s30 = scaleTimeSpan (30 :: Int) second - s15 = scaleTimeSpan (15 :: Int) second - -- b1 block time is start - void $ runBlock q bdb startSpan - - - -- do pre-insert check with transaction at start + 15s - tx <- makeTx "tx-now" (add s15 start) - void $ pactPreInsertCheck (V.singleton $ fmap (fmap _pcCode) tx) q - - setOneShotMempool mpRefIO $ mp tx - -- b2 will be made at start + 30s - void $ runBlock q bdb s30 - - where - - makeTx nonce t = buildCwCmd (sshow t <> nonce) testVersion - $ signSender00 - $ set cbChainId cid - $ set cbCreationTime (toTxCreationTime t) - $ set cbTTL 300 - $ set cbRPC (mkExec' "1") - $ defaultCmd - mp tx = mempty { - mpaGetBlock = \_ valid bh bhash _ -> getBlock bh bhash tx valid - } - - getBlock bh bhash tx valid = do - let txs = V.singleton $ (fmap . fmap) _pcCode tx - [Right t] <- V.toList <$> valid bh bhash txs - return (V.singleton t) - -preInsertCheckTimeoutTest :: IO (IORef MemPoolAccess) -> IO (SQLiteEnv, PactQueue, TestBlockDb) -> TestTree -preInsertCheckTimeoutTest _ reqIO = testCase "preInsertCheckTimeoutTest" $ do - (_, q, _) <- reqIO - - coinV3 <- T.readFile "pact/coin-contract/v3/coin-v3.pact" - coinV4 <- T.readFile "pact/coin-contract/v4/coin-v4.pact" - coinV5 <- T.readFile "pact/coin-contract/v5/coin-v5.pact" - - txCoinV3 <- buildCwCmd "tx-now-coinv3" testVersion - $ signSender00 - $ set cbChainId cid - $ set cbRPC (mkExec' coinV3) - $ defaultCmd - - txCoinV4 <- buildCwCmd "tx-now-coinv4" testVersion - $ signSender00 - $ set cbChainId cid - $ set cbRPC (mkExec' coinV4) - $ defaultCmd - - txCoinV5 <- buildCwCmd "tx-now-coinv5" testVersion - $ signSender00 - $ set cbChainId cid - $ set cbRPC (mkExec' coinV5) - $ defaultCmd - - -- timeouts are tricky to trigger in GH actions. - -- we're satisfied if it's triggered once in 100 runs. - rs <- replicateM 100 - (pactPreInsertCheck ((fmap . fmap . fmap) _pcCode $ V.fromList [txCoinV3, txCoinV4, txCoinV5]) q) - assertBool "should get at least one InsertErrorTimedOut" $ any - (V.all (== Just InsertErrorTimedOut)) - rs - -badlistNewBlockTest :: IO (IORef MemPoolAccess) -> IO (SQLiteEnv, PactQueue, TestBlockDb) -> TestTree -badlistNewBlockTest mpRefIO reqIO = testCase "badlistNewBlockTest" $ do - (_, reqQ, _) <- reqIO - let hashToTxHashList = V.singleton . pact4RequestKeyToTransactionHash . RequestKey . toUntypedHash @'Blake2b_256 - badHashRef <- newIORef $ hashToTxHashList initialHash - badTx <- buildCwCmd "badListMPA" testVersion - $ signSender00 - -- this should exceed the account balance - $ set cbGasLimit 99_999 - $ set cbGasPrice 1_000_000_000_000_000 - $ set cbRPC (mkExec' "(+ 1 2)") - $ defaultCmd - setOneShotMempool mpRefIO (badlistMPA badTx badHashRef) - bip <- throwIfNoHistory =<< newBlock noMiner NewBlockFill (ParentHeader genesisHeader) reqQ - let resp = forAnyPactVersion finalizeBlock bip - assertEqual "bad tx filtered from block" mempty (_payloadWithOutputsTransactions resp) - badHash <- readIORef badHashRef - assertEqual "Badlist should have badtx hash" (hashToTxHashList $ _cmdHash badTx) badHash - where - badlistMPA badTx badHashRef = mempty - { mpaGetBlock = \_ valid bheight bhash _ -> do - [Right t] <- V.toList <$> valid bheight bhash (V.singleton $ (fmap . fmap) _pcCode badTx) - return (V.singleton t) - , mpaBadlistTx = \v -> writeIORef badHashRef v - } - -goldenNewBlock :: String -> IO MemPoolAccess -> IO (IORef MemPoolAccess) -> IO (SQLiteEnv, PactQueue, TestBlockDb) -> TestTree -goldenNewBlock name mpIO mpRefIO reqIO = golden name $ do - mp <- mpIO - (_, reqQ, _) <- reqIO - setOneShotMempool mpRefIO mp - blockInProgress <- throwIfNoHistory =<< newBlock noMiner NewBlockFill (ParentHeader genesisHeader) reqQ - let resp = forAnyPactVersion finalizeBlock blockInProgress - -- ensure all golden txs succeed - forM_ (_payloadWithOutputsTransactions resp) $ \(txIn,TransactionOutput out) -> do - cr :: CommandResult Hash <- decodeStrictOrThrow out - assertSatisfies ("golden tx succeeds, input: " ++ show txIn) (_crResult cr) (isRight . (\(PactResult r) -> r)) - case blockInProgress of - ForPact4 bip -> goldenBytes resp bip - ForPact5 _ -> error "pact 5 in goldenNewBlock" - where - hmToSortedList :: Ord k => HM.HashMap k v -> [(k, v)] - hmToSortedList = List.sortOn fst . HM.toList - -- missing some fields, only includes the fields that are "outputs" of - -- running txs, but not the module cache - blockInProgressToJSON BlockInProgress {..} = J.object - [ "blockGasLimit" J..= J.Aeson (fromIntegral @_ @Int _blockInProgressRemainingGasLimit) - , "parentHeader" J..= J.encodeWithAeson (_parentHeader $ fromJuste _blockInProgressParentHeader) - , "pendingData" J..= J.object - [ "pendingSuccessfulTxs" J..= J.array - (encodeB64UrlNoPaddingText <$> List.sort (toList _pendingSuccessfulTxs)) - , "pendingTableCreation" J..= J.array - (List.sort (toList _pendingTableCreation)) - , "pendingWrites" J..= pendingWritesJson - ] - , "txId" J..= J.Aeson (fromIntegral @_ @Int $ _blockHandleTxId _blockInProgressHandle) - ] - where - SQLitePendingData{..} = _blockHandlePending _blockInProgressHandle - pendingWritesJson = J.Object - [ (_dkTable, J.Object - [ (T.decodeUtf8 _dkRowKey, J.Object - [ ((sshow @_ @T.Text. fromIntegral @TxId @Word) _deltaTxId, T.decodeUtf8 _deltaData) - | SQLiteRowDelta {..} <- toList rowKeyWrites - ]) - | (_dkRowKey, rowKeyWrites) <- hmToSortedList tableWrites - ]) - | (_dkTable, tableWrites) <- hmToSortedList _pendingWrites - ] - - goldenBytes :: PayloadWithOutputs -> BlockInProgress Pact4 -> IO BL.ByteString - goldenBytes a b = return $ BL.fromStrict $ encodeYaml $ J.object - [ "test-group" J..= ("new-block" :: T.Text) - , "results" J..= J.encodeWithAeson a - , "blockInProgress" J..= blockInProgressToJSON b - ] - -goldenMemPool :: IO MemPoolAccess -goldenMemPool = do - moduleStr <- readFile' $ testPactFilesDir ++ "test1.pact" - let txs = - [ (T.pack moduleStr) - , "(create-table free.test1.accounts)" - , "(free.test1.create-global-accounts)" - , "(free.test1.transfer \"Acct1\" \"Acct2\" 1.00)" - , "(at 'prev-block-hash (chain-data))" - , "(at 'block-time (chain-data))" - , "(at 'block-height (chain-data))" - , "(at 'gas-limit (chain-data))" - , "(at 'gas-price (chain-data))" - , "(at 'chain-id (chain-data))" - , "(at 'sender (chain-data))" - ] - outTxs <- mkTxs txs - mempoolOf [outTxs] - where - mkTxs txs = - fmap V.fromList $ forM (zip txs [0..]) $ \(code,n :: Int) -> - buildCwCmd ("1" <> sshow n) testVersion $ - signSender00 $ - set cbGasPrice 0.01 $ - set cbTTL 1_000_000 $ -- match old goldens - set cbRPC (mkExec code $ mkKeySetData "test-admin-keyset" [sender00]) $ - defaultCmd - -mempoolOf :: [V.Vector Pact4.Transaction] -> IO MemPoolAccess -mempoolOf blocks = do - blocksRemainingRef <- newIORef blocks - return mempty - { mpaGetBlock = getTestBlock blocksRemainingRef - } - where - getTestBlock blocksRemainingRef _ validate bHeight bHash _parent = do - outtxs <- atomicModifyIORef' blocksRemainingRef $ \case - (b:bs) -> (bs, b) - [] -> ([], mempty) - oks <- validate bHeight bHash $ (fmap . fmap . fmap) _pcCode outtxs - unless (V.all isRight oks) $ fail $ mconcat - [ "tx failed validation! \nouttxs: \n" - , show outtxs - , "\n\noks: \n" - , show [ err | Left err <- V.toList oks ] - ] - return $ V.fromList [ t | Right t <- V.toList oks ] - - -data CompactionResources = CompactionResources - { mempoolRef :: IO (IORef MemPoolAccess) - , mempool :: MemPoolAccess - , srcSqlEnv :: SQLiteEnv - , targetSqlEnv :: SQLiteEnv - , srcPactQueue :: PactQueue - , targetPactQueue :: PactQueue - , blockDb :: TestBlockDb - } - -compactionSetup :: () - => String - -- ^ test pattern - -> RocksDb - -> PactServiceConfig - -> (CompactionResources -> IO ()) - -> TestTree -compactionSetup pat rdb pactCfg f = - withResourceT (withTempDir "src-pact-dir") $ \srcDir -> withSqliteDb cid srcDir $ \srcSqlEnvIO -> - withResourceT (withTempDir "src-pact-dir") $ \targetDir -> withSqliteDb cid targetDir $ \targetSqlEnvIO -> - withResourceT (mkTestBlockDb testVersion rdb) $ \blockDbIO -> - withDelegateMempool $ \dm -> - testCase pat $ do - blockDb <- blockDbIO - bhDb <- getWebBlockHeaderDb (_bdbWebBlockHeaderDb blockDb) cid - let payloadDb = _bdbPayloadDb blockDb - srcSqlEnv <- srcSqlEnvIO - targetSqlEnv <- targetSqlEnvIO - (mempoolRef, mempool) <- do - (ref, nonRef) <- dm - pure (pure ref, nonRef) - srcPactQueue <- newPactQueue 2_000 - targetPactQueue <- newPactQueue 2_000 - - let logger = genericLogger System.LogLevel.Error (\_ -> return ()) - - -- Start pact service for the src and target - let srcPactService = runPactService testVersion cid logger Nothing srcPactQueue mempool bhDb payloadDb srcSqlEnv pactCfg - let targetPactService = runPactService testVersion cid logger Nothing targetPactQueue mempool bhDb payloadDb targetSqlEnv pactCfg - - setOneShotMempool mempoolRef =<< goldenMemPool - - withAsync srcPactService $ \_ -> do - withAsync targetPactService $ \_ -> do - f $ CompactionResources - { mempoolRef = mempoolRef - , mempool = mempool - , srcSqlEnv = srcSqlEnv - , targetSqlEnv = targetSqlEnv - , srcPactQueue = srcPactQueue - , targetPactQueue = targetPactQueue - , blockDb = blockDb - } - - -runTxInBlock :: () - => IO (IORef MemPoolAccess) -- ^ mempoolRef - -> PactQueue - -> TestBlockDb - -> (Word -> BlockHeight -> BlockHash -> BlockCreationTime -> IO Pact4.Transaction) - -> IO (Either PactException PayloadWithOutputs) -runTxInBlock mempoolRef pactQueue blockDb makeTx = do - madeTx <- newIORef @Bool False - supply <- newIORef @Word 0 - setMempool mempoolRef $ mempty { - mpaGetBlock = \_ valid bHeight bHash bct -> do - madeTxYet <- readIORef madeTx - if madeTxYet - then do - pure mempty - else do - n <- atomicModifyIORef' supply $ \a -> (a + 1, a) - tx <- makeTx n bHeight bHash bct - valids <- valid bHeight bHash (V.singleton $ (fmap . fmap) _pcCode tx) - writeIORef madeTx True - pure $ V.fromList - [ v - | Right v <- V.toList valids - ] - } - e <- runBlockE pactQueue blockDb second - writeIORef madeTx False - pure e - -runTxInBlock_ :: () - => IO (IORef MemPoolAccess) -- ^ mempoolRef - -> PactQueue - -> TestBlockDb - -> (Word -> BlockHeight -> BlockHash -> BlockCreationTime -> IO Pact4.Transaction) - -> IO PayloadWithOutputs -runTxInBlock_ mempoolRef pactQueue blockDb makeTx = do - runTxInBlock mempoolRef pactQueue blockDb makeTx >>= \case - Left e -> assertFailure $ "newBlockAndValidate: validate: got failure result: " ++ show e - Right v -> pure v - --- | Step through a prepared statement, then clear the statement's bindings --- and reset the statement. -stepThenReset :: Lite.Statement -> IO Lite.StepResult -stepThenReset stmt = do - Lite.stepNoCB stmt `finally` (Lite.clearBindings stmt >> Lite.reset stmt) diff --git a/test/unit/Chainweb/Test/Pact4/RemotePactTest.hs b/test/unit/Chainweb/Test/Pact4/RemotePactTest.hs deleted file mode 100644 index ed9b5e07f3..0000000000 --- a/test/unit/Chainweb/Test/Pact4/RemotePactTest.hs +++ /dev/null @@ -1,1319 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE ImportQualifiedPost #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE NumericUnderscores #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE ViewPatterns #-} - --- | --- Module: Chainweb.Test.RemotePactTest --- Copyright: Copyright © 2018 - 2020 Kadena LLC. --- License: See LICENSE file --- Maintainer: Mark Nichols , Emily Pillmore --- Stability: experimental --- --- Unit test for Pact execution via the Http Pact interface (/send, --- etc.) (inprocess) API in Chainweb --- -module Chainweb.Test.Pact4.RemotePactTest -( tests -, withRequestKeys -, polling -, sending -, PollingExpectation(..) -) where - -import Control.Concurrent hiding (modifyMVar, newMVar, putMVar, readMVar) -import Control.Concurrent.MVar.Strict -import Control.DeepSeq -import Control.Lens -import Control.Monad -import Control.Monad.Catch -import Control.Monad.IO.Class -import Control.Monad.Trans.Resource - -import qualified Data.Aeson as A -import Data.Aeson.Lens hiding (values) -import Data.Bifunctor (first) -import Control.Monad.Trans.Except (runExceptT, except) -import Control.Monad.Except (throwError) -import qualified Data.ByteString as BS -import qualified Data.ByteString.Lazy as LBS -import qualified Data.ByteString.Short as SB -import Data.IORef (modifyIORef', newIORef, readIORef) -import Data.Word (Word64) -import Data.Foldable (toList) -import qualified Data.HashMap.Strict as HM -import qualified Data.List as L -import qualified Data.List.NonEmpty as NEL -import qualified Data.Map.Strict as M -import Data.Maybe -import Data.Text (Text) -import qualified Data.Text as T -import qualified Data.Text.Encoding as T -import GHC.Exts(the) -import System.LogLevel (LogLevel(..)) - -import Servant.Client - -import Test.Tasty -import Test.Tasty.HUnit - -import qualified Pact.ApiReq as Pact -import qualified Pact.JSON.Encode as J -import Pact.Types.API -import Pact.Types.Capability -import qualified Pact.Types.ChainId as Pact -import qualified Pact.Types.ChainMeta as Pact -import Pact.Types.Command -import Pact.Types.Continuation -import Pact.Types.Exp -import Pact.Types.Gas -import Pact.Types.Hash (Hash(..)) -import Pact.Types.Hash qualified as Pact -import Pact.Types.Info (noInfo) -import qualified Pact.Types.PactError as Pact -import Pact.Types.PactValue -import Pact.Types.Pretty -import Pact.Types.Persistence (RowKey(..), TxLog(..)) -import Pact.Types.RowData (RowData(..)) -import Pact.Types.Term - --- internal modules - -import Chainweb.ChainId -import Chainweb.Chainweb.Configuration -import Chainweb.Graph -import Chainweb.Mempool.Mempool -import Chainweb.Pact.Backend.Compaction qualified as Sigma -import Chainweb.Pact.Backend.PactState (getLatestBlockHeight) -import Chainweb.Pact.Backend.Utils qualified as Backend -import Chainweb.Pact.RestAPI.Client -import Chainweb.Pact.RestAPI.EthSpv -import Chainweb.Pact.Types -import Chainweb.Pact4.Validations (defaultMaxTTL) -import Chainweb.Test.Pact4.Utils -import Chainweb.Test.Pact4.Utils qualified as Utils -import Chainweb.Test.RestAPI.Utils -import Chainweb.Test.Utils -import Chainweb.Test.TestVersions -import Chainweb.Time -import Chainweb.Utils hiding (check) -import Chainweb.Version -import Chainweb.Version.Mainnet -import Chainweb.Storage.Table.RocksDB -import qualified Pact.Core.Command.Server as Pact5 - --- -------------------------------------------------------------------------- -- --- Global Settings - -nNodes :: Word -nNodes = 1 - -v :: ChainwebVersion -v = instantCpmTestVersion petersenChainGraph - -vNetworkId :: Pact.NetworkId -vNetworkId = Pact.NetworkId $ getChainwebVersionName $ _versionName v - - -cid :: HasCallStack => ChainId -cid = head . toList $ chainIds v - -pactCid :: HasCallStack => Pact.ChainId -pactCid = Pact.ChainId $ chainIdToText cid - -gp :: GasPrice -gp = 0.1 - -withRequestKeys - :: Pact.TxCreationTime - -> ClientEnv - -> IO RequestKeys -withRequestKeys t cenv = do - mNonce <- newMVar 0 - testSend t mNonce cenv - --- ------------------------------------------------------------------------- -- --- Tests. GHCI use `runRocks tests` --- also: --- :set -package retry --- :set -package extra - --- | Note: These tests are intermittently non-deterministic due to the way --- random chain sampling works with our test harnesses. --- -tests :: RocksDb -> TestTree -tests rdb = testGroup "Chainweb.Test.Pact4.RemotePactTest" - [ withResourceT (withNodeDbDirs rdb nNodes) $ \dbDirs -> - withResourceT (withNodesAtLatestBehavior v id =<< liftIO dbDirs) $ \net -> - let cenv = _getServiceClientEnv <$> net - iot = toTxCreationTime @Integer <$> getCurrentTimeIntegral - - in independentSequentialTestGroup "remote pact tests" - [ withResourceT (liftIO $ join $ withRequestKeys <$> iot <*> cenv) $ \reqkeys -> golden "remote-golden" $ - join $ responseGolden <$> cenv <*> reqkeys - , testCaseSteps "remote spv" $ \step -> - join $ spvTest <$> iot <*> cenv <*> pure step - , testCaseSteps "remote eth spv" $ \step -> - join $ ethSpvTest <$> iot <*> cenv <*> pure step - , testCaseSteps "/send reports validation failure" $ \step -> - join $ sendValidationTest <$> iot <*> cenv <*> pure step - , testCase "/poll reports badlisted txs" $ - join $ pollingBadlistTest <$> cenv - , testCase "trivialLocalCheck" $ - join $ localTest <$> iot <*> cenv - , testCase "localChainData" $ - join $ localChainDataTest <$> iot <*> cenv - , testCaseSteps "transaction size gas tests" $ \step -> - join $ txTooBigGasTest <$> iot <*> cenv <*> pure step - , testCaseSteps "genesisAllocations" $ \step -> - join $ allocationTest <$> iot <*> cenv <*> pure step - , testCaseSteps "caplist TRANSFER and FUND_TX test" $ \step -> - join $ caplistTest <$> iot <*> cenv <*> pure step - , testCaseSteps "local continuation test" $ \step -> - join $ localContTest <$> iot <*> cenv <*> pure step - , testCaseSteps "poll confirmation depth test" $ \step -> - join $ pollingConfirmDepth <$> iot <*> cenv <*> pure step - , testCaseSteps "/poll rejects keys of incorrect length" $ \step -> - join $ pollBadKeyTest <$> cenv <*> pure step - , testCaseSteps "local preflight sim test" $ \step -> - join $ localPreflightSimTest <$> iot <*> cenv <*> pure step - - , testCaseSteps "poll correct results test" $ \step -> - join $ pollingCorrectResults <$> iot <*> cenv <*> pure step - , testCase "webauthn sig" $ - join $ webAuthnSignatureTest <$> iot <*> cenv - ] - , testCase "txlogsCompactionTest" $ txlogsCompactionTest rdb - , testCase "invalid command test" $ invalidCommandTest rdb - , testCase "db error test" $ dbErrorTest rdb - ] - -responseGolden :: ClientEnv -> RequestKeys -> IO LBS.ByteString -responseGolden cenv rks = do - PollResponses theMap <- polling v cid cenv rks ExpectPactResult - let values = mapMaybe (\rk -> _crResult <$> HM.lookup rk theMap) - (NEL.toList $ _rkRequestKeys rks) - return $ foldMap J.encode values - --- this tests the exact content of dberrors which make it into outputs -dbErrorTest :: RocksDb -> IO () -dbErrorTest rdb = runResourceT $ do - nodeDbDirs <- withNodeDbDirs rdb nNodes - net <- withNodesAtLatestBehavior v id nodeDbDirs - liftIO $ do - iot <- liftIO $ toTxCreationTime @Integer <$> getCurrentTimeIntegral - let cenv = _getServiceClientEnv net - cmd <- liftIO $ buildTextCmd "err" v - $ set cbSigners [mkEd25519Signer' sender00 []] - $ set cbTTL defaultMaxTTL - $ set cbCreationTime iot - $ set cbChainId cid - $ set cbGasLimit 70000 - $ set cbRPC (mkExec - (T.unlines - [ "(namespace 'free)" - , "(module m G" - , "(defcap G () true)" - , "(defschema s i:integer)" - , "(deftable tbl:{s})" - , "(defun f () (update tbl 'x {'i: 4})))" - , "(create-table tbl)" - , "(f)" - ] - ) - (mkKeySetData "sender00" [sender00])) - $ defaultCmd - let expectedMessage = - ": Failure: Database exception: {\"tag\":\"PactInternalError\",\"contents\":\"checkInsertIsOK: Update: no row found for key x\"}" - r <- local v cid cenv cmd - assertEqual "something" - (over _Left show $ _pactResult $ _crResult r) - (Left expectedMessage) - -invalidCommandTest :: RocksDb -> IO () -invalidCommandTest rdb = runResourceT $ do - nodeDbDirs <- withNodeDbDirs rdb nNodes - net <- withNodesAtLatestBehavior v id nodeDbDirs - let cenv = _getServiceClientEnv net - - let sendExpect :: (HasCallStack) => [Command Text] -> (Text -> Bool) -> ResourceT IO () - sendExpect txs p = do - e <- liftIO $ flip runClientM cenv $ - pactSendApiClient v cid $ SubmitBatch $ NEL.fromList txs - case e of - Right _ -> do - liftIO $ assertFailure "Expected an error message from /send, but didn't get it" - Left clientErr -> do - case clientErr of - FailureResponse _request resp -> do - let respBody = T.decodeUtf8 (LBS.toStrict (responseBody resp)) - if p respBody - then pure () - else liftIO $ assertFailure $ "Predicate failed, responseBody was: " ++ T.unpack respBody - _ -> do - liftIO $ assertFailure "Expected 'FailureResponse', got a different ClientError" - - iot <- liftIO $ toTxCreationTime @Integer <$> getCurrentTimeIntegral - - let prefix i cmd = "One or more transactions were invalid: Transaction " <> sshow (_cmdHash cmd) <> " at index " <> sshow @Int i <> " failed with: " - - cmdParseFailure <- liftIO $ buildTextCmd "bare-command" v - $ set cbSigners [mkEd25519Signer' sender00 []] - $ set cbTTL defaultMaxTTL - $ set cbCreationTime iot - $ set cbChainId cid - $ set cbRPC (mkExec "(+ 1" (mkKeySetData "sender00" [sender00])) - $ defaultCmd - -- Why does pact just return 'mzero' here... - sendExpect [cmdParseFailure] (== (prefix 0 cmdParseFailure <> "Pact parse error: Failed reading: mzero")) - - cmdInvalidPayloadHash <- liftIO $ do - bareCmd <- buildTextCmd "bare-command" v - $ set cbSigners [mkEd25519Signer' sender00 []] - $ set cbTTL defaultMaxTTL - $ set cbCreationTime iot - $ set cbChainId cid - $ set cbRPC (mkExec "(+ 1 2)" (mkKeySetData "sender00" [sender00])) - $ defaultCmd - pure $ bareCmd - { _cmdHash = Pact.hash "fakehash" - } - sendExpect [cmdInvalidPayloadHash] (== (prefix 0 cmdInvalidPayloadHash <> "Invalid transaction hash")) - - cmdSignersSigsLengthMismatch1 <- liftIO $ do - bareCmd <- buildTextCmd "bare-command" v - $ set cbSigners [mkEd25519Signer' sender00 []] - $ set cbTTL defaultMaxTTL - $ set cbCreationTime iot - $ set cbChainId cid - $ set cbRPC (mkExec "(+ 1 2)" (mkKeySetData "sender00" [sender00])) - $ defaultCmd - pure $ bareCmd - { _cmdSigs = [] - } - sendExpect [cmdSignersSigsLengthMismatch1] (== (prefix 0 cmdSignersSigsLengthMismatch1 <> "Invalid transaction sigs: The number of signers and signatures do not match. Number of signers: 1. Number of signatures: 0.")) - - cmdSignersSigsLengthMismatch2 <- liftIO $ do - bareCmd <- buildTextCmd "bare-command" v - $ set cbSigners [] - $ set cbTTL defaultMaxTTL - $ set cbCreationTime iot - $ set cbChainId cid - $ set cbRPC (mkExec "(+ 1 2)" (mkKeySetData "sender00" [sender00])) - $ defaultCmd - pure $ bareCmd - { -- This is an invalid ED25519 signature, but length signers == length signatures is checked first - _cmdSigs = [ED25519Sig "fakeSig"] - } - sendExpect [cmdSignersSigsLengthMismatch2] (== (prefix 0 cmdSignersSigsLengthMismatch2 <> "Invalid transaction sigs: The number of signers and signatures do not match. Number of signers: 0. Number of signatures: 1.")) - - -- TODO: It's hard to test for invalid schemes, because it's baked into - -- chainwebversion. - - -- TODO: It's hard to test for an invalid WebAuthn signer prefix, because it's - -- baked into chainweb version. - - cmdInvalidUserSig <- liftIO $ do - bareCmd <- buildTextCmd "bare-command" v - $ set cbSigners [mkEd25519Signer' sender00 []] - $ set cbTTL defaultMaxTTL - $ set cbCreationTime iot - $ set cbChainId cid - $ set cbRPC (mkExec "(+ 1 2)" (mkKeySetData "sender00" [sender00])) - $ defaultCmd - pure $ bareCmd - { _cmdSigs = [ED25519Sig "fakeSig"] - } - sendExpect [cmdInvalidUserSig] (== (prefix 0 cmdInvalidUserSig <> "Invalid transaction sigs: The signature at position 0 is invalid: failed to parse ed25519 signature: invalid bytestring size.")) - - cmdGood <- liftIO $ buildTextCmd "good-command" v - $ set cbSigners [mkEd25519Signer' sender00 []] - $ set cbTTL defaultMaxTTL - $ set cbCreationTime iot - $ set cbChainId cid - $ set cbRPC (mkExec "(+ 1 2)" (mkKeySetData "sender00" [sender00])) - $ defaultCmd - -- Test that [badCmd, goodCmd] fails on badCmd, and the batch is rejected. - -- We just re-use a previously built bad cmd. - sendExpect [cmdInvalidUserSig, cmdGood] (== (prefix 0 cmdInvalidUserSig <> "Invalid transaction sigs: The signature at position 0 is invalid: failed to parse ed25519 signature: invalid bytestring size.")) - -- Test that [goodCmd, badCmd] fails on badCmd, and the batch is rejected. - -- Order matters, and the error message also indicates the position of the - -- failing tx. - -- We just re-use a previously built bad cmd. - sendExpect [cmdGood, cmdInvalidUserSig] (== (prefix 1 cmdInvalidUserSig <> "Invalid transaction sigs: The signature at position 0 is invalid: failed to parse ed25519 signature: invalid bytestring size.")) - --- | Check that txlogs don't problematically access history --- post-compaction. --- --- At a high level, the test does this: --- - Submits a tx that creates a module with a table named `persons`. --- --- This module exposes a few functions for reading, inserting, --- and overwriting rows to the `persons` table. --- --- The tx also inserts some people into `persons` for --- some initial state. --- --- This module also exposes a way to access the `txlogs` --- of the `persons` table (what this test is concerned with). --- --- - Submits a tx that overwrites a row in the --- `persons` table. --- --- - Compacts to the latest blockheight on each chain. This should --- get rid of any out-of-date rows. --- --- - Submits a /local tx that reads the `txlogs` on the `persons` --- table. Call this `txLogs`. --- --- If this read fails, Pact is doing something problematic! --- --- If this read doesn't fail, we need to check that `txLogs` --- matches the latest pact state post-compaction. Because --- compaction sweeps away the out-of-date rows, they shouldn't --- appear in the `txLogs` anymore, and the two should be equivalent. -txlogsCompactionTest :: RocksDb -> IO () -txlogsCompactionTest rdb = runResourceT $ do - nodeDbDirs <- withNodeDbDirs rdb nNodes - -- This looks up the pactDbDir for node 0. This is - -- kind of a hack, because there is only one node in - -- this test. However, it doesn't matter much, because - -- we are dealing with both submitting /local txs - -- and compaction, so picking an arbitrary node - -- to run these two operations on is fine. - let srcPactDir = nodePactDbDir (head nodeDbDirs) - iot <- liftIO $ toTxCreationTime @Integer <$> getCurrentTimeIntegral - let cmd :: Text -> CmdBuilder - cmd tx = do - set cbSigners [mkEd25519Signer' sender00 []] - $ set cbTTL defaultMaxTTL - $ set cbCreationTime iot - $ set cbChainId cid - $ set cbRPC (mkExec tx (mkKeySetData "sender00" [sender00])) - $ defaultCmd - - nonceSupply <- liftIO $ newIORef @Word 1 -- starts at 1 since 0 is always the create-table tx - let nextNonce = liftIO $ do - cur <- readIORef nonceSupply - modifyIORef' nonceSupply (+ 1) - pure cur - - let submitAndCheckTx cenv tx = do - submitResult <- flip runClientM cenv $ - pactSendApiClient v cid $ SubmitBatch $ NEL.fromList [tx] - case submitResult of - Left err -> do - assertFailure $ "Error when sending tx: " ++ show err - Right rks -> do - PollResponses m <- polling v cid cenv rks ExpectPactResult - case HM.lookup (NEL.head (_rkRequestKeys rks)) m of - Just cr -> do - case _crResult cr of - PactResult (Left err) -> do - assertFailure $ "validation failure on tx: " ++ show err - PactResult _ -> do - pure () - Nothing -> do - assertFailure "impossible" - - -- phase 1: start nodes and populate tables - liftIO $ runResourceT $ do - net <- withNodesAtLatestBehavior v id nodeDbDirs - let cenv = _getServiceClientEnv net - - createTableTx <- liftIO $ buildTextCmd "create-table-persons" v - $ set cbGasLimit 300_000 - $ cmd - $ T.unlines - [ "(namespace 'free)" - , "(module m0 G" - , " (defcap G () true)" - , " (defschema person" - , " name:string" - , " age:integer" - , " )" - , " (deftable persons:{person})" - , " (defun read-persons (k) (read persons k))" - , " (defun insert-persons (id name age) (insert persons id { 'name:name, 'age:age }))" - , " (defun write-persons (id name age) (write persons id { 'name:name, 'age:age }))" - , " (defun persons-txlogs (i) (map (txlog persons) (txids persons i)))" - , ")" - , "(create-table persons)" - , "(insert-persons \"A\" \"Lindsey Lohan\" 42)" - , "(insert-persons \"B\" \"Nico Robin\" 30)" - , "(insert-persons \"C\" \"chessai\" 420)" - ] - - liftIO $ submitAndCheckTx cenv createTableTx - - let createWriteTx :: Word -> IO (Command Text) - createWriteTx n = liftIO $ do - let gasLimit = 500 - buildTextCmd ("test-write-" <> sshow n) v - $ set cbGasLimit gasLimit - $ cmd - $ "(free.m0.write-persons \"C\" \"chessai\" 69)" - - liftIO $ submitAndCheckTx cenv =<< createWriteTx =<< nextNonce - - -- phase 2: compact - targetPactDir <- withPactDir 0 - liftIO $ Sigma.withDefaultLogger Error $ \logger -> do - Backend.withSqliteDb cid logger srcPactDir False $ \srcDb -> do - Backend.withSqliteDb cid logger targetPactDir False $ \targetDb -> do - sigmaCompact srcDb targetDb =<< getLatestBlockHeight srcDb - - let newNodeDbDirs = (head nodeDbDirs) { nodePactDbDir = targetPactDir } : tail nodeDbDirs - - -- phase 3: restart nodes, query txlogs - liftIO $ runResourceT $ do - net <- withNodesAtLatestBehavior v (configFullHistoricPactState .~ False) newNodeDbDirs - let cenv = _getServiceClientEnv net - - let createTxLogsTx :: Word -> IO (Command Text) - createTxLogsTx n = liftIO $ do - -- cost is about 310k. - -- cost = flatCost(map) + flatCost(txIds) + numTxIds * (costOf(txlog)) + C - -- = 4 + 100_000 + 2 * 100_000 + C - -- = 300_004 + C - -- Note there are two transactions that write to `persons`, which is - -- why `numTxIds` = 2 (and not the number of rows). - let gasLimit = 310_000 - buildTextCmd ("test-txlogs-" <> sshow n) v - $ set cbGasLimit gasLimit - $ cmd - $ "(free.m0.persons-txlogs 0)" - - - let -- This can't be a Map because the RowKeys aren't - -- necessarily unique, unlike in `getLatestPactState`. - crGetTxLogs :: CommandResult Hash -> IO [(RowKey, A.Value)] - crGetTxLogs cr = do - e <- runExceptT $ do - pv0 <- except (first show (_pactResult (_crResult cr))) - case pv0 of - PList arr -> do - fmap concat $ forM arr $ \pv -> do - txLogs <- except (A.eitherDecode @[TxLog A.Value] (J.encode pv)) - pure $ flip map txLogs $ \txLog -> - (RowKey (_txKey txLog), _txValue txLog) - _ -> do - throwError "expected outermost PList when decoding TxLogs" - case e of - Left err -> do - assertFailure $ "crGetTxLogs failed: " ++ err - Right txlogs -> do - pure txlogs - - txLogs <- liftIO $ crGetTxLogs =<< local v cid cenv =<< createTxLogsTx =<< nextNonce - - let getLatestState :: IO (M.Map RowKey RowData) - getLatestState = Sigma.withDefaultLogger Error $ \logger -> do - Backend.withSqliteDb cid logger targetPactDir False $ \db -> do - st <- Utils.getLatestPactState db - case M.lookup "free.m0_persons" st of - Just ps -> fmap M.fromList $ forM (M.toList ps) $ \(rkBytes, rdBytes) -> do - let rk = RowKey (T.decodeUtf8 rkBytes) - case A.eitherDecodeStrict' @RowData rdBytes of - Left err -> do - assertFailure $ "Failed decoding rowdata: " ++ err - Right rd -> do - pure (rk, rd) - Nothing -> error "getting state of free.m0_persons failed" - - latestState <- liftIO getLatestState - liftIO $ assertEqual - "txlogs match latest state" - (map (\(rk, rd) -> (rk, J.toJsonViaEncode (_rdData rd))) (M.toAscList latestState)) - (L.sort txLogs) - -localTest :: Pact.TxCreationTime -> ClientEnv -> IO () -localTest t cenv = do - mv <- newMVar 0 - SubmitBatch batch <- testBatch t mv gp - let cmd = head $ toList batch - res <- local v (unsafeChainId 0) cenv cmd - let PactResult e = _crResult res - assertEqual "expect /local to return gas for tx" (_crGas res) 5 - assertEqual "expect /local to succeed and return 3" e (Right (PLiteral $ LDecimal 3)) - -localContTest :: Pact.TxCreationTime -> ClientEnv -> (String -> IO ()) -> IO () -localContTest t cenv step = do - - step "execute /send with initial pact continuation tx" - cmd1 <- firstStep - rks <- sending v cid' cenv (SubmitBatch $ pure cmd1) - - step "check /poll responses to extract pact id for continuation" - PollResponses m <- polling v cid' cenv rks ExpectPactResult - pid <- case _rkRequestKeys rks of - rk NEL.:| [] -> maybe (assertFailure "impossible") (return . _pePactId) - $ HM.lookup rk m >>= _crContinuation - _ -> assertFailure "continuation did not succeed" - - step "execute /local continuation dry run" - cmd2 <- secondStep pid - r <- _pactResult . _crResult <$> local v cid' cenv cmd2 - case r of - Left err -> assertFailure (show err) - Right (PLiteral (LDecimal a)) | a == 2 -> return () - Right p -> assertFailure $ "unexpected cont return value: " ++ show p - - where - cid' = unsafeChainId 0 - tx = - "(namespace 'free)(module m G (defcap G () true) (defpact p () (step (yield { \"a\" : (+ 1 1) })) (step (resume { \"a\" := a } a))))(free.m.p)" - firstStep = do - buildTextCmd "nonce-cont-1" v - $ set cbSigners [mkEd25519Signer' sender00 []] - $ set cbCreationTime t - $ set cbGasLimit 70_000 - $ set cbRPC (mkExec' tx) - $ defaultCmd - - secondStep pid = do - buildTextCmd "nonce-cont-2" v - $ set cbSigners [mkEd25519Signer' sender00 []] - $ set cbCreationTime t - $ set cbRPC (mkCont (mkContMsg pid 1)) - $ defaultCmd - -pollingConfirmDepth :: Pact.TxCreationTime -> ClientEnv -> (String -> IO ()) -> IO () -pollingConfirmDepth t cenv step = do - - step "/send transactions" - cmd1 <- firstStep tx - cmd2 <- firstStep tx' - rks <- sending v cid' cenv (SubmitBatch $ cmd1 NEL.:| [cmd2]) - - step "/poll for the transactions until they appear" - - PollResponses m <- pollingWithDepth v cid' cenv rks (Just $ ConfirmationDepth 10) ExpectPactResult - afterPolling <- getCurrentBlockHeight v cenv cid' - -- here we rely on both txs being in the same block. - let txHeight = the - (m ^.. to HM.elems . folded . crMetaData . _Just . key "blockHeight" . _Integer) - - assertBool "there are two command results" $ length (HM.keys m) == 2 - - -- we are checking that we have waited exactly 10 blocks using /poll for the transaction - -- this is technically a race, because a block could've been made after the poll response - -- and before we fetch the current height; so we give it some slack. - assertBool "the difference between heights should be within 1 block of the confirmation depth" - (afterPolling - int txHeight `elem` [10..20]) - where - cid' = unsafeChainId 0 - tx = - "42" - tx' = - "43" - firstStep transaction = do - buildTextCmd "nonce-cont-1" v - $ set cbSigners [mkEd25519Signer' sender00 []] - $ set cbCreationTime t - $ set cbGasLimit 70_000 - $ set cbRPC (mkExec' transaction) - $ defaultCmd - -pollingCorrectResults :: Pact.TxCreationTime -> ClientEnv -> (String -> IO ()) -> IO () -pollingCorrectResults t cenv step = do - step "/send transactions" - - -- submit the first one, then poll to confirm its in a block - cmd1 <- stepTx tx - rks1@(RequestKeys (rk1 NEL.:| [])) <- sending v cid' cenv (SubmitBatch $ cmd1 NEL.:| []) - PollResponses _ <- pollingWithDepth v cid' cenv rks1 (Just $ ConfirmationDepth 10) ExpectPactResult - - -- submit the second... - cmd2 <- stepTx tx' - RequestKeys (rk2 NEL.:| []) <- sending v cid' cenv (SubmitBatch $ cmd2 NEL.:| []) - - -- now request both. the second transaction will by definition go into another block. - -- do it in two different orders, and ensure it works either way. - let - together1 = RequestKeys $ rk1 NEL.:| [rk2] - together2 = RequestKeys $ rk2 NEL.:| [rk1] - - PollResponses resp1 <- polling v cid' cenv together1 ExpectPactResult - PollResponses resp2 <- polling v cid' cenv together2 ExpectPactResult - - assertEqual "the two responses should be the same" resp1 resp2 - where - cid' = unsafeChainId 0 - (tx, tx') = ("42", "43") - - stepTx transaction = do - buildTextCmd "nonce-cont-2" v - $ set cbSigners [mkEd25519Signer' sender00 []] - $ set cbCreationTime t - $ set cbGasLimit 70_000 - $ set cbRPC (mkExec' transaction) - $ defaultCmd - -localChainDataTest :: Pact.TxCreationTime -> ClientEnv -> IO () -localChainDataTest t cenv = do - mv <- newMVar (0 :: Int) - SubmitBatch batch <- localTestBatch mv - let cmd = head $ toList batch - sid <- mkChainId v maxBound 0 - res <- flip runClientM cenv $ pactLocalApiClient v sid cmd - checkCommandResult res - where - - checkCommandResult (Left e) = throwM $ LocalFailure (show e) - checkCommandResult (Right cr) = - let (PactResult e) = _crResult cr - in mapM_ expectedResult e - - localTestBatch mnonce = modifyMVar mnonce $ \(!nn) -> do - let nonce = "nonce" <> sshow nn - kps <- testKeyPairs sender00 Nothing - c <- Pact.mkExec "(chain-data)" A.Null (pm t) kps [] (Just vNetworkId) (Just nonce) - pure (succ nn, SubmitBatch (pure c)) - where - pm = Pact.PublicMeta pactCid "sender00" 1000 0.1 defaultMaxTTL - - expectedResult (PObject (ObjectMap m)) = do - assert' "chain-id" (PLiteral (LString $ chainIdToText cid)) - assert' "gas-limit" (PLiteral (LInteger 1000)) - assert' "gas-price" (PLiteral (LDecimal 0.1)) - assert' "sender" (PLiteral (LString "sender00")) - where - assert' name value = assertEqual name (M.lookup (FieldKey (T.pack name)) m) (Just value) - expectedResult _ = assertFailure "Didn't get back an object map!" - -localPreflightSimTest :: Pact.TxCreationTime -> ClientEnv -> (String -> IO ()) -> IO () -localPreflightSimTest t cenv step = do - mv <- newMVar (0 :: Int) - sid <- mkChainId v maxBound 0 - let sigs = [mkEd25519Signer' sender00 []] - - step "Execute preflight /local tx - preflight known /send success" - let psid = Pact.ChainId $ chainIdToText sid - psigs <- testKeyPairs sender00 Nothing - cmd0 <- mkRawTx mv psid psigs - runLocalPreflightClient sid cenv cmd0 >>= \case - Right Pact4LocalResultWithWarns{} -> pure () - Right r -> assertFailure $ "unexpected local result: " <> T.unpack (J.getJsonText $ J.encodeJsonText r) - Left e -> assertFailure $ show e - - step "Execute preflight /local tx - preflight+signoverify known /send success" - cmd0' <- mkRawTx mv psid psigs - cr <- runClientM - (pactLocalWithQueryApiClient v sid - (Just PreflightSimulation) (Just NoVerify) Nothing cmd0') cenv - void $ case cr of - Left e -> assertFailure $ show e - Right{} -> pure () - - step "Execute preflight /local tx - unparseable chain id" - sigs0 <- testKeyPairs sender00 Nothing - cmd1 <- mkRawTx mv (Pact.ChainId "fail") sigs0 - runClientFailureAssertion sid cenv cmd1 "Unparseable transaction chain id" - - step "Execute preflight /local tx - chain id mismatch" - let fcid = unsafeChainId maxBound - cmd2 <- mkTx v mv =<< mkCmdBuilder sigs fcid 1000 gp - runClientFailureAssertion sid cenv cmd2 "Chain id mismatch" - - step "Execute preflight /local tx - tx gas limit too high" - cmd3 <- mkTx v mv =<< mkCmdBuilder sigs sid 100000000000000 gp - runClientFailureAssertion sid cenv cmd3 - "Transaction Gas limit exceeds block gas limit" - - step "Execute preflight /local tx - tx gas price precision too high" - cmd4 <- mkTx v mv =<< mkCmdBuilder sigs sid 1000 0.00000000000000001 - runClientFailureAssertion sid cenv cmd4 - "Gas price decimal precision too high" - - step "Execute preflight /local tx - network id mismatch" - cmd5 <- mkTx Mainnet01 mv =<< mkCmdBuilder sigs sid 1000 gp - runClientFailureAssertion sid cenv cmd5 "Network id mismatch" - - step "Execute preflight /local tx - too many sigs" - let pcid = Pact.ChainId $ chainIdToText sid - sigs1' <- testKeyPairs sender00 Nothing >>= \case - [ks] -> pure $ replicate 101 ks - _ -> assertFailure "/local test keypair construction failed" - - cmd6 <- mkRawTx mv pcid sigs1' - runClientFailureAssertion sid cenv cmd6 "Signature list size too big" - - step "Execute preflight /local tx - collect warnings" - cmd7 <- mkRawTx' mv pcid sigs0 "(+ 1 2.0)" - - currentBlockHeight <- getCurrentBlockHeight v cenv sid - runLocalPreflightClient sid cenv cmd7 >>= \case - Right (Pact4LocalResultWithWarns cr' ws) -> do - let crbh :: Integer = fromIntegral $ fromMaybe 0 $ crGetBlockHeight cr' - expectedbh = 1 + fromIntegral currentBlockHeight - assertBool "Preflight's metadata should have increment block height" - -- we don't control the node in remote tests and the data can get oudated, - -- to make test less flaky we use a small range for validation - (abs (expectedbh - crbh) <= 2) - - case ws of - [w] | "decimal/integer operator overload" `T.isInfixOf` w -> - pure () - ws' -> assertFailure $ "Incorrect warns: " ++ show ws' - Right r -> assertFailure $ "invalid local result: " <> T.unpack (J.getJsonText $ J.encodeJsonText r) - Left e -> assertFailure $ show e - - let rewindDepth = 10 - currentBlockHeight' <- getCurrentBlockHeight v cenv sid - runLocalPreflightClientWithDepth sid cenv cmd7 rewindDepth >>= \case - Right (Pact4LocalResultWithWarns cr' ws) -> do - let crbh :: Integer = fromIntegral $ fromMaybe 0 $ crGetBlockHeight cr' - expectedbh = toInteger $ 1 + (fromIntegral currentBlockHeight') - rewindDepth - assertBool "Preflight's metadata block height should reflect the rewind depth" - -- we don't control the node in remote tests and the data can get oudated, - -- to make test less flaky we use a small range for validation - (abs (expectedbh - crbh) <= 2) - - case ws of - [w] | "decimal/integer operator overload" `T.isInfixOf` w -> - pure () - ws' -> assertFailure $ "Incorrect warns: " ++ show ws' - Right r -> assertFailure $ "invalid local result: " <> T.unpack (J.getJsonText $ J.encodeJsonText r) - Left e -> assertFailure $ show e - where - runLocalPreflightClient sid e cmd = flip runClientM e $ - pactLocalWithQueryApiClient v sid - (Just PreflightSimulation) - (Just Verify) Nothing cmd - - runLocalPreflightClientWithDepth sid e cmd d = flip runClientM e $ - pactLocalWithQueryApiClient v sid - (Just PreflightSimulation) - (Just Verify) (Just $ RewindDepth d) cmd - - runClientFailureAssertion sid e cmd msg = - runLocalPreflightClient sid e cmd >>= \case - Left err -> checkClientErrText err msg - r -> assertFailure $ "Unintended success: " ++ either show (T.unpack . J.getJsonText . J.encodeJsonText) r - - checkClientErrText (FailureResponse _ (Response _ _ _ body)) e - | BS.isInfixOf e $ LBS.toStrict body = pure () - checkClientErrText _ e = assertFailure $ show e - - -- cmd builder is more correct by construction than - -- would allow for us to modify the chain id to something - -- unparsable. Hence we need to do this in the unparsable - -- chain id case and nowhere else. - mkRawTx mv pcid kps = mkRawTx' mv pcid kps "(+ 1 2)" - - mkRawTx' mv pcid kps code = modifyMVar mv $ \(nn :: Int) -> do - let nonce = "nonce" <> sshow nn - pm = Pact.PublicMeta pcid "sender00" 1000 0.1 defaultMaxTTL - - c <- Pact.mkExec code A.Null (pm t) kps [] (Just vNetworkId) (Just nonce) - pure (succ nn, c) - - mkCmdBuilder sigs pcid limit price = do - pure - $ set cbGasLimit limit - $ set cbGasPrice price - $ set cbChainId pcid - $ set cbSigners sigs - $ set cbCreationTime t - $ set cbRPC (mkExec' "(+ 1 2)") - $ defaultCmd - - mkTx v' mv tx = modifyMVar mv $ \nn -> do - let n = "nonce-" <> sshow nn - tx' <- buildTextCmd n v' tx - pure (succ nn, tx') - --- FIXME: Polling no longer checks request key validity, so this test probably does not pass anymore. -pollingBadlistTest :: ClientEnv -> IO () -pollingBadlistTest cenv = do - let rks = RequestKeys $ NEL.fromList [pactDeadBeef] - sid <- mkChainId v maxBound 0 - void $ polling v sid cenv rks ExpectPactError - --- | Check request key length validation in the /poll endpoints --- -pollBadKeyTest :: ClientEnv -> (String -> IO ()) -> IO () -pollBadKeyTest cenv step = do - let tooBig = toRk $ BS.replicate 33 0x3d - tooSmall = toRk $ BS.replicate 31 0x3d - - sid <- liftIO $ mkChainId v maxBound 0 - - step "RequestKeys of length > 32 fail fast" - runClientM (pactPollWithQueryApiClient v sid Nothing (pact4Poll $ Poll tooBig)) cenv >>= \case - Left _ -> return () - Right (Pact5.PollResponse r) -> assertFailure $ "Poll succeeded with response: " <> show r - - step "RequestKeys of length < 32 fail fast" - runClientM (pactPollWithQueryApiClient v sid Nothing (pact4Poll $ Poll tooSmall)) cenv >>= \case - Left _ -> return () - Right (Pact5.PollResponse r) -> assertFailure $ "Poll succeeded with response: " <> show r - where - toRk = (NEL.:| []) . RequestKey . Hash . SB.toShort - -sendValidationTest :: Pact.TxCreationTime -> ClientEnv -> (String -> IO ()) -> IO () -sendValidationTest t cenv step = do - step "check sending poisoned TTL batch" - mv <- newMVar 0 - SubmitBatch batch1 <- - testBatch' t 10_000 mv gp - SubmitBatch batch2 <- - testBatch' (toTxCreationTime (Time (TimeSpan 0) :: Time Micros)) 2 mv gp - let batch = SubmitBatch $ batch1 <> batch2 - expectSendFailure "Transaction time-to-live is expired" $ - flip runClientM cenv $ - pactSendApiClient v cid batch - - step "check sending mismatched chain id" - cid0 <- mkChainId v maxBound 0 - batch3 <- testBatch'' "40" t 20_000 mv gp - expectSendFailure "Transaction metadata (chain id, chainweb version) conflicts with this endpoint" $ - flip runClientM cenv $ - pactSendApiClient v cid0 batch3 - - step "check insufficient gas" - batch4 <- testBatch' t 10_000 mv 10_000_000_000 - expectSendFailure - "Attempt to buy gas failed with: (enforce (<= amount balance) \\\"...: Failure: Tx Failed: Insufficient funds\"" $ - flip runClientM cenv $ - pactSendApiClient v cid batch4 - - step "check bad sender" - batch5 <- mkBadGasTxBatch "(+ 1 2)" "invalid-sender" sender00 Nothing - expectSendFailure - "Attempt to buy gas failed with: (read coin-table sender): Failure: Tx Failed: read: row not found: invalid-sender" $ - flip runClientM cenv $ - pactSendApiClient v cid0 batch5 - - where - mkBadGasTxBatch code senderName senderKeyPair capList = do - ks <- testKeyPairs senderKeyPair capList - let pm = Pact.PublicMeta (Pact.ChainId "0") senderName 100_000 0.01 defaultMaxTTL t - let cmd (n :: Int) = liftIO $ Pact.mkExec code A.Null pm ks [] (Just vNetworkId) (Just $ sshow n) - cmds <- mapM cmd (0 NEL.:| [1..5]) - return $ SubmitBatch cmds - -expectSendFailure - :: NFData a - => NFData b - => Show a - => Show b - => String - -> IO (Either b a) - -> Assertion -expectSendFailure expectErr act = tryAllSynchronous act >>= \case - (Right (Left e)) -> test $ show e - (Right (Right out)) -> assertFailure $ "expected exception on bad tx, got: " <> show out - (Left e) -> test $ show e - where - test er = assertSatisfies ("Expected message containing '" ++ expectErr ++ "'") er (L.isInfixOf expectErr) - -ethSpvTest :: Pact.TxCreationTime -> ClientEnv -> (String -> IO ()) -> IO () -ethSpvTest t cenv step = do - - req <- A.eitherDecodeFileStrict' "test/pact/eth-spv-request.json" >>= \case - Left e -> assertFailure $ "failed to decode test/pact/eth-spv-request: " <> e - Right x -> return (x :: EthSpvRequest) - - c <- mkChainId v maxBound 1 - r <- flip runClientM cenv $ do - - void $ liftIO $ step "ethSpvApiClient: submit eth proof request" - proof <- liftIO $ ethSpv v c cenv req - - batch <- liftIO $ mkTxBatch proof - - void $ liftIO $ step "sendApiClient: submit batch for proof validation" - rks <- liftIO $ sending v c cenv batch - - void $ liftIO $ step "pollApiClient: poll until key is found" - void $ liftIO $ polling v c cenv rks ExpectPactResult - - return () - - case r of - Left e -> assertFailure $ "eth proof roundtrip failed: " <> sshow e - Right _ -> return () - where - - mkTxBatch proof = do - ks <- liftIO $ testKeyPairs sender00 Nothing - let pm = Pact.PublicMeta (Pact.ChainId "1") "sender00" 100_000 0.01 defaultMaxTTL t - cmd <- liftIO $ Pact.mkExec txcode (txdata proof) pm ks [] (Just vNetworkId) (Just "1") - return $ SubmitBatch (pure cmd) - - txcode = "(verify-spv 'ETH (read-msg))" - - txdata proof = A.toJSON proof - -spvTest :: Pact.TxCreationTime -> ClientEnv -> (String -> IO ()) -> IO () -spvTest t cenv step = do - batch <- mkTxBatch - sid <- mkChainId v maxBound 1 - r <- flip runClientM cenv $ do - - void $ liftIO $ step "sendApiClient: submit batch" - rks <- liftIO $ sending v sid cenv batch - - void $ liftIO $ step "pollApiClient: poll until key is found" - void $ liftIO $ polling v sid cenv rks ExpectPactResult - - void $ liftIO $ step "spvApiClient: submit request key" - liftIO $ spv v sid cenv (SpvRequest (NEL.head $ _rkRequestKeys rks) tid) - - case r of - Left e -> assertFailure $ "output proof failed: " <> sshow e - Right _ -> return () - where - tid = Pact.ChainId "2" - - mkTxBatch = do - ks <- liftIO $ testKeyPairs sender00 - (Just [mkGasCap, mkXChainTransferCap "sender00" "sender01" 1.0 "2"]) - let pm = Pact.PublicMeta (Pact.ChainId "1") "sender00" 100_000 0.01 defaultMaxTTL t - cmd1 <- liftIO $ Pact.mkExec txcode txdata pm ks [] (Just vNetworkId) (Just "1") - cmd2 <- liftIO $ Pact.mkExec txcode txdata pm ks [] (Just vNetworkId) (Just "2") - return $ SubmitBatch (pure cmd1 <> pure cmd2) - - txcode = T.unlines - [ "(coin.transfer-crosschain" - , " 'sender00" - , " 'sender01" - , " (read-keyset 'sender01-keyset)" - , " (read-msg 'target-chain-id)" - , " 1.0)" - ] - - txdata = A.object - [ "sender01-keyset" A..= [fst sender01] - , "target-chain-id" A..= J.toJsonViaEncode tid - ] - -txTooBigGasTest :: Pact.TxCreationTime -> ClientEnv -> (String -> IO ()) -> IO () -txTooBigGasTest t cenv step = do - - let - runSend batch expectation = try @IO @PactTestFailure $ do - void $ step "sendApiClient: submit transaction" - rks <- sending v sid cenv batch - - void $ step "pollApiClient: polling for request key" - PollResponses resp <- polling v sid cenv rks expectation - return (HM.lookup (NEL.head $ _rkRequestKeys rks) resp) - - runLocal (SubmitBatch cmds) = do - void $ step "localApiClient: submit transaction" - local v sid cenv (head $ toList cmds) - - -- batch with big tx and insufficient gas - batch0 <- mkTxBatch txcode0 A.Null 1 (Just "0") - - -- batch to test that gas for tx size discounted from the total gas supply - batch1 <- mkTxBatch txcode1 A.Null 5 (Just "1") - - res0Send <- runSend batch0 ExpectPactError - res1Send <- runSend batch1 ExpectPactError - - res0Local <- runLocal batch0 - res1Local <- runLocal batch1 - - void $ liftIO $ step "when tx too big, gas pact error thrown" - assertEqual "LOCAL: expect gas error for big tx" gasError0 (Just $ resultOf res0Local) - case res0Send of - Left e -> assertFailure $ "test failure for big tx with insufficient gas: " <> show e - Right cr -> assertEqual "SEND: expect gas error for big tx" gasError0Mem (resultOf <$> cr) - - let getFailureMsg (Left (Pact.PactError _ _ _ m)) = m - getFailureMsg p = pretty $ "Expected failure result, got " ++ show p - - void $ liftIO $ step "discounts initial gas charge from gas available for pact execution" - assertEqual "LOCAL: expect gas error after discounting initial gas charge" - gasError1 (getFailureMsg $ resultOf res1Local) - - case res1Send of - Left e -> assertFailure $ "test failure for discounting initial gas charge: " <> show e - Right cr -> assertEqual "SEND: expect gas error after discounting initial gas charge" - (Just gasError1Mem) (getFailureMsg . resultOf <$> cr) - - where - sid = unsafeChainId 0 - gasError0 = Just $ Left $ - Pact.PactError Pact.GasError noInfo [] "Tx too big (4), limit 1" - gasError0Mem = Just $ Left $ - Pact.PactError Pact.TxFailure noInfo [] "Transaction is badlisted because it previously failed to validate." - gasError1 = "Gas limit (5) exceeded: 6" - gasError1Mem = "Transaction is badlisted because it previously failed to validate." - - mkTxBatch code cdata limit n = do - ks <- testKeyPairs sender00 Nothing - let pm = Pact.PublicMeta (Pact.ChainId "0") "sender00" limit 0.01 defaultMaxTTL t - cmd <- liftIO $ Pact.mkExec code cdata pm ks [] (Just vNetworkId) n - return $ SubmitBatch (pure cmd) - - txcode0 = T.concat ["[", T.replicate 10 " 1", "]"] - txcode1 = txcode0 <> "(identity 1)" - - -caplistTest :: Pact.TxCreationTime -> ClientEnv -> (String -> IO ()) -> IO () -caplistTest t cenv step = do - let testCaseStep = liftIO . step - - r <- flip runClientM cenv $ do - batch <- liftIO - $ mkSingletonBatch t sender00 tx0 n0 (pm "sender00") clist - - testCaseStep "send transfer request with caplist sender00 -> sender01" - rks <- liftIO $ sending v sid cenv batch - - testCaseStep "poll for transfer results" - PollResponses rs <- liftIO $ polling v sid cenv rks ExpectPactResult - - return (HM.lookup (NEL.head $ _rkRequestKeys rks) rs) - - case r of - Left e -> assertFailure $ "test failure for TRANSFER + FUND_TX: " <> show e - Right res -> do - assertEqual "TRANSFER + FUND_TX test" result0 (resultOf <$> res) - assertSatisfies "meta in output" (preview (_Just . crMetaData . _Just . _Object . at "blockHash") res) isJust - - where - sid = unsafeChainId 0 - n0 = Just "transfer-clist0" - pm sendr = Pact.PublicMeta (Pact.ChainId "0") sendr 100_000 0.01 defaultMaxTTL - - result0 = Just (Right (PLiteral (LString "Write succeeded"))) - - clist :: Maybe [SigCapability] - clist = Just $ - [ mkCoinCap "GAS" [] - , mkCoinCap "TRANSFER" - [ PLiteral $ LString "sender00" - , PLiteral $ LString "sender01" - , PLiteral $ LDecimal 100.0 - ] - ] - - tx0 = PactTransaction "(coin.transfer \"sender00\" \"sender01\" 100.0)" Nothing - - - -allocation01KeyPair :: SimpleKeyPair -allocation01KeyPair = - ( "b4c8a3ea91d3146b0560994740f0e3eed91c59d2eeca1dc99f0c2872845c294d" - , "5dbbbd8b765b7d0cf8426d6992924b057c70a2138ecd4cf60cfcde643f304ea9" - ) - -allocation02KeyPair :: SimpleKeyPair -allocation02KeyPair = - ( "e9e4e71bd063dcf7e06bd5b1a16688897d15ca8bd2e509c453c616219c186cc5" - , "45f026b7a6bb278ed4099136c13e842cdd80138ab7c5acd4a1f0e6c97d1d1e3c" - ) - -allocation02KeyPair' :: SimpleKeyPair -allocation02KeyPair' = - ( "0c8212a903f6442c84acd0069acc263c69434b5af37b2997b16d6348b53fcd0a" - , "2f75b5d875dd7bf07cc1a6973232a9e53dc1d4ffde2bab0bbace65cd87e87f53" - ) - -allocationTest :: Pact.TxCreationTime -> ClientEnv -> (String -> IO ()) -> IO () -allocationTest t cenv step = do - - step "positive allocation test: allocation00 release" - p <- do - batch0 <- liftIO - $ mkSingletonBatch t allocation00KeyPair tx0 n0 (pm "allocation00") Nothing - - SubmitBatch batch1 <- liftIO - $ mkSingletonBatch t allocation00KeyPair tx1 n1 (pm "allocation00") Nothing - step "sendApiClient: submit allocation release request" - rks0 <- liftIO $ sending v sid cenv batch0 - - step "pollApiClient: polling for allocation key" - _ <- liftIO $ polling v sid cenv rks0 ExpectPactResult - - step "localApiClient: submit local account balance request" - liftIO $ localTestToRetry v sid cenv (head (toList batch1)) (localAfterBlockHeight 4) - - assertEqual "00 expect /local allocation balance" accountInfo (resultOf p) - - step "negative allocation test: allocation01 release" - do - batch0 <- mkSingletonBatch t allocation01KeyPair tx2 n2 (pm "allocation01") Nothing - - step "sendApiClient: submit allocation release request" - cr <- local v sid cenv (NEL.head $ _sbCmds batch0) - - case resultOf cr of - Left e -> do - assertBool "expect negative allocation test failure" - $ T.isInfixOf "Failure: Tx Failed: funds locked" - $ sshow e - _ -> assertFailure "unexpected pact result success in negative allocation test" - - step "positive key-rotation test: allocation2" - r <- do - - batch0 <- mkSingletonBatch t allocation02KeyPair tx3 n3 (pm "allocation02") Nothing - - step "senderApiClient: submit keyset rotation request" - rks <- sending v sid cenv batch0 - - step "pollApiClient: polling for successful rotation" - void $ polling v sid cenv rks ExpectPactResult - - step "senderApiClient: submit allocation release request" - batch1 <- mkSingletonBatch t allocation02KeyPair' tx4 n4 (pm "allocation02") Nothing - - rks' <- sending v sid cenv batch1 - step "pollingApiClient: polling for successful release" - pr <- polling v sid cenv rks' ExpectPactResult - - step "localApiClient: retrieving account info for allocation02" - SubmitBatch batch2 <- mkSingletonBatch t allocation02KeyPair' tx5 n5 (pm "allocation02") Nothing - - localTestToRetry v sid cenv (head (toList batch2)) (localAfterPollResponse pr) - - assertEqual "02 expect /local allocation balance" accountInfo' (resultOf r) - - where - n0 = Just "allocation-0" - n1 = Just "allocation-1" - n2 = Just "allocation-2" - n3 = Just "allocation-3" - n4 = Just "allocation-4" - n5 = Just "allocation-5" - - sid = unsafeChainId 0 - - localAfterPollResponse (PollResponses prs) cr = - crGetBlockHeight cr > crGetBlockHeight (snd $ head $ HM.toList prs) - - localAfterBlockHeight bh cr = - crGetBlockHeight cr > Just bh - - accountInfo = Right - $ PObject - $ ObjectMap - $ M.fromList - [ (FieldKey "account", PLiteral $ LString "allocation00") - , (FieldKey "balance", PLiteral $ LDecimal 1_099_993.91) -- balance = (1k + 1mm) - gas - , (FieldKey "guard", PGuard $ GKeySetRef (KeySetName "allocation00" Nothing)) - ] - - pm sendr = Pact.PublicMeta (Pact.ChainId "0") sendr 100_000 0.01 defaultMaxTTL - - tx0 = PactTransaction "(coin.release-allocation \"allocation00\")" Nothing - tx1 = PactTransaction "(coin.details \"allocation00\")" Nothing - tx2 = PactTransaction "(coin.release-allocation \"allocation01\")" Nothing - tx3 = - let - c = "(define-keyset \"allocation02\" (read-keyset \"allocation02-keyset\"))" - d = mkKeySet - ["0c8212a903f6442c84acd0069acc263c69434b5af37b2997b16d6348b53fcd0a"] - "keys-all" - in PactTransaction c $ Just (A.object [ "allocation02-keyset" A..= J.toJsonViaEncode d ]) - tx4 = PactTransaction "(coin.release-allocation \"allocation02\")" Nothing - tx5 = PactTransaction "(coin.details \"allocation02\")" Nothing - - accountInfo' = Right - $ PObject - $ ObjectMap - $ M.fromList - [ (FieldKey "account", PLiteral $ LString "allocation02") - , (FieldKey "balance", PLiteral $ LDecimal 1_099_991.05) -- 1k + 1mm - gas - , (FieldKey "guard", PGuard $ GKeySetRef (KeySetName "allocation02" Nothing)) - ] - --- Test that transactions signed with (mock) WebAuthn keypairs are accepted --- by the pact service. -webAuthnSignatureTest :: Pact.TxCreationTime -> ClientEnv -> IO () -webAuthnSignatureTest t cenv = do - - cmd1 <- buildTextCmd "nonce-webauthn-1" v - $ set cbSigners [mkWebAuthnSigner' sender02WebAuthn [], mkEd25519Signer' sender00 []] - $ set cbCreationTime t - $ set cbGasLimit 1000 - $ set cbRPC (mkExec' "(concat [\"chainweb-\" \"node\"])") - $ defaultCmd - - rks1 <- sending v cid' cenv (SubmitBatch $ pure cmd1) - PollResponses _resp1 <- polling v cid' cenv rks1 ExpectPactResult - - cmd2 <- buildTextCmd "nonce-webauthn-2" v - $ set cbSigners [mkWebAuthnSigner' sender02WebAuthn [], mkEd25519Signer' sender00 []] - $ set cbCreationTime t - $ set cbGasLimit 1000 - $ set cbRPC (mkExec' "(concat [\"chainweb-\" \"node\"])") - $ defaultCmd - - rks2 <- sending v cid' cenv (SubmitBatch $ pure cmd2) - PollResponses _resp2 <- polling v cid' cenv rks2 ExpectPactResult - - return () - - where - cid' = unsafeChainId 0 - - - --- -------------------------------------------------------------------------- -- --- Utils - - -data PactTransaction = PactTransaction - { _pactCode :: Text - , _pactData :: Maybe A.Value - } deriving (Eq, Show) - -resultOf :: CommandResult l -> Either Pact.PactError PactValue -resultOf = _pactResult . _crResult - -mkSingletonBatch - :: Pact.TxCreationTime - -> SimpleKeyPair - -> PactTransaction - -> Maybe Text - -> (Pact.TxCreationTime -> Pact.PublicMeta) - -> Maybe [SigCapability] - -> IO SubmitBatch -mkSingletonBatch t kps (PactTransaction c d) nonce pmk clist = do - ks <- testKeyPairs kps clist - let dd = fromMaybe A.Null d - cmd <- liftIO $ Pact.mkExec c dd (pmk t) ks [] (Just vNetworkId) nonce - return $ SubmitBatch (cmd NEL.:| []) - -testSend :: Pact.TxCreationTime -> MVar Int -> ClientEnv -> IO RequestKeys -testSend t mNonce env = testBatch t mNonce gp >>= sending v cid env - -testBatch'' :: Pact.ChainId -> Pact.TxCreationTime -> Pact.TTLSeconds -> MVar Int -> GasPrice -> IO SubmitBatch -testBatch'' chain t ttl mnonce gp' = modifyMVar mnonce $ \(!nn) -> do - let nonce = "nonce" <> sshow nn - kps <- testKeyPairs sender00 Nothing - c <- Pact.mkExec "(+ 1 2)" A.Null (pm t) kps [] (Just vNetworkId) (Just nonce) - pure (succ nn, SubmitBatch (pure c)) - where - pm :: Pact.TxCreationTime -> Pact.PublicMeta - pm = Pact.PublicMeta chain "sender00" 1000 gp' ttl - -testBatch' :: Pact.TxCreationTime -> Pact.TTLSeconds -> MVar Int -> GasPrice -> IO SubmitBatch -testBatch' = testBatch'' pactCid - -testBatch :: Pact.TxCreationTime -> MVar Int -> GasPrice -> IO SubmitBatch -testBatch t mnonce = testBatch' t defaultMaxTTL mnonce - -pactDeadBeef :: RequestKey -pactDeadBeef = let (TransactionHash b) = deadbeef - in RequestKey $ Hash b - --- avoiding `scientific` dep here -crGetBlockHeight :: CommandResult a -> Maybe Word64 -crGetBlockHeight = preview (crMetaData . _Just . key "blockHeight" . _Number . to ((fromIntegral :: Integer -> Word64 ) . round . toRational)) diff --git a/test/unit/Chainweb/Test/Pact4/RewardsTest.hs b/test/unit/Chainweb/Test/Pact4/RewardsTest.hs index 236bf39381..9ecb56d24c 100644 --- a/test/unit/Chainweb/Test/Pact4/RewardsTest.hs +++ b/test/unit/Chainweb/Test/Pact4/RewardsTest.hs @@ -13,7 +13,7 @@ import Chainweb.Test.TestVersions import Chainweb.Version v :: ChainwebVersion -v = instantCpmTestVersion petersenChainGraph +v = instantCpmTestVersion False petersenChainGraph tests :: TestTree tests = testGroup "Chainweb.Test.Pact4.RewardsTest" @@ -25,7 +25,7 @@ tests = testGroup "Chainweb.Test.Pact4.RewardsTest" rewardsTest :: HasCallStack => TestTree rewardsTest = testCaseSteps "rewards" $ \step -> do - let k = _kda . minerRewardKda . blockMinerReward v + let k = _kda . minerRewardKda . withVersion v blockMinerReward step "block heights below initial threshold" let a = k 0 diff --git a/test/unit/Chainweb/Test/Pact4/SPV.hs b/test/unit/Chainweb/Test/Pact4/SPV.hs deleted file mode 100644 index 0ce12c4e62..0000000000 --- a/test/unit/Chainweb/Test/Pact4/SPV.hs +++ /dev/null @@ -1,549 +0,0 @@ -{-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE NumericUnderscores #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} - --- | --- Copyright: Copyright © 2018 - 2020 Kadena LLC. --- License: MIT --- Maintainer: Lars Kuhtz , Emily Pillmore --- Stability: experimental --- --- Pact Service SPV Support roundtrip tests --- -module Chainweb.Test.Pact4.SPV -( -- * test suite - tests - -- * repl tests -, standard -, invalidProof -) where - -import Control.Arrow ((***)) -import Control.Concurrent.MVar -import Control.Exception (SomeException, finally) -import Control.Monad -import Control.Lens hiding ((.=)) - -import Data.Aeson as Aeson -import qualified Data.ByteString.Base64.URL as B64U -import qualified Data.ByteString.Char8 as B8 - -import Data.ByteString.Lazy (toStrict) -import qualified Data.HashMap.Strict as HM -import Data.IORef -import Data.List (isInfixOf) -import Data.LogMessage -import Data.Text (pack,Text) -import qualified Data.Text.IO as T -import qualified Data.Text as T -import Data.Vector (Vector) -import qualified Data.Vector as Vector -import Data.Word - -import Ethereum.Block -import Ethereum.Receipt -import Ethereum.Receipt.ReceiptProof -import Ethereum.RLP - -import System.LogLevel - -import Test.Tasty -import Test.Tasty.HUnit - --- internal pact modules - -import qualified Pact.JSON.Encode as J -import Pact.Types.Command -import Pact.Types.Exp -import Pact.Types.Hash -import Pact.Types.PactValue -import Pact.Types.Runtime (toPactId) -import Pact.Types.SPV -import Pact.Types.Term - --- internal chainweb modules - -import Chainweb.BlockCreationTime -import Chainweb.BlockHash -import Chainweb.BlockHeader -import Chainweb.BlockHeight -import Chainweb.Cut -import Chainweb.Graph -import Chainweb.Miner.Pact - -import Chainweb.Pact.Types (MemPoolAccess, mpaGetBlock) -import Chainweb.Payload -import Chainweb.Payload.PayloadStore -import Chainweb.SPV.CreateProof -import Chainweb.Storage.Table.RocksDB -import Chainweb.Test.Cut -import Chainweb.Test.Cut.TestBlockDb -import Chainweb.Test.Pact4.Utils -import Chainweb.Test.Utils -import Chainweb.Test.TestVersions -import Chainweb.Time -import qualified Chainweb.Pact4.Transaction as Pact4 -import Chainweb.Utils hiding (check) -import Chainweb.Version as Chainweb -import Chainweb.WebPactExecutionService -import Control.Monad.Trans.Resource -import Control.Monad.IO.Class - - --- | Note: These tests are intermittently non-deterministic due to the way --- random chain sampling works with our test harnesses. --- -tests :: RocksDb -> TestTree -tests rdb = testGroup "Chainweb.Test.Pact4.SPV" - [ testCaseSteps "standard SPV verification round trip" $ standard rdb - , testCaseSteps "contTXOUTOld" $ contTXOUTOld rdb - , testCaseSteps "contTXOUTNew" $ contTXOUTNew rdb - , testCaseSteps "tfrTXOUTNew" $ tfrTXOUTNew rdb - , testCaseSteps "ethReceiptProof" $ ethReceiptProof rdb - , testCaseSteps "noEthReceiptProof" $ noEthReceiptProof rdb - , testCaseSteps "invalid proof formats fail" $ invalidProof rdb - ] - -testVer :: ChainwebVersion -testVer = noBridgeCpmTestVersion triangleChainGraph - -bridgeVer :: ChainwebVersion -bridgeVer = fastForkingCpmTestVersion pairChainGraph - --- Only use for debugging. Do not use in tests in the test suite! --- -logg :: LogMessage a => LogLevel -> a -> IO () -logg l - | l <= Warn = T.putStrLn . logText - | otherwise = const $ return () - - --- debugging -_handle' :: SomeException -> IO (Bool, String) -_handle' e = - let - s = show e - in logg System.LogLevel.Error (pack s) >> return (False, s) - --- -------------------------------------------------------------------------- -- --- tests - -standard :: RocksDb -> (String -> IO ()) -> Assertion -standard rdb step = do - (c1,c3) <- roundtrip rdb 0 1 burnGen createSuccess step - checkResult c1 0 "ObjectMap" - checkResult c3 1 "Write succeeded" - -contTXOUTOld :: RocksDb -> (String -> IO ()) -> Assertion -contTXOUTOld rdb step = do - code <- T.readFile "test/pact/contTXOUTOld.pact" - (c1,c3) <- roundtrip rdb 0 1 burnGen (createVerify False code mdata) step - checkResult c1 0 "ObjectMap" - checkResult' c3 1 $ PactResult $ Right $ PLiteral $ LString rSuccessTXOUT - where - mdata = toJSON [fst sender01] :: Value - - -contTXOUTNew :: RocksDb -> (String -> IO ()) -> Assertion -contTXOUTNew rdb step = do - code <- T.readFile "test/pact/contTXOUTNew.pact" - (c1,c3) <- roundtrip' rdb bridgeVer 0 1 burnGen (createVerify True code mdata) step - checkResult c1 0 "ObjectMap" - checkResult' c3 1 $ PactResult $ Right $ PLiteral $ LString rSuccessTXOUT - where - mdata = toJSON [fst sender01] - - -tfrTXOUTNew :: RocksDb -> (String -> IO ()) -> Assertion -tfrTXOUTNew rdb step = do - code <- T.readFile "test/pact/tfrTXOUTNew.pact" - (c1,c3) <- roundtrip' rdb bridgeVer 0 1 transferGen (createVerify True code mdata) step - checkResult c1 0 "Write succeeded" - checkResult' c3 1 $ PactResult $ Right $ PLiteral $ LString rSuccessTXOUT - where - mdata = toJSON [fst sender01] :: Value - -ethReceiptProof :: RocksDb -> (String -> IO ()) -> Assertion -ethReceiptProof rdb step = do - code <- T.readFile "test/pact/ethReceiptProof.pact" - (c1,c3) <- roundtrip' rdb bridgeVer 0 1 transferGen (createVerifyEth code) step - checkResult c1 0 "Write succeeded" - checkResult' c3 1 $ PactResult $ Right $ PLiteral $ LString "ETH Success" - -noEthReceiptProof :: RocksDb -> (String -> IO ()) -> Assertion -noEthReceiptProof rdb step = do - code <- T.readFile "test/pact/ethReceiptProof.pact" - (c1,c3) <- roundtrip' rdb testVer 0 1 transferGen (createVerifyEth code) step - checkResult c1 0 "Write succeeded" - checkResult c3 1 "unsupported SPV types: ETH" - -rSuccessTXOUT :: Text -rSuccessTXOUT = "TXOUT Success" - -invalidProof :: RocksDb -> (String -> IO ()) -> Assertion -invalidProof rdb step = do - (c1,c3) <- roundtrip rdb 0 1 burnGen createInvalidProof step - checkResult c1 0 "ObjectMap" - checkResult c3 1 "Failure: resumePact: no previous execution found" - -checkResult :: HasCallStack => CutOutputs -> Word32 -> String -> Assertion -checkResult co ci expect = - assertSatisfies ("result on chain " ++ show ci ++ " contains '" ++ show expect ++ "'") - (HM.lookup (unsafeChainId ci) co) (isInfixOf expect . show) - -checkResult' :: HasCallStack => CutOutputs -> Word32 -> PactResult -> Assertion -checkResult' co ci expect = case HM.lookup (unsafeChainId ci) co of - Nothing -> assertFailure $ "No result found for chain " ++ show ci - Just v -> case Vector.toList v of - [(_,cr)] -> assertEqual "pact results match" expect (_crResult cr) - _ -> assertFailure $ "expected single result, got " ++ show v - -getCutOutputs :: TestBlockDb -> IO CutOutputs -getCutOutputs (TestBlockDb _ pdb cmv) = do - c <- readMVar cmv - cutToPayloadOutputs c pdb - --- | Populate blocks for every chain of the current cut. Uses provided pact --- service to produce a new block, add it -runCut' :: ChainwebVersion -> TestBlockDb -> WebPactExecutionService -> IO CutOutputs -runCut' v bdb pact = do - runCut v bdb pact (offsetBlockTime second) zeroNoncer noMiner - getCutOutputs bdb - -roundtrip - :: RocksDb - -> Word32 - -- ^ source chain id - -> Word32 - -- ^ target chain id - -> BurnGenerator - -- ^ burn tx generator - -> CreatesGenerator - -- ^ create tx generator - -> (String -> IO ()) - -> IO (CutOutputs, CutOutputs) -roundtrip rdb = roundtrip' rdb testVer - -roundtrip' - :: RocksDb - -> ChainwebVersion - -> Word32 - -- ^ source chain id - -> Word32 - -- ^ target chain id - -> BurnGenerator - -- ^ burn tx generator - -> CreatesGenerator - -- ^ create tx generator - -> (String -> IO ()) - -- ^ logging backend - -> IO (CutOutputs, CutOutputs) -roundtrip' rdb v sid0 tid0 burn create step = runResourceT $ do - bdb <- mkTestBlockDb v rdb - liftIO $ do - tg <- newMVar mempty - let logger = hunitDummyLogger step - mempools <- onAllChains v $ \chain -> - return $ chainToMPA' chain tg - withWebPactExecutionService logger v testPactServiceConfig bdb mempools $ \(pact,_) -> do - - sid <- mkChainId v maxBound sid0 - tid <- mkChainId v maxBound tid0 - - -- track the continuation pact id - pidv <- newEmptyMVar @PactId - - -- cut 0: empty run (not sure why this is needed but test fails without it) - step "cut 0: empty run" - void $ runCut' v bdb pact - - -- cut 1: burn - step "cut 1: burn" - -- Creating the parent took at least 1 second. So 1s is fine as creation time - let t1 = add second epoch - txGen1 <- burn v t1 pidv sid tid - void $ swapMVar tg txGen1 - co1 <- runCut' v bdb pact - - -- setup create txgen with cut 1 - step "setup create txgen with cut 1" - (BlockCreationTime t2) <- view blockCreationTime <$> getParentTestBlockDb bdb tid - hi <- view blockHeight <$> getParentTestBlockDb bdb sid - txGen2 <- create v t2 bdb pidv sid tid hi - - -- cut 2: empty cut for diameter 1 - step "cut 2: empty cut for diameter 1" - void $ swapMVar tg mempty - void $ runCut' v bdb pact - - -- cut 3: create - step "cut 3: create" - void $ swapMVar tg txGen2 - co2 <- runCut' v bdb pact - - return (co1,co2) - - -_debugCut :: CanReadablePayloadCas tbl => String -> Cut -> PayloadDb tbl -> IO () -_debugCut msg c pdb = do - putStrLn $ "CUT: =============== " ++ msg - outs <- cutToPayloadOutputs c pdb - forM_ (HM.toList outs) $ \(cid,vs) -> do - putStrLn $ "Chain: " ++ show cid - forM_ vs $ \(cmd,pr) -> do - putStrLn $ show (_cmdHash cmd) ++ ": " ++ show pr - -type CutOutputs = HM.HashMap Chainweb.ChainId (Vector (Command Text, CommandResult Hash)) - -cutToPayloadOutputs - :: CanReadablePayloadCas tbl - => Cut - -> PayloadDb tbl - -> IO CutOutputs -cutToPayloadOutputs c pdb = do - forM (_cutMap c) $ \bh -> do - Just pwo <- lookupPayloadWithHeight pdb (Just $ view blockHeight bh) (view blockPayloadHash bh) - let txs = Vector.map (toTx *** toCR) (_payloadWithOutputsTransactions pwo) - toTx :: Transaction -> Command Text - toTx (Transaction t) = fromJuste $ decodeStrict' t - toCR :: TransactionOutput -> CommandResult Hash - toCR (TransactionOutput t) = fromJuste $ decodeStrict' t - return txs - -chainToMPA' :: ChainId -> MVar TransactionGenerator -> MemPoolAccess -chainToMPA' chain f = mempty - { mpaGetBlock = \_g pc hi ha he -> do - tg <- readMVar f - txs <- tg chain hi ha he - tos <- pc hi ha ((fmap . fmap . fmap) _pcCode txs) - forM tos $ \case - Left err -> error (sshow err) - Right t -> return t - } - - --- -------------------------------------------------------------------------- -- --- transaction generators - -type TransactionGenerator - = Chainweb.ChainId - -> BlockHeight - -> BlockHash - -> BlockCreationTime - -> IO (Vector Pact4.Transaction) - -type BurnGenerator - = ChainwebVersion -> Time Micros -> MVar PactId -> Chainweb.ChainId -> Chainweb.ChainId -> IO TransactionGenerator - -type CreatesGenerator - = ChainwebVersion - -> Time Micros - -> TestBlockDb - -> MVar PactId - -> Chainweb.ChainId - -> Chainweb.ChainId - -> BlockHeight - -> IO TransactionGenerator - --- | Generate burn/create Pact Service commands on arbitrarily many chains --- -burnGen :: BurnGenerator -burnGen v time pidv sid tid = do - ref0 <- newIORef False - ref1 <- newIORef False - return $ go ref0 ref1 - where - go ref0 ref1 _cid _bhe _bha _ - | sid /= _cid = return mempty - | otherwise = readIORef ref0 >>= \case - True -> return mempty - False -> do - readIORef ref1 >>= \case - True -> return mempty - False -> do - cmd <- buildCwCmd "0" v $ - set cbSigners [mkEd25519Signer' sender00 []] $ - set cbCreationTime (toTxCreationTime time) $ - set cbChainId sid $ - set cbRPC (mkExec tx1Code tx1Data) $ - defaultCmd - writeIORef ref0 True - - let pid = toPactId $ toUntypedHash $ _cmdHash cmd - - putMVar pidv pid `finally` writeIORef ref1 True - return $ Vector.singleton cmd - - tx1Code = T.unlines - [ "(coin.transfer-crosschain" - , " 'sender00" - , " 'sender01" - , " (read-keyset 'sender01-keyset)" - , " (read-msg 'target-chain-id)" - , " 1.0)" - ] - - tx1Data = - -- sender01 keyset guard - let ks = mkKeySet - ["6be2f485a7af75fedb4b7f153a903f7e6000ca4aa501179c91a2450b777bd2a7"] - "keys-all" - - in object - [ "sender01-keyset" .= J.toJsonViaEncode ks - , "target-chain-id" .= chainIdToText tid - ] - --- | Generate arbitrary coin.transfer call. --- -transferGen :: BurnGenerator -transferGen v time pidv sid _tid = do - ref0 <- newIORef False - ref1 <- newIORef False - return $ go ref0 ref1 - where - go ref0 ref1 _cid _bhe _bha _ - | sid /= _cid = return mempty - | otherwise = readIORef ref0 >>= \case - True -> return mempty - False -> do - readIORef ref1 >>= \case - True -> return mempty - False -> do - cmd <- buildCwCmd "0" v $ - set cbSigners - [mkEd25519Signer' sender00 - [mkTransferCap "sender00" "sender01" 1.0 - ,mkGasCap]] $ - set cbCreationTime (toTxCreationTime time) $ - set cbChainId sid $ - set cbRPC (mkExec' tx1Code) $ - defaultCmd - writeIORef ref0 True - - let pid = toPactId $ toUntypedHash $ _cmdHash cmd - - putMVar pidv pid `finally` writeIORef ref1 True - return $ Vector.singleton cmd - - - - tx1Code = "(coin.transfer 'sender00 'sender01 1.0)" - -createCont - :: ChainwebVersion - -> ChainId - -> MVar PactId - -> Maybe ContProof - -> Time Micros - -> IO (Vector Pact4.Transaction) -createCont v cid pidv proof time = do - pid <- readMVar pidv - fmap Vector.singleton $ - buildCwCmd "1" v $ - set cbSigners [mkEd25519Signer' sender00 []] $ - set cbCreationTime (toTxCreationTime time) $ - set cbChainId cid $ - set cbRPC (mkCont $ (mkContMsg pid 1) { _cmProof = proof }) $ - defaultCmd - --- | Generate a tx to run 'verify-spv' tests. --- -createVerify :: Bool -> Text -> Value -> CreatesGenerator -createVerify bridge code mdata v time (TestBlockDb wdb pdb _c) _pidv sid tid bhe = do - ref <- newIORef False - return $ go ref - where - go ref cid _bhe _bha _ - | tid /= cid = return mempty - | otherwise = readIORef ref >>= \case - True -> return mempty - False -> do - pf <- createTransactionOutputProof_ wdb pdb tid sid bhe 0 - let q | bridge = object - [ ("proof", String $ encodeB64UrlNoPaddingText $ encodeToByteString pf) - ] - | otherwise = toJSON pf - cmd <- buildCwCmd "0" v $ - set cbSigners [mkEd25519Signer' sender00 []] $ - set cbCreationTime (toTxCreationTime time) $ - set cbChainId tid $ - set cbRPC (mkExec code (object [("proof",q),("data",mdata)])) $ - defaultCmd - return (Vector.singleton cmd) - `finally` writeIORef ref True - --- | Generate a tx to run 'verify-spv' tests. --- -createVerifyEth :: Text -> CreatesGenerator -createVerifyEth code v time (TestBlockDb _wdb _pdb _c) _pidv _sid tid _bhe = do - ref <- newIORef False - q <- encodeB64UrlNoPaddingText . putRlpByteString <$> receiptProofTest 2 - return $ go q ref - where - go q ref cid _bhe _bha _ - | tid /= cid = return mempty - | otherwise = readIORef ref >>= \case - True -> return mempty - False -> do - -- q <- toJSON <$> createTransactionOutputProof_ wdb pdb tid sid bhe 0 - cmd <- buildCwCmd "0" v $ - set cbSigners [mkEd25519Signer' sender00 []] $ - set cbCreationTime (toTxCreationTime time) $ - set cbChainId tid $ - set cbRPC (mkExec code (object [("proof", toJSON q)])) $ - defaultCmd - return (Vector.singleton cmd) - `finally` writeIORef ref True - -receiptProofTest :: Int -> IO ReceiptProof -receiptProofTest i = do - recps <- readFile "test/pact/receipts.json" - blk <- readFile "test/pact/block.json" - rs <- decodeStrictOrThrow @_ @[RpcReceipt] $ B8.pack recps - block <- decodeStrictOrThrow @_ @RpcBlock $ B8.pack blk - let hdr = _rpcBlockHeader block - rpcReceiptProof hdr [] rs (TransactionIndex $ fromIntegral i) - - --- | Generate the 'create-coin' command in response to the previous 'delete-coin' call. --- Note that we maintain an atomic update to make sure that if a given chain id --- has already called the 'create-coin' half of the transaction, it will not do so again. --- -createSuccess :: CreatesGenerator -createSuccess v time (TestBlockDb wdb pdb _c) pidv sid tid bhe = do - ref <- newIORef False - return $ go ref - where - go ref cid _bhe _bha _ - | tid /= cid = return mempty - | otherwise = readIORef ref >>= \case - True -> return mempty - False -> do - q <- toJSON <$> createTransactionOutputProof_ wdb pdb tid sid bhe 0 - let proof = Just . ContProof . B64U.encode . toStrict . Aeson.encode $ q - createCont v tid pidv proof time - `finally` writeIORef ref True - --- | Execute create-coin command with invalid proof --- -createInvalidProof :: CreatesGenerator -createInvalidProof v time _ pidv _ tid _ = do - ref <- newIORef False - return $ go ref - where - go ref cid _bhe _bha _ - | tid /= cid = return mempty - | otherwise = readIORef ref >>= \case - True -> return mempty - False -> - createCont v tid pidv Nothing time - `finally` writeIORef ref True diff --git a/test/unit/Chainweb/Test/Pact4/SQLite.hs b/test/unit/Chainweb/Test/Pact4/SQLite.hs index d96f353dfb..3c1d84a5dc 100644 --- a/test/unit/Chainweb/Test/Pact4/SQLite.hs +++ b/test/unit/Chainweb/Test/Pact4/SQLite.hs @@ -42,12 +42,13 @@ import Test.Tasty.HUnit import Chainweb.Test.Utils import Chainweb.Pact.Backend.Types (SQLiteEnv) +import Chainweb.Pact.Backend.Utils (withSQLiteConnection) -- -------------------------------------------------------------------------- -- -- Tests tests :: TestTree -tests = withResourceT withInMemSQLiteResource $ \dbIO -> +tests = withResourceT (withSQLiteConnection ":memory:" []) $ \dbIO -> withResource' (dbIO >>= newMVar) $ \dbVarIO -> let run = runMsgTest dbVarIO [] runMonte = runMonteTest dbVarIO [] diff --git a/test/unit/Chainweb/Test/Pact4/TTL.hs b/test/unit/Chainweb/Test/Pact4/TTL.hs deleted file mode 100644 index 7d2bee692f..0000000000 --- a/test/unit/Chainweb/Test/Pact4/TTL.hs +++ /dev/null @@ -1,303 +0,0 @@ -{-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE NumericUnderscores #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} - -module Chainweb.Test.Pact4.TTL -( tests ) where - -import Control.Concurrent.MVar -import Control.Lens (set, view) -import Control.Monad -import Control.Monad.Catch - -import qualified Data.Vector as V - -import Pact.Types.ChainMeta -import Pact.Types.Exp(ParsedCode(..)) - -import Test.Tasty -import Test.Tasty.HUnit - --- internal modules - -import Chainweb.BlockCreationTime -import Chainweb.BlockHeader -import Chainweb.BlockHeaderDB hiding (withBlockHeaderDb) -import Chainweb.BlockHeaderDB.Internal (unsafeInsertBlockHeaderDb) -import Chainweb.Miner.Pact - -import Chainweb.Pact.Service.BlockValidation -import Chainweb.Pact.Service.PactQueue -import Chainweb.Pact.Types -import Chainweb.Pact4.Validations (defaultLenientTimeSlop) -import Chainweb.Payload -import Chainweb.Payload.PayloadStore -import Chainweb.Test.Cut.TestBlockDb -import Chainweb.Test.Pact4.Utils -import Chainweb.Test.Utils -import Chainweb.Test.TestVersions -import Chainweb.Time -import Chainweb.Utils -import Chainweb.Version -import Chainweb.Version.Utils - -import Chainweb.Storage.Table.RocksDB -import Data.Either (isRight) - --- -------------------------------------------------------------------------- -- --- Settings - -testVer :: ChainwebVersion -testVer = instantCpmTestVersion petersen - -defTtl :: Seconds -defTtl = 60 * 60 * 2 -- 2 hours - -genblock :: BlockHeader -genblock = genesisBlockHeader testVer (someChainId testVer) - --- -------------------------------------------------------------------------- -- --- Tests - --- | Test new block validation of transaction timings. --- --- New block validation must be stricter than block validation. I.e. each block --- that passes new block validation must also pass block validation, or, --- equivalently, each block that is rejected by block validation must also be --- rejected by new block validation. --- --- Thus, all failing tests are expected to already fail during pre block --- validation. --- -tests :: RocksDb -> TestTree -tests rdb = testGroup "Chainweb.Test.Pact4.TTL" - [ testGroup "timing tests" - [ withTestPact rdb testTxTime - , withTestPact rdb testTxTimeLenient - , withTestPact rdb testTxTimeFail1 - , withTestPact rdb testTxTimeFail2 - , withTestPact rdb testTtlTooLarge - , withTestPact rdb testTtlSmall - , withTestPact rdb testExpired - , withTestPact rdb testExpiredTight - , withTestPact rdb testJustMadeItSmall - , withTestPact rdb testJustMadeItLarge - ] - ] - --- -------------------------------------------------------------------------- -- --- Tests - -testTxTime :: IO Ctx -> TestTree -testTxTime ctxIO = - testCase "tx time of parent time and default ttl pass validation" $ do - T2 hdr1 _ <- mineBlock ctxIO mempty (ParentHeader genblock) (Nonce 0) 1 - T2 hdr2 _ <- mineBlock ctxIO (offset 0) (ParentHeader hdr1) (Nonce 1) 1 - void $ mineBlock ctxIO (offset (-1)) (ParentHeader hdr2) (Nonce 2) 1 - -testTxTimeLenient :: IO Ctx -> TestTree -testTxTimeLenient ctxIO = - testCase "testTxTimeLenient: tx time of parent time + slop and default ttl succeeds during new block validation" $ do - T2 hdr _ <- mineBlock ctxIO mempty (ParentHeader genblock) (Nonce 1) 1 - void $ doNewBlock ctxIO (offset defaultLenientTimeSlop) (ParentHeader hdr) (Nonce 2) 1 - -testTxTimeFail1 :: IO Ctx -> TestTree -testTxTimeFail1 ctxIO = - testCase "testTxTimeFail1: tx time of parent time + slop + 1 and default ttl fails during new block validation" $ do - T2 hdr _ <- mineBlock ctxIO mempty (ParentHeader genblock) (Nonce 1) 1 - assertDoPreBlockFailure $ doNewBlock ctxIO (offset (succ defaultLenientTimeSlop)) (ParentHeader hdr) (Nonce 2) 1 - -testTxTimeFail2 :: IO Ctx -> TestTree -testTxTimeFail2 ctxIO = - testCase "tx time of parent time + 1000 and default ttl fails during new block validation" $ do - T2 hdr _ <- mineBlock ctxIO mempty (ParentHeader genblock) (Nonce 1) 1 - assertDoPreBlockFailure $ doNewBlock ctxIO (offset 1000) (ParentHeader hdr) (Nonce 2) 1 - -testTtlTooLarge :: IO Ctx -> TestTree -testTtlTooLarge ctxIO = - testCase "too large TTL fails validation" $ do - T2 hdr _ <- mineBlock ctxIO mempty (ParentHeader genblock) (Nonce 1) 1 - assertDoPreBlockFailure $ doNewBlock ctxIO (ttl (100 * 24 * 3600)) (ParentHeader hdr) (Nonce 2) 1 - -testTtlSmall :: IO Ctx -> TestTree -testTtlSmall ctxIO = - testCase "testTtlSmall: small TTL passes validation" $ do - T2 hdr _ <- mineBlock ctxIO mempty (ParentHeader genblock) (Nonce 1) 1 - void $ doNewBlock ctxIO (ttl 5) (ParentHeader hdr) (Nonce 2) 1 - -testExpired :: IO Ctx -> TestTree -testExpired ctxIO = - testCase "expired transaction fails validation" $ do - T2 hdr _ <- mineBlock ctxIO mempty (ParentHeader genblock) (Nonce 1) 500 - assertDoPreBlockFailure $ doNewBlock ctxIO (offsetTtl (-400) 300) (ParentHeader hdr) (Nonce 2) 1 - -testExpiredTight :: IO Ctx -> TestTree -testExpiredTight ctxIO = - testCase "tightly expired transaction fails validation" $ do - T2 hdr _ <- mineBlock ctxIO mempty (ParentHeader genblock) (Nonce 1) 500 - assertDoPreBlockFailure $ doNewBlock ctxIO (offsetTtl (-300) 300) (ParentHeader hdr) (Nonce 2) 1 - -testJustMadeItSmall :: IO Ctx -> TestTree -testJustMadeItSmall ctxIO = - testCase "testJustMadeItSmall" $ do - T2 hdr _ <- mineBlock ctxIO mempty (ParentHeader genblock) (Nonce 1) 100 - void $ doNewBlock ctxIO (offsetTtl (-99) 100) (ParentHeader hdr) (Nonce 2) 1 - -testJustMadeItLarge :: IO Ctx -> TestTree -testJustMadeItLarge ctxIO = - testCase "testJustMadeItLarge" $ do - T2 hdr _ <- mineBlock ctxIO mempty (ParentHeader genblock) (Nonce 1) 500 - void $ doNewBlock ctxIO (offsetTtl (-399) 400) (ParentHeader hdr) (Nonce 2) 1 - --- -------------------------------------------------------------------------- -- --- Mempool Access - --- Mempool access implementations that provide transactions with different --- values for creation time and TTL. - --- | Use parent block time for tx creation time, change ttl. -ttl :: Seconds -> MemPoolAccess -ttl = modAtTtl id - --- | Offset tx creation time relative to parent block time, use default ttl. -offset :: Seconds -> MemPoolAccess -offset = modAt . add . secondsToTimeSpan - --- | Offset tx creation time relative to parent block time, AND set ttl. -offsetTtl :: Seconds -> Seconds -> MemPoolAccess -offsetTtl off ttl' = modAtTtl (add (secondsToTimeSpan off)) ttl' - --- | Set tx creation time relative to parent block time, use default ttl. -modAt :: (Time Micros -> Time Micros) -> MemPoolAccess -modAt f = modAtTtl f defTtl - -modAtTtl :: (Time Micros -> Time Micros) -> Seconds -> MemPoolAccess -modAtTtl f (Seconds t) = mempty - { mpaGetBlock = \_ validate bh hash bct -> do - let txTime = toTxCreationTime $ f $ _bct bct - tt = TTLSeconds (int t) - outtxs <- fmap V.singleton $ buildCwCmd (sshow bh) testVer - $ set cbCreationTime txTime - $ set cbTTL tt - $ set cbSigners [mkEd25519Signer' sender00 []] - $ set cbRPC (mkExec' "1") - $ defaultCmd - - tos <- validate bh hash $ (fmap . fmap . fmap) _pcCode outtxs - - unless (all isRight tos) $ throwM DoPreBlockFailure - return $ V.fromList [ to | Right to <- V.toList tos ] - } - --- -------------------------------------------------------------------------- -- --- Block Validation - -mineBlock - :: IO Ctx - -> MemPoolAccess - -> ParentHeader - -> Nonce - -> Seconds - -- ^ Block time - -> IO (T2 BlockHeader PayloadWithOutputs) -mineBlock ctxIO mempool parent nonce s = do - T2 hdr payload <- doNewBlock ctxIO mempool parent nonce s - doValidateBlock ctxIO hdr payload - return $ T2 hdr payload - --- | Create new block --- -doNewBlock - :: IO Ctx - -> MemPoolAccess - -> ParentHeader - -> Nonce - -> Seconds - -- ^ Block time - -> IO (T2 BlockHeader PayloadWithOutputs) -doNewBlock ctxIO mempool parent nonce t = do - ctx <- ctxIO - unlessM (tryPutMVar (_ctxMempool ctx) mempool) $ - error "Test failure: mempool access is not empty. Some previous test step failed unexpectedly" - - bip <- throwIfNoHistory =<< newBlock noMiner NewBlockFill parent (_ctxQueue ctx) - let payload = forAnyPactVersion finalizeBlock bip - let - creationTime = BlockCreationTime - . add (secondsToTimeSpan t) -- 10 seconds - . _bct . view blockCreationTime - $ _parentHeader parent - bh = newBlockHeader - (_versionForkNumber (_chainwebVersion parent)) - mempty - (_payloadWithOutputsPayloadHash payload) - nonce - creationTime - parent - -- no need for mining, since testVer uses a trivial target - return $ T2 bh payload - where - --- | Validate Block --- -doValidateBlock - :: IO Ctx - -> BlockHeader - -> PayloadWithOutputs - -> IO () -doValidateBlock ctxIO header payload = do - ctx <- ctxIO - _mv' <- validateBlock header (CheckablePayloadWithOutputs payload) $ _ctxQueue ctx - addNewPayload (_ctxPdb ctx) (view blockHeight header) payload - unsafeInsertBlockHeaderDb (_ctxBdb ctx) header - -- FIXME FIXME FIXME: do at least some checks? - --- -------------------------------------------------------------------------- -- --- Misc Utils - -data ValidationFailure - = DoPreBlockFailure - deriving (Show) - -instance Exception ValidationFailure - -assertDoPreBlockFailure - :: IO a - -> IO () -assertDoPreBlockFailure action = try action >>= \case - Left DoPreBlockFailure -> return () - Right{} -> assertFailure "Expected DoPreBlockFailure but the action succeeded." - -data Ctx = Ctx - { _ctxMempool :: !(MVar MemPoolAccess) - , _ctxQueue :: !PactQueue - , _ctxPdb :: !(PayloadDb RocksDbTable) - , _ctxBdb :: !BlockHeaderDb - } - -withTestPact - :: RocksDb - -> (IO Ctx -> TestTree) - -> TestTree -withTestPact rdb test = - withResource' newEmptyMVar $ \mempoolVarIO -> - withPactTestBlockDb testVer cid rdb (mempool mempoolVarIO) testPactServiceConfig $ \ios -> - test $ do - (_, pq, bdb) <- ios - mp <- mempoolVarIO - bhdb <- getBlockHeaderDb cid bdb - return $ Ctx mp pq (_bdbPayloadDb bdb) bhdb - where - cid = someChainId testVer - mempool mempoolVarIO = return $ mempty - { mpaGetBlock = \g val he h p -> - mempoolVarIO >>= tryTakeMVar >>= \case - Nothing -> mempty - Just mp -> mpaGetBlock mp g val he h p - } diff --git a/test/unit/Chainweb/Test/Pact4/TransactionTests.hs b/test/unit/Chainweb/Test/Pact4/TransactionTests.hs index 88334342bb..68cf9584c4 100644 --- a/test/unit/Chainweb/Test/Pact4/TransactionTests.hs +++ b/test/unit/Chainweb/Test/Pact4/TransactionTests.hs @@ -37,38 +37,28 @@ import qualified System.LogLevel as L -- internal pact modules -import Pact.Gas import Pact.Interpreter import Pact.Parse import Pact.Repl import Pact.Repl.Types import Pact.Types.Command -import qualified Pact.Types.Hash as H -import Pact.Types.PactValue import Pact.Types.RPC import Pact.Types.Runtime -import Pact.Types.SPV -- internal chainweb modules -import Chainweb.BlockCreationTime -import Chainweb.BlockHeader.Internal -import Chainweb.BlockHeight import Chainweb.Logger import Chainweb.Miner.Pact import Chainweb.Pact4.Templates import Chainweb.Pact4.TransactionExec -import qualified Chainweb.Pact4.Types as Pact4 -import Chainweb.Test.Utils -import Chainweb.Test.TestVersions -import Chainweb.Time import Chainweb.Utils import Chainweb.Version as V import Chainweb.Version.RecapDevelopment -import Chainweb.Version.Mainnet -import Chainweb.Test.Pact4.Utils import qualified Chainweb.Pact4.ModuleCache as Pact4 +import qualified Pact.Core.Guards as Pact5 +import qualified Data.Set as Set +import qualified Pact.Core.Names as Pact5 -- ---------------------------------------------------------------------- -- @@ -204,180 +194,10 @@ buildExecWithoutData = void $ buildExecParsedCode maxBound Nothing "(+ 1 1)" badMinerId :: MinerId badMinerId = MinerId "alpha\" (read-keyset \"miner-keyset\") 9999999.99)(coin.coinbase \"alpha" -minerKeys0 :: MinerKeys -minerKeys0 = MinerKeys $ mkKeySet - ["f880a433d6e2a13a32b6169030f56245efdd8c1b8a5027e9ce98a88e886bef27"] - "default" - --- ---------------------------------------------------------------------- -- --- Vuln 792 fork tests - -testCoinbase797DateFix :: TestTree -testCoinbase797DateFix = testCaseSteps "testCoinbase791Fix" $ \step -> do - (pdb,mc) <- loadCC coinReplV1 - - step "pre-fork code injection succeeds, no enforced precompile" - - cmd <- buildExecParsedCode maxBound Nothing "(coin.get-balance \"tester01\")" - - doCoinbaseExploit pdb mc preForkHeight cmd False $ \case - Left _ -> assertFailure "local call to get-balance failed" - Right (PLiteral (LDecimal d)) - | d == 1000.1 -> return () - | otherwise -> assertFailure $ "miner balance is incorrect: " <> show d - Right l -> assertFailure $ "wrong return type: " <> show l - - step "post-fork code injection fails, no enforced precompile" - - cmd' <- buildExecParsedCode maxBound Nothing - "(coin.get-balance \"tester01\\\" (read-keyset \\\"miner-keyset\\\") 1000.0)(coin.coinbase \\\"tester01\")" - - doCoinbaseExploit pdb mc postForkHeight cmd' False $ \case - Left _ -> assertFailure "local call to get-balance failed" - Right (PLiteral (LDecimal d)) - | d == 0.1 -> return () - | otherwise -> assertFailure $ "miner balance is incorrect: " <> show d - Right l -> assertFailure $ "wrong return type: " <> show l - - step "pre-fork code injection fails, enforced precompile" - - doCoinbaseExploit pdb mc preForkHeight cmd' True $ \case - Left _ -> assertFailure "local call to get-balance failed" - Right (PLiteral (LDecimal d)) - | d == 0.2 -> return () - | otherwise -> assertFailure $ "miner balance is incorrect: " <> show d - Right l -> assertFailure $ "wrong return type: " <> show l - - step "post-fork code injection fails, enforced precompile" - - doCoinbaseExploit pdb mc postForkHeight cmd' True $ \case - Left _ -> assertFailure "local call to get-balance failed" - Right (PLiteral (LDecimal d)) - | d == 0.3 -> return () - | otherwise -> assertFailure $ "miner balance is incorrect: " <> show d - Right l -> assertFailure $ "wrong return type: " <> show l - - where - doCoinbaseExploit pdb mc height localCmd precompile testResult = do - let ctx = Pact4.TxContext (mkTestParentHeader $ height - 1) noPublicMeta miner - - void $ applyCoinbase Mainnet01 logger pdb 0.1 ctx - (EnforceCoinbaseFailure True) (Pact4.CoinbaseUsePrecompiled precompile) mc - - let h = H.toUntypedHash (H.hash "" :: H.PactHash) - tenv = TransactionEnv Transactional pdb logger Nothing noPublicData - noSPVSupport Nothing 0.0 (RequestKey h) 0 emptyExecutionConfig Nothing Nothing - txst = TransactionState mempty mempty 0 Nothing (_geGasModel freeGasEnv) mempty - - CommandResult _ _ (PactResult pr) _ _ _ _ _ <- evalTransactionM tenv txst $! - applyExec 0 defaultInterpreter localCmd [] [] h permissiveNamespacePolicy - - testResult pr - - miner = Miner - (MinerId "tester01\" (read-keyset \"miner-keyset\") 1000.0)(coin.coinbase \"tester01") - (MinerKeys $ mkKeySet ["b67e109352e8e33c8fe427715daad57d35d25d025914dd705b97db35b1bfbaa5"] "keys-all") - - preForkHeight = 121451 - postForkHeight = 121452 - - -- | someBlockHeader is a bit slow for the vuln797Fix to trigger. So, instead - -- of mining a full chain we fake the height. - -- - mkTestParentHeader :: BlockHeight -> ParentHeader - mkTestParentHeader h = ParentHeader $ someBlockHeader (slowForkingCpmTestVersion singleton) 10 - & blockHeight .~ h - -testCoinbaseEnforceFailure :: Assertion -testCoinbaseEnforceFailure = do - (pdb,mc) <- loadCC coinReplV4 - r <- tryAllSynchronous $ - applyCoinbase toyVersion logger pdb 0.1 - (Pact4.TxContext someParentHeader noPublicMeta badMiner) - (EnforceCoinbaseFailure True) (Pact4.CoinbaseUsePrecompiled False) mc - case r of - Left e -> - if isInfixOf "CoinbaseFailure" (sshow e) then - return () - else assertFailure $ "Coinbase failed for unknown reason: " <> show e - Right _ -> assertFailure "Coinbase did not fail for bad miner id" - where - badMiner = Miner (MinerId "") (MinerKeys $ mkKeySet [] "<") - blockHeight' = 123 - someParentHeader = ParentHeader $ someTestVersionHeader - & blockHeight .~ blockHeight' - & blockCreationTime .~ BlockCreationTime [timeMicrosQQ| 2019-12-10T01:00:00.0 |] - -testCoinbaseUpgradeDevnet :: V.ChainId -> BlockHeight -> Assertion -testCoinbaseUpgradeDevnet cid upgradeHeight = - testUpgradeScript "test/pact/coin-and-devaccts.repl" cid upgradeHeight test - where - test (T2 cr mcm) = case (_crLogs cr,mcm) of - (_,Nothing) -> assertFailure "Expected module cache from successful upgrade" - (Nothing,_) -> assertFailure "Expected logs from successful upgrade" - (Just logs,_) -> - matchLogs (logResults logs) expectedResults - - expectedResults = - [ ("USER_coin_coin-table", "NoMiner", Just (Number 0.1)) - , ("SYS_modules","fungible-v2",Nothing) - , ("SYS_modules","coin",Nothing) - , ("USER_coin_coin-table","sender07",Just (Number 998662.3)) - , ("USER_coin_coin-table","sender09",Just (Number 998662.1)) - ] - -testTwentyChainDevnetUpgrades :: TestTree -testTwentyChainDevnetUpgrades = testCaseSteps "Test 20-chain Devnet upgrades" $ \step -> do - step "Check that 20-chain upgrades fire at block height 60" - testUpgradeScript "test/pact/twenty-chain-upgrades.repl" (unsafeChainId 0) 60 test0 - - step "Check that 20-chain upgrades do not fire at block heights < 60 and > 60" - testUpgradeScript "test/pact/twenty-chain-upgrades.repl" (unsafeChainId 0) (60 - 1) test1 - testUpgradeScript "test/pact/twenty-chain-upgrades.repl" (unsafeChainId 0) (60 + 1) test1 - - step "Check that 20-chain upgrades do not fire at on other chains" - testUpgradeScript "test/pact/twenty-chain-upgrades.repl" (unsafeChainId 1) 60 test1 - - step "Check that 20-chain upgrades succeed even if e7f7 balance is insufficient" - testUpgradeScript "test/pact/twenty-chain-insufficient-bal.repl" (unsafeChainId 0) 60 test1 - where - test0 (T2 cr _) = case _crLogs cr of - Just logs -> matchLogs (logResults logs) - [ ("USER_coin_coin-table","NoMiner",Just (Number 0.1)) - , ( "USER_coin_coin-table" - , "e7f7634e925541f368b827ad5c72421905100f6205285a78c19d7b4a38711805" - , Just (Number 50.0) -- 100.0 tokens remediated - ) - ] - Nothing -> assertFailure "Expected logs from upgrade" - - test1 (T2 cr _) = case _crLogs cr of - Just logs -> matchLogs (logResults logs) - [ ("USER_coin_coin-table", "NoMiner", Just (Number 0.1)) - ] - Nothing -> assertFailure "Expected logs from upgrade" - --- ---------------------------------------------------------------------- -- --- Utils - -testUpgradeScript - :: FilePath - -> V.ChainId - -> BlockHeight - -> (T2 (CommandResult [TxLogJson]) (Maybe Pact4.ModuleCache) -> IO ()) - -> IO () -testUpgradeScript script cid bh test = do - (pdb, mc) <- loadScript script - r <- tryAllSynchronous $ applyCoinbase v logger pdb 0.1 (Pact4.TxContext parent noPublicMeta noMiner) - (EnforceCoinbaseFailure True) (Pact4.CoinbaseUsePrecompiled False) mc - case r of - Left e -> assertFailure $ "tx execution failed: " ++ show e - Right cr -> test cr - where - parent = ParentHeader $ someBlockHeader v bh - & blockChainwebVersion .~ _versionCode v - & blockChainId .~ cid - & blockHeight .~ pred bh +minerKeys0 :: MinerGuard +minerKeys0 = MinerGuard $ Pact5.GKeyset $ Pact5.KeySet + (Set.fromList [Pact5.PublicKeyText "f880a433d6e2a13a32b6169030f56245efdd8c1b8a5027e9ce98a88e886bef27"]) + (Pact5.CustomPredicate (fromJuste $ Pact5.parseParsedTyName "default")) matchLogs :: [(Text, Text, Maybe Value)] -> [(Text, Text, Maybe Value)] -> IO () matchLogs expectedResults actualResults diff --git a/test/unit/Chainweb/Test/Pact4/VerifierPluginTest.hs b/test/unit/Chainweb/Test/Pact4/VerifierPluginTest.hs index 16c0f69d1c..048569f834 100644 --- a/test/unit/Chainweb/Test/Pact4/VerifierPluginTest.hs +++ b/test/unit/Chainweb/Test/Pact4/VerifierPluginTest.hs @@ -4,13 +4,9 @@ module Chainweb.Test.Pact4.VerifierPluginTest import Test.Tasty -import Chainweb.Storage.Table.RocksDB - -import qualified Chainweb.Test.Pact4.VerifierPluginTest.Transaction import qualified Chainweb.Test.Pact4.VerifierPluginTest.Unit -tests :: RocksDb -> TestTree -tests rdb = testGroup "Chainweb.Test.Pact4.VerifierPluginTest" +tests :: TestTree +tests = testGroup "Chainweb.Test.Pact4.VerifierPluginTest" [ Chainweb.Test.Pact4.VerifierPluginTest.Unit.tests - , Chainweb.Test.Pact4.VerifierPluginTest.Transaction.tests rdb ] diff --git a/test/unit/Chainweb/Test/Pact5/CheckpointerTest.hs b/test/unit/Chainweb/Test/Pact5/CheckpointerTest.hs deleted file mode 100644 index f1ad384dd7..0000000000 --- a/test/unit/Chainweb/Test/Pact5/CheckpointerTest.hs +++ /dev/null @@ -1,322 +0,0 @@ -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE QuantifiedConstraints #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE NumericUnderscores #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE ViewPatterns #-} - -module Chainweb.Test.Pact5.CheckpointerTest (tests) where - -import Chainweb.BlockHeader -import Chainweb.Graph (singletonChainGraph) -import Chainweb.Logger -import Chainweb.MerkleLogHash -import Chainweb.MerkleUniverse (ChainwebMerkleHashAlgorithm) -import Chainweb.Pact.Types -import Chainweb.Test.TestVersions -import Chainweb.Test.Utils hiding (withTempSQLiteResource) -import Chainweb.Time -import Chainweb.Utils -import Chainweb.Utils.Serialization (runGetS, runPutS) -import Chainweb.Version -import Control.Exception (evaluate) -import Control.Exception.Safe -import Control.Lens -import Control.Monad -import Control.Monad.IO.Class -import Data.ByteString (ByteString) -import Data.Foldable -import Data.Functor.Product -import qualified Data.Map as Map -import Data.MerkleLog (MerkleNodeType(..), merkleRoot, merkleTree) -import Data.Text (Text) -import qualified Data.Text as T -import qualified Data.Text.Encoding as T -import Hedgehog hiding (Update) -import qualified Hedgehog.Gen as Gen -import qualified Hedgehog.Range as Range -import Numeric.AffineSpace -import Pact.Core.Builtin -import Pact.Core.Evaluate (Info) -import Pact.Core.Literal -import Pact.Core.Names -import qualified Pact.Core.PactDbRegression as Pact -import Pact.Core.PactValue -import Pact.Core.Persistence -import qualified Streaming.Prelude as Stream -import Test.Tasty -import Test.Tasty.HUnit (assertEqual, testCase) -import Test.Tasty.Hedgehog -import Chainweb.Test.Pact5.Utils -import Chainweb.Pact5.Backend.ChainwebPactDb (Pact5Db(doPact5DbTransaction)) -import Chainweb.Pact5.Types (noInfo) -import Chainweb.Pact.Backend.Types -import qualified Chainweb.Pact.PactService.Checkpointer.Internal as Checkpointer - --- | A @DbAction f@ is a description of some action on the database together with an f-full of results for it. -type DbValue = Integer -data DbAction f - = DbRead !T.Text RowKey (f (Either Text (Maybe DbValue))) - | DbWrite WriteType !T.Text RowKey DbValue (f (Either Text ())) - | DbKeys !T.Text (f (Either Text [RowKey])) - | DbSelect !T.Text (f (Either Text [(RowKey, Integer)])) - | DbCreateTable T.Text (f (Either Text ())) - -mkTableName :: T.Text -> TableName -mkTableName n = TableName n (ModuleName "mod" Nothing) - -genDbAction :: Gen (DbAction (Const ())) -genDbAction = do - let tn = Gen.choice [pure "A", pure "B", pure "C"] - Gen.choice - [ DbRead - <$> tn - <*> Gen.choice (pure . RowKey <$> ["A", "B", "C"]) - <*> pure (Const ()) - , DbWrite - <$> genWriteType - <*> tn - <*> Gen.choice (pure . RowKey <$> ["A", "B", "C"]) - <*> fmap fromIntegral (Gen.int (Range.constant 0 5)) - <*> pure (Const ()) - , DbKeys <$> tn <*> pure (Const ()) - , DbSelect <$> tn <*> pure (Const ()) - , DbCreateTable <$> tn <*> pure (Const ()) - ] - where - genWriteType = Gen.choice $ fmap pure - [ Write - , Insert - , Update - ] - --- a block is a list of actions -type DbBlock f = [DbAction f] - -genDbBlock :: Gen (DbBlock (Const ())) -genDbBlock = Gen.list (Range.constant 1 20) genDbAction - -genBlockHistory :: Gen [DbBlock (Const ())] -genBlockHistory = do - let create tn = DbCreateTable tn (Const ()) - blocks <- Gen.list (Range.linear 1 20) genDbBlock - -- we always start by making tables A and B to ensure the tests do something, - -- but we leave table C uncreated to leave some room for divergent table sets - return $ [create "A", create "B"] : blocks - -hoistDbAction :: (forall a. (Eq a, Show a) => f a -> g a) -> DbAction f -> DbAction g -hoistDbAction f (DbRead tn k r) = DbRead tn k (f r) -hoistDbAction f (DbWrite wt tn k v r) = DbWrite wt tn k v (f r) -hoistDbAction f (DbKeys tn ks) = DbKeys tn (f ks) -hoistDbAction f (DbSelect tn rs) = DbSelect tn (f rs) -hoistDbAction f (DbCreateTable tn es) = DbCreateTable tn (f es) - -tryShow :: IO a -> IO (Either Text a) -tryShow = handleAny (fmap Left . \case - (fromException -> Just (PactInternalError _ text)) -> return text - e -> return $ sshow e - ) . fmap Right - --- Run an empty DbAction, annotating it with its result -runDbAction :: PactDb CoreBuiltin Info -> DbAction (Const ()) -> IO (DbAction Identity) -runDbAction pactDB act = - fmap (hoistDbAction (\(Pair (Const ()) fa) -> fa)) - $ runDbAction' pactDB act - -extractInt :: RowData -> IO Integer -extractInt (RowData m) = evaluate (m ^?! ix (Field "k") . _PLiteral . _LInteger) - --- Annotate a DbAction with its result, including any other contents it has -runDbAction' :: PactDb CoreBuiltin Info -> DbAction f -> IO (DbAction (Product f Identity)) -runDbAction' pactDB = \case - DbRead tn k v -> do - maybeValue <- tryShow $ ignoreGas noInfo $ _pdbRead pactDB (DUserTables (mkTableName tn)) k - integerValue <- (traverse . traverse) extractInt maybeValue - return $ DbRead tn k $ Pair v (Identity integerValue) - DbWrite wt tn k v s -> - fmap (DbWrite wt tn k v . Pair s . Identity) - $ tryShow $ ignoreGas noInfo - $ _pdbWrite pactDB wt (DUserTables (mkTableName tn)) k (RowData $ Map.singleton (Field "k") $ PLiteral $ LInteger v) - DbKeys tn ks -> - fmap (DbKeys tn . Pair ks . Identity) - $ tryShow $ ignoreGas noInfo $ _pdbKeys pactDB (DUserTables (mkTableName tn)) - DbSelect tn rs -> - fmap (DbSelect tn . Pair rs . Identity) - $ tryShow $ do - ks <- ignoreGas noInfo $ _pdbKeys pactDB (DUserTables (mkTableName tn)) - traverse (\k -> fmap (k,) . extractInt . fromJuste =<< ignoreGas noInfo (_pdbRead pactDB (DUserTables (mkTableName tn)) k)) ks - DbCreateTable tn s -> - fmap (DbCreateTable tn . Pair s . Identity) - $ tryShow (ignoreGas noInfo $ _pdbCreateUserTable pactDB (mkTableName tn)) - --- craft a fake block header from txlogs, i.e. some set of writes. --- that way, the block header changes if the write set stops agreeing. -blockHeaderFromTxLogs :: ParentHeader -> [TxLog ByteString] -> IO BlockHeader -blockHeaderFromTxLogs ph txLogs = do - let - logMerkleTree = merkleTree @ChainwebMerkleHashAlgorithm @ByteString - [ TreeNode $ merkleRoot $ merkleTree - [ InputNode (T.encodeUtf8 (_txDomain txLog)) - , InputNode (T.encodeUtf8 (_txKey txLog)) - , InputNode (_txValue txLog) - ] - | txLog <- txLogs - ] - encodedLogRoot = runPutS $ encodeMerkleLogHash $ MerkleLogHash $ merkleRoot logMerkleTree - fakePayloadHash <- runGetS decodeBlockPayloadHash encodedLogRoot - return $ newBlockHeader - (_versionForkNumber (_chainwebVersion ph)) - mempty - fakePayloadHash - (Nonce 0) - (view blockCreationTime (_parentHeader ph) .+^ TimeSpan (1_000_000 :: Micros)) - ph - --- TODO things to test later: --- that a tree of blocks can be explored, such that reaching any particular block gives identical results to running to that block from genesis --- more specific regressions, like in the Pact 4 checkpointer test - -runBlocks - :: Checkpointer GenericLogger - -> ParentHeader - -> [DbBlock (Const ())] - -> IO [(BlockHeader, DbBlock Identity)] -runBlocks cp rewindPt blks = do - ((), finishedBlks) <- Checkpointer.restoreAndSave cp (Just rewindPt) $ traverse_ Stream.yield - [ Pact5RunnableBlock $ \db ph startHandle -> do - doPact5DbTransaction db startHandle Nothing $ \txdb -> do - runBlk txdb ph (traverse (runDbAction txdb) blk) - | blk <- blks - ] - return finishedBlks - -runBlk - :: PactDb x Info - -> Maybe ParentHeader - -> IO r - -> IO ([(BlockHeader, r)], BlockHeader) -runBlk txdb ph blk = do - _ <- ignoreGas noInfo $ _pdbBeginTx txdb Transactional - blk' <- blk - txLogs <- ignoreGas noInfo $ _pdbCommitTx txdb - bh <- blockHeaderFromTxLogs (fromJuste ph) txLogs - return ([(bh, blk')], bh) - --- Check that a block's result at the time it was added to the checkpointer --- is consistent with us executing that block with `readFrom` -assertBlock :: Checkpointer GenericLogger -> ParentHeader -> (BlockHeader, DbBlock Identity) -> IO () -assertBlock cp ph (expectedBh, blk) = do - hist <- Checkpointer.readFrom cp (Just ph) Pact5T $ \db startHandle -> do - ((), _endHandle) <- doPact5DbTransaction db startHandle Nothing $ \txdb -> do - _ <- ignoreGas noInfo $ _pdbBeginTx txdb Transactional - blk' <- forM blk (runDbAction' txdb) - txLogs <- ignoreGas noInfo $ _pdbCommitTx txdb - forM_ blk' $ \case - DbRead _d _k (Pair expected actual) -> - assertEqual "read result" expected actual - DbWrite _wt _d _k _v (Pair expected actual) -> - assertEqual "write result" expected actual - DbKeys _d (Pair expected actual) -> - assertEqual "keys result" expected actual - DbSelect _d (Pair expected actual) -> - assertEqual "select result" expected actual - DbCreateTable _tn (Pair expected actual) -> - assertEqual "create table result" expected actual - - actualBh <- blockHeaderFromTxLogs ph txLogs - assertEqual "block header" expectedBh actualBh - return () - throwIfNoHistory hist - -tests :: TestTree -tests = testGroup "Pact5 Checkpointer tests" - [ withResourceT (liftIO . initCheckpointer testVer cid =<< withTempSQLiteResource) $ \cpIO -> - testCase "valid PactDb before genesis" $ do - cp <- cpIO - ((), _handle) <- (throwIfNoHistory =<<) $ - Checkpointer.readFrom cp Nothing Pact5T $ \db blockHandle -> do - doPact5DbTransaction db blockHandle Nothing $ \txdb -> - Pact.runPactDbRegression txdb - return () - , withResourceT (liftIO . initCheckpointer testVer cid =<< withTempSQLiteResource) $ \cpIO -> - testProperty "readFrom with linear block history is valid" $ withTests 1000 $ property $ do - blocks <- forAll genBlockHistory - evalIO $ do - cp <- cpIO - -- extend this empty chain with the genesis block - ((), ()) <- Checkpointer.restoreAndSave cp Nothing $ Stream.yield $ Pact5RunnableBlock $ \_ _ hndl -> - return (((), gh), hndl) - -- run all of the generated blocks - finishedBlocks <- runBlocks cp (ParentHeader gh) blocks - let - finishedBlocksWithParents = - zip (fmap ParentHeader $ gh : (fst <$> finishedBlocks)) finishedBlocks - -- assert that using readFrom to read from a parent, then executing the same block, - -- gives the same results - forM_ finishedBlocksWithParents $ \(ph, block) -> do - assertBlock cp ph block - , withResourceT (liftIO . initCheckpointer testVer cid =<< withTempSQLiteResource) $ \cpIO -> - testCase "reading doesn't duplicate keys results" $ do - cp <- cpIO - _ <- Checkpointer.restoreAndSave cp Nothing $ Stream.yield $ Pact5RunnableBlock $ \_ _ hndl -> - return (((), gh), hndl) - _ <- Checkpointer.restoreAndSave cp (Just $ ParentHeader gh) $ do - let coinTable = TableName "coin-table" (ModuleName "coin" Nothing) - let domain = DUserTables coinTable - Stream.yield $ Pact5RunnableBlock $ \db ph hndl -> - doPact5DbTransaction db hndl Nothing $ \txdb -> - runBlk txdb ph $ do - ignoreGas noInfo $ _pdbCreateUserTable txdb - coinTable - ignoreGas noInfo $ _pdbWrite txdb Insert - domain - (RowKey "k") - (RowData $ Map.singleton (Field "f") (PString "value")) - Stream.yield $ Pact5RunnableBlock $ \db ph hndl -> - doPact5DbTransaction db hndl Nothing $ \txdb -> - runBlk txdb ph $ do - _ <- ignoreGas noInfo $ _pdbRead txdb - domain - (RowKey "k") - keys <- ignoreGas noInfo $ _pdbKeys txdb domain - assertEqual "keys after reading" [RowKey "k"] keys - - return () - ] - -testVer :: ChainwebVersion -testVer = pact5CheckpointerTestVersion singletonChainGraph - -cid :: ChainId -cid = unsafeChainId 0 - -gh :: BlockHeader -gh = genesisBlockHeader testVer cid - -instance (forall a. Show a => Show (f a)) => Show (DbAction f) where - showsPrec n (DbRead tn k v) = showParen (n > 10) $ - showString "DbRead " . showsPrec 11 tn - . showString " " . showsPrec 11 k - . showString " " . showsPrec 11 v - showsPrec n (DbWrite wt tn k v r) = showParen (n > 10) $ - showString "DbWrite " . showsPrec 11 wt - . showString " " . showsPrec 11 tn - . showString " " . showsPrec 11 k - . showString " " . showsPrec 11 v - . showString " " . showsPrec 11 r - showsPrec n (DbKeys tn ks) = showParen (n > 10) $ - showString "DbKeys " . showsPrec 11 tn - . showString " " . showsPrec 11 ks - showsPrec n (DbSelect tn rs) = showParen (n > 10) $ - showString "DbSelect " . showsPrec 11 tn - . showString " " . showsPrec 11 rs - showsPrec n (DbCreateTable tn r) = showParen (n > 10) $ - showString "DbSelect " . showsPrec 11 tn - . showString " " . showsPrec 11 r diff --git a/test/unit/Chainweb/Test/Pact5/CutFixture.hs b/test/unit/Chainweb/Test/Pact5/CutFixture.hs deleted file mode 100644 index 5b72848159..0000000000 --- a/test/unit/Chainweb/Test/Pact5/CutFixture.hs +++ /dev/null @@ -1,350 +0,0 @@ -{-# language - BangPatterns - , ConstraintKinds - , DataKinds - , DeriveAnyClass - , DerivingStrategies - , FlexibleContexts - , FlexibleInstances - , ImplicitParams - , ImportQualifiedPost - , LambdaCase - , MultiParamTypeClasses - , NumericUnderscores - , OverloadedStrings - , PackageImports - , RankNTypes - , RecordWildCards - , ScopedTypeVariables - , TemplateHaskell - , TupleSections - , TypeApplications - , ViewPatterns -#-} - --- | A fixture which provides access to the internals of a running node, with --- multiple chains. Usually, you initialize it with `mkFixture`, insert --- transactions into the mempool as desired, and use `advanceAllChains` to --- trigger mining on all chains at once. -module Chainweb.Test.Pact5.CutFixture - ( Fixture(..) - , HasFixture(..) - , mkFixture - , fixtureCutDb - , fixturePayloadDb - , fixtureWebBlockHeaderDb - , fixtureWebPactExecutionService - , fixtureMempools - , fixturePactQueues - , advanceAllChains - , advanceAllChains_ - , advanceToForkHeight - , withTestCutDb - ) - where - -import Chainweb.BlockCreationTime (BlockCreationTime(..)) -import Chainweb.BlockHash (BlockHash) -import Chainweb.BlockHeader hiding (blockCreationTime, blockNonce) -import Chainweb.BlockHeader.Internal (blockCreationTime, blockNonce) -import Chainweb.ChainId -import Chainweb.ChainValue (ChainValue(..), ChainValueCasLookup, chainLookupM) -import Chainweb.Cut -import Chainweb.Cut.Create (InvalidSolvedHeader(..), WorkHeader(..), SolvedWork(..), extendCut, getCutExtension, newWorkHeaderPure) -import Chainweb.Cut.CutHashes -import Chainweb.CutDB -import Chainweb.Logger -import Chainweb.Mempool.Mempool (MempoolBackend) -import Chainweb.Miner.Pact -import Chainweb.Pact.PactService.Pact4.ExecBlock () -import Chainweb.Pact.Service.PactQueue -import Chainweb.Pact.Types -import Chainweb.Pact4.Transaction qualified as Pact4 -import Chainweb.Payload -import Chainweb.Payload.PayloadStore -import Chainweb.Storage.Table (Casify) -import Chainweb.Storage.Table.RocksDB -import Chainweb.Sync.WebBlockHeaderStore -import Chainweb.Test.Pact5.Utils -import Chainweb.Test.Utils -import Chainweb.Time -import Chainweb.Utils -import Chainweb.Utils.Serialization (runGetS, runPutS) -import Chainweb.Version -import Chainweb.Version.Utils -import Chainweb.WebBlockHeaderDB -import Chainweb.WebPactExecutionService -import Control.Concurrent.STM as STM -import Control.Lens hiding (elements, only) -import Control.Monad -import Control.Monad.Catch hiding (finally) -import Control.Monad.IO.Class -import Control.Monad.Trans.Resource (ResourceT, allocate) -import Data.ByteString.Lazy qualified as LBS -import Data.ByteString.Short qualified as SBS -import Data.Function -import Data.HashMap.Strict qualified as HashMap -import Data.HashSet qualified as HashSet -import Data.Maybe (fromMaybe) -import Data.Text (Text) -import Data.Text qualified as Text -import Data.Vector (Vector) -import GHC.Stack -import Network.HTTP.Client qualified as HTTP - -data Fixture = Fixture - { _fixtureCutDb :: CutDb RocksDbTable - , _fixturePayloadDb :: PayloadDb RocksDbTable - , _fixtureWebBlockHeaderDb :: WebBlockHeaderDb - , _fixtureWebPactExecutionService :: WebPactExecutionService - , _fixtureMempools :: ChainMap (MempoolBackend Pact4.UnparsedTransaction) - , _fixturePactQueues :: ChainMap PactQueue - } -makeLenses ''Fixture - -class HasFixture a where - cutFixture :: a -> IO Fixture -instance HasFixture Fixture where - cutFixture = return -instance HasFixture a => HasFixture (IO a) where - cutFixture = (>>= cutFixture) - -mkFixture :: ChainwebVersion -> PactServiceConfig -> RocksDb -> ResourceT IO Fixture -mkFixture v pactServiceConfig baseRdb = do - logger <- liftIO getTestLogger - testRdb <- liftIO $ testRocksDb "withBlockDbs" baseRdb - (payloadDb, webBHDb) <- withBlockDbs v testRdb - perChain <- iforM (HashSet.toMap (chainIds v)) $ \chain () -> do - pactQueue <- liftIO $ newPactQueue 2_000 - mempool <- withMempool v chain pactQueue - withRunPactService logger v chain pactQueue mempool webBHDb payloadDb pactServiceConfig - return (mempool, pactQueue) - let webPact = mkWebPactExecutionService $ HashMap.map (mkPactExecutionService . snd) perChain - let cutHashesStore = cutHashesTable testRdb - cutDb <- withTestCutDb logger v webBHDb payloadDb cutHashesStore webPact - - let fixture = Fixture - { _fixtureCutDb = cutDb - , _fixturePayloadDb = payloadDb - , _fixtureWebBlockHeaderDb = webBHDb - , _fixtureWebPactExecutionService = webPact - , _fixtureMempools = OnChains $ fst <$> perChain - , _fixturePactQueues = OnChains $ snd <$> perChain - } - -- we create the first block to avoid rejecting txs based on genesis - -- block creation time being from the past - _ <- liftIO $ advanceAllChains fixture - return fixture - --- | Advance all chains by one block, filling that block with whatever is in --- their mempools at the time. --- -advanceAllChains - :: (HasCallStack, HasFixture a) - => a - -> IO (Cut, ChainMap (Vector TestPact5CommandResult)) -advanceAllChains fx = do - Fixture{..} <- cutFixture fx - let v = _chainwebVersion _fixtureCutDb - latestCut <- liftIO $ _fixtureCutDb ^. cut - let blockHeights = fmap (view blockHeight) $ latestCut ^. cutMap - let latestBlockHeight = maximum blockHeights - - -- TODO: rejig this to do parallel mining. - (finalCut, perChainCommandResults) <- foldM - (\ (prevCut, !acc) cid -> do - (newCut, _minedChain, pwo) <- - mine cid noMiner NewBlockFill _fixtureWebPactExecutionService _fixtureCutDb prevCut - commandResults <- forM (_payloadWithOutputsTransactions pwo) $ \(_, txOut) -> do - decodeOrThrow' $ LBS.fromStrict $ _transactionOutputBytes txOut - - addNewPayload _fixturePayloadDb latestBlockHeight pwo - - return $ (newCut, (cid, commandResults) : acc) - ) - (latestCut, []) - (HashSet.toList (chainIdsAt v (latestBlockHeight + 1))) - - return (finalCut, onChains perChainCommandResults) - -advanceAllChains_ - :: (HasCallStack, HasFixture a) - => a - -> IO () -advanceAllChains_ = void . advanceAllChains - --- Advance to the forkheight of a fork. --- --- Throws an 'error' if the fork is not found in the ChainwebVersion '_versionForks', or if --- the fork height is ever 'ForkNever' or 'ForkGenesis' on all chains. --- --- Does nothing if you are already at or past the the forkheight. -advanceToForkHeight :: (HasCallStack, HasFixture fx) => fx -> Fork -> IO () -advanceToForkHeight fx fork = do - Fixture{..} <- cutFixture fx - let v = _chainwebVersion _fixtureCutDb - latestCut <- liftIO $ _fixtureCutDb ^. cut - let latestBlockHeight = latestCut ^. cutMaxHeight - - let targetHeight = fromMaybe (error "advanceToForkHeight: no fork found") $ - maximumOf (versionForks . ix fork . folded . _ForkAtBlockHeight) v - - when (targetHeight > latestBlockHeight) $ do - replicateM_ (int (targetHeight - latestBlockHeight)) $ advanceAllChains_ fx - -withTestCutDb :: (Logger logger) - => logger - -> ChainwebVersion - -> WebBlockHeaderDb - -> PayloadDb RocksDbTable - -> Casify RocksDbTable CutHashes - -> WebPactExecutionService - -> ResourceT IO (CutDb RocksDbTable) -withTestCutDb logger v webBHDb payloadDb cutHashesStore webPact = snd <$> allocate create destroy - where - create :: IO (CutDb RocksDbTable) - create = do - initializePayloadDb v payloadDb - httpManager <- HTTP.newManager HTTP.defaultManagerSettings - - headerStore <- newWebBlockHeaderStore httpManager webBHDb (logFunction logger) - payloadStore <- newWebPayloadStore httpManager webPact payloadDb (logFunction logger) - - let cutFetchTimeout = 3_000_000 - cutDb <- startCutDb (defaultCutDbParams v cutFetchTimeout) (logFunction logger) headerStore payloadStore cutHashesStore - return cutDb - - destroy :: CutDb RocksDbTable -> IO () - destroy = stopCutDb - --- | Build a linear chainweb (no forks, assuming single threaded use of the --- cutDb). No POW or poison delay is applied. Block times are real times. -mine - :: (HasCallStack, CanReadablePayloadCas tbl) - => ChainId - -> Miner - -- ^ The miner. For testing you may use 'defaultMiner' or 'noMiner'. - -> NewBlockFill - -> WebPactExecutionService - -- ^ only the new-block generator is used. For testing you may use - -- 'fakePact'. - -> CutDb tbl - -> Cut - -> IO (Cut, ChainId, PayloadWithOutputs) -mine cid miner newBlockStrat pact cutDb c = do - tryMineForChain miner newBlockStrat pact cutDb c cid >>= \case - Left _ -> throwM $ InternalInvariantViolation - $ "Failed to create new cut on chain " <> toText cid <> "." - <> "This is a bug in Chainweb.Test.Pact5.CutFixture or one of its users; check that this chain's adjacent chains aren't too far behind." - <> "\nCut: \n" - <> Text.unlines (cutToTextShort c) - Right x -> do - void $ awaitCut cutDb $ ((<=) `on` _cutHeight) (view _1 x) - return x - --- | Atomically await for a 'CutDb' instance to synchronize cuts according to some --- predicate for a given 'Cut' and the results of '_cutStm'. -awaitCut - :: CutDb tbl - -> (Cut -> Bool) - -> IO Cut -awaitCut cdb k = atomically $ do - c <- _cutStm cdb - STM.check $ k c - pure c - -testMineWithPayloadHash - :: forall cid hdb. (HasChainId cid, ChainValueCasLookup hdb BlockHeader) - => hdb - -> Nonce - -> Time Micros - -> BlockPayloadHash - -> cid - -> Cut - -> IO (Either MineFailure (T2 BlockHeader Cut)) -testMineWithPayloadHash db n t ph cid c = try $ createNewCut (chainLookupM db) n t ph cid c - --- | Create a new block. Only produces a new cut but doesn't insert it into the --- chain database. --- --- The creation time isn't checked. --- -createNewCut - :: (HasCallStack, MonadCatch m, MonadIO m, HasChainId cid) - => (ChainValue BlockHash -> m BlockHeader) - -> Nonce - -> Time Micros - -> BlockPayloadHash - -> cid - -> Cut - -> m (T2 BlockHeader Cut) -createNewCut hdb n t pay i c = do - extension <- fromMaybeM BadAdjacents $ getCutExtension c i - work <- newWorkHeaderPure hdb (_versionForkNumber $ _chainwebVersion c) (BlockCreationTime t) extension pay - (h, mc') <- extendCut c pay (solveWork work n t) - `catch` \(InvalidSolvedHeader _ msg) -> throwM $ InvalidHeader msg - c' <- fromMaybeM BadAdjacents mc' - return $ T2 h c' - --- | Solve Work. Doesn't check that the nonce and the time are valid. --- -solveWork :: HasCallStack => WorkHeader -> Nonce -> Time Micros -> SolvedWork -solveWork w n t = - case runGetS decodeBlockHeaderWithoutHash $ SBS.fromShort $ _workHeaderBytes w of - Nothing -> error "Chainwb.Test.Cut.solveWork: Invalid work header bytes" - Just hdr -> SolvedWork - $ fromJuste - $ runGetS decodeBlockHeaderWithoutHash - $ runPutS - $ encodeBlockHeaderWithoutHash - -- After injecting the nonce and the creation time will have to do a - -- serialization roundtrip to update the Merkle hash. - -- - -- A "real" miner would inject the nonce and time without first - -- decoding the header and would hand over the header in serialized - -- form. - - $ set blockCreationTime (BlockCreationTime t) - $ set blockNonce n - $ hdr - --- | Build a linear chainweb (no forks). No POW or poison delay is applied. --- Block times are real times. --- -tryMineForChain - :: forall tbl. (HasCallStack, CanReadablePayloadCas tbl) - => Miner - -- ^ The miner. For testing you may use 'defaultMiner'. - -> NewBlockFill - -> WebPactExecutionService - -> CutDb tbl - -> Cut - -> ChainId - -> IO (Either MineFailure (Cut, ChainId, PayloadWithOutputs)) -tryMineForChain miner newBlockStrat webPact cutDb c cid = do - newBlock <- throwIfNoHistory =<< _webPactNewBlock webPact cid miner newBlockStrat parent - let outputs = newBlockToPayloadWithOutputs newBlock - let payloadHash = _payloadWithOutputsPayloadHash outputs - t <- getCurrentTimeIntegral - x <- testMineWithPayloadHash wdb (Nonce 0) t payloadHash cid c - case x of - Right (T2 h c') -> do - addCutHashes cutDb (cutToCutHashes Nothing c') - { _cutHashesHeaders = HashMap.singleton (view blockHash h) h - , _cutHashesPayloads = HashMap.singleton (view blockPayloadHash h) (payloadWithOutputsToPayloadData outputs) - } - return $ Right (c', cid, outputs) - Left e -> return $ Left e - where - parent = ParentHeader $ c ^?! ixg cid -- parent to mine on - wdb = view cutDbWebBlockHeaderDb cutDb - -data MineFailure - = InvalidHeader Text - -- ^ The header is invalid, e.g. because of a bad nonce or creation time. - | MissingParentHeader - -- ^ A parent header is missing in the chain db - | BadAdjacents - -- ^ This could mean that the chain is blocked. - deriving stock (Show) - deriving anyclass (Exception) diff --git a/test/unit/Chainweb/Test/Pact5/PactServiceTest.hs b/test/unit/Chainweb/Test/Pact5/PactServiceTest.hs deleted file mode 100644 index c348e5998f..0000000000 --- a/test/unit/Chainweb/Test/Pact5/PactServiceTest.hs +++ /dev/null @@ -1,841 +0,0 @@ -{-# language - DataKinds - , FlexibleContexts - , ImpredicativeTypes - , ImportQualifiedPost - , LambdaCase - , NumericUnderscores - , OverloadedStrings - , PackageImports - , ScopedTypeVariables - , TypeApplications - , TemplateHaskell - , RecordWildCards - , TupleSections -#-} - -{-# options_ghc -fno-warn-gadt-mono-local-binds #-} - -module Chainweb.Test.Pact5.PactServiceTest - ( tests - ) where - -import Data.List qualified as List -import "pact" Pact.Types.Command qualified as Pact4 -import "pact" Pact.Types.Hash qualified as Pact4 -import Chainweb.BlockHeader -import Chainweb.BlockHeight -import Chainweb.ChainId -import Chainweb.Chainweb -import Chainweb.Cut -import Chainweb.Graph (singletonChainGraph, pairChainGraph) -import Chainweb.Logger -import Chainweb.Mempool.Consensus -import Chainweb.Mempool.InMem -import Chainweb.Mempool.Mempool (InsertType (..), MempoolBackend (..)) -import Chainweb.Miner.Pact -import Chainweb.Pact.PactService -import Chainweb.Pact.PactService.Pact4.ExecBlock () -import Chainweb.Pact.Service.BlockValidation -import Chainweb.Pact.Service.PactInProcApi -import Chainweb.Pact.Service.PactQueue -import Chainweb.Pact.Types -import Chainweb.Pact4.Transaction qualified as Pact4 -import Chainweb.Pact5.Transaction qualified as Pact5 -import Chainweb.Payload -import Chainweb.Storage.Table.RocksDB -import Chainweb.Test.Cut.TestBlockDb (TestBlockDb (_bdbPayloadDb, _bdbWebBlockHeaderDb), addTestBlockDb, getCutTestBlockDb, getParentTestBlockDb, mkTestBlockDb, setCutTestBlockDb) -import Chainweb.Test.Pact5.CmdBuilder -import Chainweb.Test.Pact5.Utils hiding (withInMemSQLiteResource) -import Chainweb.Test.TestVersions -import Chainweb.Test.Utils -import Chainweb.Time -import Chainweb.Utils -import qualified Data.ByteString.Base64.URL as B64U -import Chainweb.SPV.CreateProof -import Chainweb.Version -import Chainweb.WebBlockHeaderDB (getWebBlockHeaderDb) -import Chainweb.WebPactExecutionService -import Control.Concurrent hiding (throwTo) -import Control.Concurrent.Async (forConcurrently) -import Control.Exception (AsyncException (..)) -import Control.Exception.Safe -import Control.Lens hiding (only) -import Control.Monad -import Control.Monad.IO.Class -import Control.Monad.Trans.Resource -import Control.Monad.Trans.Resource qualified as Resource -import Data.ByteString.Lazy qualified as LBS -import Data.Decimal -import Data.HashMap.Strict qualified as HashMap -import Data.HashSet qualified as HashSet -import Data.Maybe (fromMaybe) -import Pact.Core.Command.RPC (ContMsg (..)) -import Pact.Core.SPV (ContProof(..)) -import Data.Text qualified as T -import Data.Text.IO qualified as Text -import Data.Vector (Vector) -import Data.Vector qualified as Vector -import Pact.Core.Capabilities -import Pact.Core.ChainData hiding (ChainId, _chainId) -import Pact.Core.Command.Types hiding (ChainId) -import Pact.Core.DefPacts.Types -import Pact.Core.Gas.Types -import Pact.Core.Hash qualified as Pact5 -import Pact.Core.Names -import Pact.Core.PactValue -import Pact.Types.Gas qualified as Pact4 -import PropertyMatchers ((?)) -import PropertyMatchers qualified as P -import Test.Tasty -import Test.Tasty.HUnit (assertBool, assertEqual, assertFailure, testCase, (@?=)) -import Text.Printf (printf) - -data Fixture = Fixture - { _fixtureChains :: [ChainId] - , _fixtureBlockDb :: TestBlockDb - , _fixtureMempools :: ChainMap (MempoolBackend Pact4.UnparsedTransaction) - , _fixturePactQueues :: ChainMap PactQueue - } - -mkFixtureWith :: PactServiceConfig -> ChainwebVersion -> RocksDb -> ResourceT IO Fixture -mkFixtureWith pactServiceConfig v' baseRdb = do - - tdb <- mkTestBlockDb v' baseRdb - perChain <- iforM (HashSet.toMap (chainIds v')) $ \chain () -> do - sqlite <- withInMemSQLiteResource - bhdb <- liftIO $ getWebBlockHeaderDb (_bdbWebBlockHeaderDb tdb) chain - pactQueue <- liftIO $ newPactQueue 2_000 - pactExecutionServiceVar <- liftIO $ newMVar (mkPactExecutionService pactQueue) - let mempoolCfg = validatingMempoolConfig chain v' (Pact4.GasLimit 150_000) (Pact4.GasPrice 1e-8) pactExecutionServiceVar - logLevel <- liftIO getTestLogLevel - let logger = genericLogger logLevel Text.putStrLn - mempool <- liftIO $ startInMemoryMempoolTest mempoolCfg - mempoolConsensus <- liftIO $ mkMempoolConsensus mempool bhdb (Just (_bdbPayloadDb tdb)) - let mempoolAccess = pactMemPoolAccess mempoolConsensus logger - _ <- Resource.allocate - (forkIO $ runPactService v' chain logger Nothing pactQueue mempoolAccess bhdb (_bdbPayloadDb tdb) sqlite pactServiceConfig) - (\tid -> throwTo tid ThreadKilled) - return (mempool, pactQueue) - let fixture = Fixture - { _fixtureChains = HashSet.toList $ chainIds v' - , _fixtureBlockDb = tdb - , _fixtureMempools = OnChains $ fst <$> perChain - , _fixturePactQueues = OnChains $ snd <$> perChain - } - -- The mempool expires txs based on current time, but newBlock expires txs based on parent creation time. - -- So by running an empty block with the creationTime set to the current time, we get these goals to align - -- for future blocks we run. - _ <- liftIO $ advanceAllChains fixture $ onChains [] - return fixture - -mkFixture :: RocksDb -> ResourceT IO Fixture -mkFixture = mkFixtureWith testPactServiceConfig v - -mkFixtureDual :: RocksDb -> ResourceT IO Fixture -mkFixtureDual = mkFixtureWith testPactServiceConfig vPair - -tests :: RocksDb -> TestTree -tests baseRdb = testGroup "Pact5 PactServiceTest" - [ testCase "simple end to end" (simpleEndToEnd baseRdb) - , testCase "continue block spec" (continueBlockSpec baseRdb) - , testCase "new block empty" (newBlockEmpty baseRdb) - , testCase "new block timeout spec" (newBlockTimeoutSpec baseRdb) - , testCase "new block excludes invalid transactions" (testNewBlockExcludesInvalid baseRdb) - , testCase "lookup pact txs spec" (lookupPactTxsSpec baseRdb) - , testCase "failed txs should go into blocks" (failedTxsShouldGoIntoBlocks baseRdb) - , testCase "modules with higher level transitive dependencies (simple)" (modulesWithHigherLevelTransitiveDependenciesSimple baseRdb) - , testCase "modules with higher level transitive dependencies (complex)" (modulesWithHigherLevelTransitiveDependenciesComplex baseRdb) - , testCase "apply initial gas model" (testIntialGasModel baseRdb) - ] - -simpleEndToEnd :: RocksDb -> IO () -simpleEndToEnd baseRdb = runResourceT $ do - fixture <- mkFixture baseRdb - liftIO $ do - cmd1 <- buildCwCmd v (transferCmd 1.0) - cmd2 <- buildCwCmd v (transferCmd 2.0) - - results <- advanceAllChainsWithTxs fixture $ onChain chain0 [cmd1, cmd2] - - -- we only care that they succeed; specifics regarding their outputs are in TransactionExecTest - results & - P.alignExact ? onChain chain0 ? - P.alignExact ? Vector.replicate 2 successfulTx - -newBlockEmpty :: RocksDb -> IO () -newBlockEmpty baseRdb = runResourceT $ do - fixture <- mkFixture baseRdb - liftIO $ do - cmd <- buildCwCmd v (transferCmd 1.0) - _ <- advanceAllChains fixture $ onChain chain0 $ \ph pactQueue mempool -> do - mempoolInsertPact5 mempool CheckedInsert [cmd] - -- -- Test that NewBlockEmpty ignores the mempool - emptyBip <- throwIfNotPact5 =<< throwIfNoHistory =<< - newBlock noMiner NewBlockEmpty (ParentHeader ph) pactQueue - let emptyPwo = finalizeBlock emptyBip - assertEqual "empty block has no transactions" 0 (Vector.length $ _payloadWithOutputsTransactions emptyPwo) - return emptyPwo - - results <- advanceAllChains fixture $ onChain chain0 $ \ph pactQueue _ -> do - nonEmptyBip <- throwIfNotPact5 =<< throwIfNoHistory =<< - newBlock noMiner NewBlockFill (ParentHeader ph) pactQueue - return $ finalizeBlock nonEmptyBip - - results & - P.alignExact ? onChain chain0 ? - P.alignExact ? Vector.replicate 1 successfulTx - -continueBlockSpec :: RocksDb -> IO () -continueBlockSpec baseRdb = runResourceT $ do - fixture <- mkFixture baseRdb - liftIO $ do - startCut <- getCut fixture - - -- construct some transactions that we plan to put into the block - cmd1 <- buildCwCmd v (transferCmd 1.0) - cmd2 <- buildCwCmd v (transferCmd 2.0) - cmd3 <- buildCwCmd v (transferCmd 3.0) - - allAtOnceResults <- advanceAllChains fixture $ onChain chain0 $ \ph pactQueue mempool -> do - -- insert all transactions - mempoolInsertPact5 mempool CheckedInsert [cmd1, cmd2, cmd3] - -- construct a new block with all of said transactions - bipAllAtOnce <- throwIfNotPact5 =<< throwIfNoHistory =<< - newBlock noMiner NewBlockFill (ParentHeader ph) pactQueue - return $ finalizeBlock bipAllAtOnce - -- assert that 3 successful txs are in the block - allAtOnceResults & - P.alignExact ? onChain chain0 ? - P.alignExact ? Vector.replicate 3 successfulTx - - -- reset back to the empty block for the next phase - -- next, produce the same block by repeatedly extending a block - -- with the same transactions as were included in the original. - -- note that this will reinsert all txs in the full block into the - -- mempool, so we need to clear it after, or else the block will - -- contain all of the transactions before we extend it. - revert fixture startCut - continuedResults <- advanceAllChains fixture $ onChain chain0 $ \ph pactQueue mempool -> do - mempoolClear mempool - mempoolInsertPact5 mempool CheckedInsert [cmd3] - bipStart <- throwIfNotPact5 =<< throwIfNoHistory =<< - newBlock noMiner NewBlockFill (ParentHeader ph) pactQueue - - mempoolInsertPact5 mempool CheckedInsert [cmd2] - bipContinued <- throwIfNoHistory =<< continueBlock bipStart pactQueue - - mempoolInsertPact5 mempool CheckedInsert [cmd1] - bipFinal <- throwIfNoHistory =<< continueBlock bipContinued pactQueue - - -- We must make progress on the same parent header - assertEqual "same parent header after continuing block" - (_blockInProgressParentHeader bipStart) - (_blockInProgressParentHeader bipContinued) - assertBool "made progress (1)" - (bipStart /= bipContinued) - assertEqual "same parent header after finishing block" - (_blockInProgressParentHeader bipContinued) - (_blockInProgressParentHeader bipFinal) - assertBool "made progress (2)" - (bipContinued /= bipFinal) - - return $ finalizeBlock bipFinal - - -- assert that the continued results are equal to doing it all at once - continuedResults & P.equals allAtOnceResults - --- * test that the NewBlock timeout works properly and doesn't leave any extra state from a timed-out transaction -newBlockTimeoutSpec :: RocksDb -> IO () -newBlockTimeoutSpec baseRdb = runResourceT $ do - let pactServiceConfig = testPactServiceConfig - { _pactTxTimeLimit = Just (Micros 35_000) - -- this may need to be tweaked for CI. - -- it should be long enough that `timeoutTx` times out - -- but neither `tx1` nor `tx2` time out. - } - fixture <- mkFixtureWith pactServiceConfig v baseRdb - - liftIO $ do - tx1 <- buildCwCmd v (defaultCmd chain0) - { _cbRPC = mkExec' "1" - , _cbGasPrice = GasPrice 1.0 - , _cbGasLimit = GasLimit (Gas 400) - } - tx2 <- buildCwCmd v (defaultCmd chain0) - { _cbRPC = mkExec' "2" - , _cbGasPrice = GasPrice 2.0 - , _cbGasLimit = GasLimit (Gas 400) - } - timeoutTx <- buildCwCmd v (defaultCmd chain0) - { _cbRPC = mkExec' $ "(fold + 0 (enumerate 1 500000))" - , _cbGasPrice = GasPrice 1.5 - , _cbGasLimit = GasLimit (Gas 5000) - } - - _ <- advanceAllChains fixture $ onChain chain0 $ \ph pactQueue mempool -> do - mempoolInsertPact5 mempool CheckedInsert [tx2, timeoutTx, tx1] - bip <- throwIfNotPact5 =<< throwIfNoHistory =<< - newBlock noMiner NewBlockFill (ParentHeader ph) pactQueue - -- Mempool orders by GasPrice. 'buildCwCmd' sets the gas price to the transfer amount. - -- We hope for 'timeoutTx' to fail, meaning that only 'txTransfer2' is in the block. - bip & P.fun _blockInProgressTransactions ? P.fun _transactionPairs - ? P.alignExact ? Vector.fromList - [ P.pair - (P.fun _cmdHash ? P.equals (_cmdHash tx2)) - successfulTx - ] - return $ finalizeBlock bip - - pure () - -testNewBlockExcludesInvalid :: RocksDb -> IO () -testNewBlockExcludesInvalid baseRdb = runResourceT $ do - fixture <- mkFixture baseRdb - liftIO $ do - -- The mempool should reject a tx that doesn't parse as valid pact. - badParse <- buildCwCmdNoParse v (defaultCmd chain0) - { _cbRPC = mkExec' "(not a valid pact tx" - } - - regularTx1 <- buildCwCmd v $ transferCmd 1.0 - -- The mempool checks that a tx does not already exist in the chain before adding it. - let badUnique = regularTx1 - - -- The mempool checks that a tx does not have a creation time too far into the future. - badFuture <- buildCwCmd v $ (transferCmd 1.0) - { _cbCreationTime = Just $ TxCreationTime (2 ^ (32 :: Word)) - } - - -- The mempool checks that a tx does not have a creation time too far into the past. - badPast <- buildCwCmd v $ (transferCmd 1.0) - { _cbCreationTime = Just $ TxCreationTime 0 - } - - regularTx2 <- buildCwCmd v $ transferCmd 1.0 - -- The mempool checks that a tx has a valid hash. - let badTxHash = regularTx2 - { _cmdHash = Pact5.Hash "bad hash" - } - - badSigs <- buildCwCmdNoParse v (defaultCmd chain0) - { _cbSigners = - [ CmdSigner - { _csSigner = Signer - { _siScheme = Nothing - , _siPubKey = fst sender00 - , _siAddress = Nothing - , _siCapList = [] - } - , _csPrivKey = snd sender01 - } - ] - } - - badChain <- buildCwCmd v $ transferCmd 1.0 & set cbChainId (chainIdToText $ unsafeChainId 1) - - let pact4Hash = Pact5.Hash . Pact4.unHash . Pact4.toUntypedHash . Pact4._cmdHash - _ <- advanceAllChains fixture $ onChain chain0 $ \ph pactQueue mempool -> do - mempoolInsertPact5 mempool CheckedInsert [regularTx1] - bip <- throwIfNotPact5 =<< throwIfNoHistory =<< newBlock noMiner NewBlockFill (ParentHeader ph) pactQueue - return $ finalizeBlock bip - - _ <- advanceAllChains fixture $ onChain chain0 $ \ph pactQueue mempool -> do - mempoolInsert mempool UncheckedInsert $ Vector.fromList [badParse, badSigs] - mempoolInsertPact5 mempool UncheckedInsert [badChain, badUnique, badFuture, badPast, badTxHash] - bip <- throwIfNotPact5 =<< throwIfNoHistory =<< newBlock noMiner NewBlockFill (ParentHeader ph) pactQueue - let expectedTxs = [] - let actualTxs = Vector.toList $ Vector.map (unRequestKey . _crReqKey . snd) $ _transactionPairs $ _blockInProgressTransactions bip - assertEqual "block has excluded all invalid transactions" expectedTxs actualTxs - return $ finalizeBlock bip - - -- we need to wait until this above block is validate for `badUnique` - -- to disappear, because only the parent block is used to find txs to - -- delete from the mempool - let mempool = _fixtureMempools fixture ^?! atChain chain0 - mempoolInsertPact5 mempool CheckedInsert [badUnique, badFuture, badPast, badTxHash] - - let badTxHashes = - [ pact4Hash badParse - , _cmdHash badUnique - , _cmdHash badFuture - , _cmdHash badPast - , _cmdHash badTxHash - , pact4Hash badSigs - ] - inMempool <- mempoolLookupPact5 mempool (Vector.fromList badTxHashes) - forM_ (zip [0 :: Word ..] badTxHashes) $ \(i, badHash) -> do - assertBool ("bad tx [index = " <> sshow i <> ", hash = " <> sshow badTxHash <> "] should have been evicted from the mempool") $ not $ HashSet.member badHash inMempool - - return () - -lookupPactTxsSpec :: RocksDb -> IO () -lookupPactTxsSpec baseRdb = runResourceT $ do - fixture <- mkFixture baseRdb - liftIO $ do - cmd1 <- buildCwCmd v (transferCmd 1.0) - cmd2 <- buildCwCmd v (transferCmd 2.0) - - -- Depth 0 - _ <- advanceAllChains fixture $ onChain chain0 $ \ph pactQueue mempool -> do - mempoolInsertPact5 mempool CheckedInsert [cmd1, cmd2] - bip <- throwIfNotPact5 =<< throwIfNoHistory =<< newBlock noMiner NewBlockFill (ParentHeader ph) pactQueue - return $ finalizeBlock bip - - let rks = List.sort $ List.map (Pact5.unHash . _cmdHash) [cmd1, cmd2] - - let lookupExpect :: Maybe Word -> IO () - lookupExpect depth = do - txs <- lookupPactTxs (fmap (ConfirmationDepth . fromIntegral) depth) (Vector.fromList rks) (_fixturePactQueues fixture ^?! atChain chain0) - assertEqual ("all txs should be available with depth=" ++ show depth) (HashSet.fromList rks) (HashMap.keysSet txs) - let lookupDontExpect :: Maybe Word -> IO () - lookupDontExpect depth = do - txs <- lookupPactTxs (fmap (ConfirmationDepth. fromIntegral) depth) (Vector.fromList rks) (_fixturePactQueues fixture ^?! atChain chain0) - assertEqual ("no txs should be available with depth=" ++ show depth) HashSet.empty (HashMap.keysSet txs) - - lookupExpect Nothing - lookupExpect (Just 0) - lookupDontExpect (Just 1) - - -- Depth 1 - _ <- advanceAllChains fixture $ onChains [] - - lookupExpect Nothing - lookupExpect (Just 0) - lookupExpect (Just 1) - lookupDontExpect (Just 2) - - -- Depth 2 - _ <- advanceAllChains fixture $ onChains [] - - lookupExpect Nothing - lookupExpect (Just 0) - lookupExpect (Just 1) - lookupExpect (Just 2) - lookupDontExpect (Just 3) - -failedTxsShouldGoIntoBlocks :: RocksDb -> IO () -failedTxsShouldGoIntoBlocks baseRdb = runResourceT $ do - fixture <- mkFixture baseRdb - - liftIO $ do - cmd1 <- buildCwCmd v (transferCmd 1.0) - cmd2 <- buildCwCmd v (defaultCmd chain0) - { _cbRPC = mkExec' "(namespace 'free) (module mod G (defcap G () true) (defun f () true)) (describe-module \"free.mod\")" - -- for ordering the transactions as they appear in the block - , _cbGasPrice = GasPrice 0.1 - , _cbGasLimit = GasLimit (Gas 1000) - } - - -- Depth 0 - _ <- advanceAllChains fixture $ onChain chain0 $ \ph pactQueue mempool -> do - mempoolInsertPact5 mempool CheckedInsert [cmd1, cmd2] - bip <- throwIfNotPact5 =<< throwIfNoHistory =<< newBlock noMiner NewBlockFill (ParentHeader ph) pactQueue - let block = finalizeBlock bip - assertEqual "block has 2 txs even though one of them failed" 2 (Vector.length $ _payloadWithOutputsTransactions block) - return block - - return () - -modulesWithHigherLevelTransitiveDependenciesSimple :: RocksDb -> IO () -modulesWithHigherLevelTransitiveDependenciesSimple baseRdb = runResourceT $ do - fixture <- mkFixture baseRdb - liftIO $ do - cmd1 <- buildCwCmd v (defaultCmd chain0) - { _cbRPC = mkExec' "(namespace 'free) (interface barbar (defconst FOO_CONST:integer 1))" - -- for ordering the transactions as they appear in the block - , _cbGasPrice = GasPrice 0.9 - , _cbGasLimit = GasLimit (Gas 1000) - } - cmd2 <- buildCwCmd v (defaultCmd chain0) - { _cbRPC = mkExec' "(namespace 'free) (module foo g (defcap g () true) (defun calls-foo () barbar.FOO_CONST))" - -- for ordering the transactions as they appear in the block - , _cbGasPrice = GasPrice 0.8 - , _cbGasLimit = GasLimit (Gas 1000) - } - cmd3 <- buildCwCmd v (defaultCmd chain0) - { _cbRPC = mkExec' "(namespace 'free) (module bar g (defcap g () true) (defun calls-bar () (foo.calls-foo)))" - -- for ordering the transactions as they appear in the block - , _cbGasPrice = GasPrice 0.7 - , _cbGasLimit = GasLimit (Gas 1000) - } - cmd4 <- buildCwCmd v (defaultCmd chain0) - { _cbRPC = mkExec' "(namespace 'free) (module baz g (defcap g () true) (defun calls-baz () (bar.calls-bar)))" - -- for ordering the transactions as they appear in the block - , _cbGasPrice = GasPrice 0.6 - , _cbGasLimit = GasLimit (Gas 1000) - } - cmd5 <- buildCwCmd v (defaultCmd chain0) - { _cbRPC = mkExec' "(namespace 'free) (baz.calls-baz)" - -- for ordering the transactions as they appear in the block - , _cbGasPrice = GasPrice 0.5 - , _cbGasLimit = GasLimit (Gas 1000) - } - - results <- advanceAllChains fixture $ onChain chain0 $ \ph pactQueue mempool -> do - mempoolInsertPact5 mempool CheckedInsert [cmd1, cmd2, cmd3, cmd4, cmd5] - bip <- throwIfNotPact5 =<< throwIfNoHistory =<< newBlock noMiner NewBlockFill (ParentHeader ph) pactQueue - let block = finalizeBlock bip - return block - - results & - P.alignExact ? onChain chain0 ? - P.alignExact ? Vector.replicate 5 successfulTx - - results & - P.alignExact ? onChain chain0 ? - P.alignExact ? Vector.fromList - [ P.fun _crGas ? P.equals (Gas 173) - , P.fun _crGas ? P.equals (Gas 305) - , P.fun _crGas ? P.equals (Gas 348) - , P.fun _crGas ? P.equals (Gas 389) - , P.fun _crGas ? P.equals (Gas 81) - ] - - return () - -modulesWithHigherLevelTransitiveDependenciesComplex :: RocksDb -> IO () -modulesWithHigherLevelTransitiveDependenciesComplex baseRdb = runResourceT $ do - fixture <- mkFixture baseRdb - liftIO $ do - cmd1 <- buildCwCmd v (defaultCmd chain0) - { _cbRPC = mkExec' "(namespace 'free) (interface barbar (defconst FOO_CONST:integer 1))" - -- for ordering the transactions as they appear in the block - , _cbGasPrice = GasPrice 0.9 - , _cbGasLimit = GasLimit (Gas 1000) - } - cmd2 <- buildCwCmd v (defaultCmd chain0) - { _cbRPC = mkExec' $ T.unlines - [ "(namespace 'free)" - , "(module foo g" - , " (defcap g () true)" - , " (defun calls-foo (sender:string amount:integer)" - , " (with-capability (FOO_MANAGED sender amount)" - , " (with-capability (FOO_CAP)" - , " barbar.FOO_CONST" - , " )" - , " )" - , " )" - , " (defcap FOO_CAP () true)" - , "" - , " (defun foo-mgr (a:integer b:integer) (+ a b))" - , "" - , " (defcap FOO_MANAGED (sender:string a:integer)" - , " @managed a foo-mgr" - , " true" - , " )" - , " )" - ] - -- for ordering the transactions as they appear in the block - , _cbGasPrice = GasPrice 0.8 - , _cbGasLimit = GasLimit (Gas 1000) - } - cmd3 <- buildCwCmd v (defaultCmd chain0) - { _cbRPC = mkExec' "(namespace 'free) (module bar g (defcap g () true) (defun calls-bar () (install-capability (foo.FOO_MANAGED \"bob\" 100)) (foo.calls-foo \"bob\" 100)))" - -- for ordering the transactions as they appear in the block - , _cbGasPrice = GasPrice 0.7 - , _cbGasLimit = GasLimit (Gas 1000) - } - cmd4 <- buildCwCmd v (defaultCmd chain0) - { _cbRPC = mkExec' "(namespace 'free) (module baz g (defcap g () true) (defun calls-baz () (bar.calls-bar)))" - -- for ordering the transactions as they appear in the block - , _cbGasPrice = GasPrice 0.6 - , _cbGasLimit = GasLimit (Gas 1000) - } - cmd5 <- buildCwCmd v (defaultCmd chain0) - { _cbRPC = mkExec' "(namespace 'free) (baz.calls-baz)" - -- for ordering the transactions as they appear in the block - , _cbGasPrice = GasPrice 0.5 - , _cbGasLimit = GasLimit (Gas 1000) - } - - results <- advanceAllChains fixture $ onChain chain0 $ \ph pactQueue mempool -> do - mempoolInsertPact5 mempool CheckedInsert [cmd1, cmd2, cmd3, cmd4, cmd5] - bip <- throwIfNotPact5 =<< throwIfNoHistory =<< newBlock noMiner NewBlockFill (ParentHeader ph) pactQueue - let block = finalizeBlock bip - return block - - results & - P.alignExact ? onChain chain0 ? - P.alignExact ? Vector.replicate 5 successfulTx - - results & - P.alignExact ? onChain chain0 ? - P.alignExact ? Vector.fromList - [ P.fun _crGas ? P.equals (Gas 173) - , P.fun _crGas ? P.equals (Gas 715) - , P.fun _crGas ? P.equals (Gas 648) - , P.fun _crGas ? P.equals (Gas 618) - , P.fun _crGas ? P.equals (Gas 82) - ] - - return () - --- A simple test module that increments an integer, on a single chain or cross-chain -testModule :: T.Text -testModule = "(namespace 'free) \ - \ (module m G (defcap G () true) \ - \ (defun inc (arg) \ - \ (+ arg 1)) \ - \ (defpact inc-x-chain (arg dest-chain) \ - \ (step (yield { \"a\" : (+ arg 1)} dest-chain )) \ - \ (step (resume { \"a\" := a } a)) \ - \ ) \ - \ )" - -assertCutHeight :: Fixture -> BlockHeight -> IO () -assertCutHeight fixt bh = do - cut <- getCut fixt - view cutMinHeight cut @?= bh - view cutMaxHeight cut @?= bh - -makeProof :: Fixture -> ChainId -> ChainId -> BlockHeight -> Int -> IO ContProof -makeProof Fixture{..} cidT cidS bh i = (ContProof . B64U.encode . encodeToByteString) <$> - createTransactionOutputProof_ (_bdbWebBlockHeaderDb _fixtureBlockDb) ( _bdbPayloadDb _fixtureBlockDb) - cidT cidS bh i - -testIntialGasModel :: RocksDb -> IO () -testIntialGasModel baseRdb = runResourceT $ do - fixture <- mkFixtureDual baseRdb - - liftIO $ do - -- Confirm We are here at height 1 - assertCutHeight fixture $ BlockHeight 1 - - -- Deploy the module on both chains and initiate two defpact Txs on Chain 0 - cmdDeployChain0 <- buildCwCmd vPair (defaultCmd chain0) - { _cbRPC = mkExec' testModule - , _cbGasPrice = GasPrice 0.0004} - - cmdDeployChain1 <- buildCwCmd vPair (defaultCmd chain1) - { _cbRPC = mkExec' testModule - , _cbGasPrice = GasPrice 0.0004} - - cmdDefPact1 <-buildCwCmd vPair (defaultCmd chain0) - { _cbRPC = mkExec' "(free.m.inc-x-chain 0 \"1\")" - , _cbGasPrice = GasPrice 0.0003} - - cmdDefPact2 <- buildCwCmd vPair (defaultCmd chain0) - { _cbRPC = mkExec' "(free.m.inc-x-chain 1 \"1\")" - , _cbGasPrice = GasPrice 0.0002} - - cmdDefPact3 <- buildCwCmd vPair (defaultCmd chain0) - { _cbRPC = mkExec' "(free.m.inc-x-chain 2 \"1\")" - , _cbGasPrice = GasPrice 0.0001} - - resBlock2 <- advanceAllChainsWithTxs fixture $ onChains [ (chain0, [cmdDeployChain0, cmdDefPact1, cmdDefPact2, cmdDefPact3]) - , (chain1, [cmdDeployChain1]) ] - - -- Check That all transactions are successful - resBlock2 & - P.alignExact ? onChains [ (chain0, P.alignExact ? Vector.fromList [successfulTx, successfulTx, successfulTx, successfulTx]) - , (chain1, P.alignExact ? Vector.fromList [successfulTx])] - - -- Increase the height to allow SPV retrieval - _ <- advanceAllChainsWithTxs fixture $ AllChains [] - - ------------------------------------------------------------------------------------------------------------- - ----------------------------------- HEIGHT 4 - pre31GasModel ----------------------------------------------- - -- Confirm We are here at height 3 - -- We use the pre31GasModel - assertCutHeight fixture $ BlockHeight 3 - - prf1 <- makeProof fixture chain1 chain0 (BlockHeight 2) 1 - cmdCont1 <- buildCwCmd vPair (defaultCmd chain1) - { _cbRPC = mkCont $ ContMsg { _cmPactId = resBlock2 ^?! ixg chain0 . ix 1 . crContinuation . _Just . peDefPactId - , _cmStep = 1 - , _cmRollback = False - , _cmData = PObject mempty - , _cmProof = Just prf1 - } - , _cbGasPrice = GasPrice 0.0001} - - cmd1 <- buildCwCmd vPair (defaultCmd chain0) - { _cbRPC = mkExec' "(free.m.inc 0)" - } - - resBlock4 <- advanceAllChainsWithTxs fixture $ onChains [ (chain0, [cmd1]) - , (chain1, [cmdCont1]) ] - resBlock4 & - P.alignExact ? onChains [ (chain0, P.alignExact ? Vector.fromList [P.fun _crGas ? P.equals (Gas 74)]) - , (chain1, P.alignExact ? Vector.fromList [P.fun _crGas ? P.equals (Gas 100)]) - ] - - ------------------------------------------------------------------------------------------------------------- - ----------------------------------- HEIGHT 4 - post31GasModel ----------------------------------------------- - -- Confirm We are here at height 4 - assertCutHeight fixture $ BlockHeight 4 - - prf2 <- makeProof fixture chain1 chain0 (BlockHeight 2) 2 - cmdCont2 <- buildCwCmd vPair (defaultCmd chain1) - { _cbRPC = mkCont $ ContMsg { _cmPactId = resBlock2 ^?! ixg chain0 . ix 2 . crContinuation . _Just . peDefPactId - , _cmStep = 1 - , _cmRollback = False - , _cmData = PObject mempty - , _cmProof = Just prf2 - } - , _cbGasPrice = GasPrice 0.0001} - - cmd2 <- buildCwCmd vPair (defaultCmd chain0) - { _cbRPC = mkExec' "(free.m.inc 1)" - } - - resBlock5 <- advanceAllChainsWithTxs fixture $ onChains [ (chain0, [cmd2]) - , (chain1, [cmdCont2]) ] - - -- Check that now, with the post31GasModel => continuation proofs are charged - resBlock5 & - P.alignExact ? onChains [ (chain0, P.alignExact ? Vector.fromList [P.fun _crGas ? P.equals (Gas 74)]) - , (chain1, P.alignExact ? Vector.fromList [P.fun _crGas ? P.equals (Gas 124)]) - ] - - ------------------------------------------------------------------------------------------------------------- - ----------------------------------- HEIGHT 5 - post32GasModel ----------------------------------------------- - -- Confirm We are here at height 5 - assertCutHeight fixture $ BlockHeight 5 - - prf3 <- makeProof fixture chain1 chain0 (BlockHeight 2) 3 - cmdCont3 <- buildCwCmd vPair (defaultCmd chain1) - { _cbRPC = mkCont $ ContMsg { _cmPactId = resBlock2 ^?! ixg chain0 . ix 3 . crContinuation . _Just . peDefPactId - , _cmStep = 1 - , _cmRollback = False - , _cmData = PObject mempty - , _cmProof = Just prf3 - } - } - - cmd3 <- buildCwCmd vPair (defaultCmd chain0) - { _cbRPC = mkExec' "(free.m.inc 2)"} - - resBlock6 <- advanceAllChainsWithTxs fixture $ onChains [ (chain0, [cmd3]) - , (chain1, [cmdCont3]) ] - - -- Check that now, with the post32GasModel => continuation proofs + Signatures are charged - resBlock6 & - P.alignExact ? onChains [ (chain0, P.alignExact ? Vector.fromList [P.fun _crGas ? P.equals (Gas 96)]) - , (chain1, P.alignExact ? Vector.fromList [P.fun _crGas ? P.equals (Gas 145)]) - ] - - -{- -tests = do - -- * test that ValidateBlock does a destructive rewind to the parent of the block being validated - -- * test ValidateBlock's behavior if its parent doesn't exist in the chain database - - do - -- * test that read-only replay gives results that agree with running the block - blocks <- doBlocks (replicate 10 [tx1, tx2]) - - -- * test that read-only replay fails with the block missing - - - -- * test that PreInsertCheck does a Pact 5 check after the fork and Pact 4 check before the fork - -- - -- * test that the mempool only gives valid transactions - -- * test that blocks fit the block gas limit always - -- * test that blocks can include txs even if their gas limits together exceed that block gas limit - -- pact5 upgrade tests: - -- * test that a defpact can straddle the pact5 upgrade - -- * test that pact5 can load pact4 modules - -- * test that rewinding past the pact5 boundary is possible --} - -chain0 :: ChainId -chain0 = unsafeChainId 0 - -chain1 :: ChainId -chain1 = unsafeChainId 1 - -v :: ChainwebVersion -v = pact5InstantCpmTestVersion False singletonChainGraph - -vPair :: ChainwebVersion -vPair = pact5InstantCpmTestVersion False pairChainGraph - -advanceAllChainsWithTxs :: Fixture -> ChainMap [Pact5.Transaction] -> IO (ChainMap (Vector TestPact5CommandResult)) -advanceAllChainsWithTxs fixture txsPerChain = - advanceAllChains fixture $ - txsPerChain <&> \txs ph pactQueue mempool -> do - mempoolClear mempool - mempoolInsertPact5 mempool CheckedInsert txs - nb <- throwIfNotPact5 =<< throwIfNoHistory =<< - newBlock noMiner NewBlockFill (ParentHeader ph) pactQueue - return $ finalizeBlock nb - --- this mines a block on *all chains*. if you don't specify a payload on a chain, --- it adds empty blocks! -advanceAllChains :: () - => Fixture - -> ChainMap (BlockHeader -> PactQueue -> MempoolBackend Pact4.UnparsedTransaction -> IO PayloadWithOutputs) - -> IO (ChainMap (Vector TestPact5CommandResult)) -advanceAllChains Fixture{..} blocks = do - commandResults <- - forConcurrently _fixtureChains $ \c -> do - ph <- getParentTestBlockDb _fixtureBlockDb c - creationTime <- getCurrentTimeIntegral - let pactQueue = _fixturePactQueues ^?! atChain c - let mempool = _fixtureMempools ^?! atChain c - let makeEmptyBlock p _ _ = do - bip <- throwIfNotPact5 =<< throwIfNoHistory =<< - newBlock noMiner NewBlockEmpty (ParentHeader p) pactQueue - return $! finalizeBlock bip - - payload <- fromMaybe makeEmptyBlock (blocks ^? atChain c) ph pactQueue mempool - added <- addTestBlockDb _fixtureBlockDb - (succ $ view blockHeight ph) - (Nonce 0) - (\_ _ -> creationTime) - c - payload - when (not added) $ - error "failed to mine block" - ph' <- getParentTestBlockDb _fixtureBlockDb c - payload' <- validateBlock ph' (CheckablePayloadWithOutputs payload) pactQueue - assertEqual "payloads must not be altered by validateBlock" payload payload' - commandResults :: Vector TestPact5CommandResult - <- forM - (_payloadWithOutputsTransactions payload') - (decodeOrThrow' - . LBS.fromStrict - . _transactionOutputBytes - . snd) - -- assert on the command results - return (c, commandResults) - - return (onChains commandResults) - -getCut :: Fixture -> IO Cut -getCut Fixture{..} = getCutTestBlockDb _fixtureBlockDb - -revert :: Fixture -> Cut -> IO () -revert Fixture{..} c = do - setCutTestBlockDb _fixtureBlockDb c - forM_ (HashSet.toList (chainIds v)) $ \chain -> do - ph <- getParentTestBlockDb _fixtureBlockDb chain - pactSyncToBlock ph (_fixturePactQueues ^?! atChain chain) - -throwIfNotPact5 :: ForSomePactVersion f -> IO (f Pact5) -throwIfNotPact5 h = case h of - ForSomePactVersion Pact4T _ -> do - assertFailure "throwIfNotPact5: should be pact5" - ForSomePactVersion Pact5T a -> do - pure a - -transferCmd :: Decimal -> CmdBuilder -transferCmd transferAmount = (defaultCmd chain0) - { _cbRPC = mkExec' $ - "(coin.transfer \"sender00\" \"sender01\" " <> - -- if the number doesn't end with a decimal part, even if it's zero, Pact will - -- throw an error - T.pack (printf "%.4f" (realToFrac transferAmount :: Double)) <> - ")" - , _cbSigners = - [ mkEd25519Signer' sender00 - [ CapToken (QualifiedName "GAS" (ModuleName "coin" Nothing)) [] - , CapToken (QualifiedName "TRANSFER" coinModuleName) [PString "sender00", PString "sender01", PDecimal transferAmount] - ] - ] - -- for ordering the transactions as they appear in the block - , _cbGasPrice = GasPrice transferAmount - , _cbGasLimit = GasLimit (Gas 1000) - } diff --git a/test/unit/Chainweb/Test/ResponseSizeLimiter.hs b/test/unit/Chainweb/Test/ResponseSizeLimiter.hs index 2c8df57525..7903b4a50b 100644 --- a/test/unit/Chainweb/Test/ResponseSizeLimiter.hs +++ b/test/unit/Chainweb/Test/ResponseSizeLimiter.hs @@ -10,6 +10,7 @@ import Chainweb.Graph import Chainweb.Test.TestVersions import Chainweb.Test.Utils import Chainweb.Utils (ResponseBodyTooLarge(..)) +import Chainweb.Version import Control.Exception (fromException) import Control.Lens import Control.Monad.IO.Class @@ -30,8 +31,8 @@ import PropertyMatchers qualified as P tests :: TestTree -tests = testCase "Chainweb.Test.ResponseSizeLimiter" $ do - (mgr, _) <- PeerResources.connectionManager False =<< PeerDB.newEmptyPeerDb (timedConsensusVersion 0 singletonChainGraph pairChainGraph) +tests = testCase "Chainweb.Test.ResponseSizeLimiter" $ withVersion (timedConsensusVersion 0 singletonChainGraph pairChainGraph) $ do + (mgr, _) <- PeerResources.connectionManager False =<< PeerDB.newEmptyPeerDb runResourceT $ do let smallString = "small string" diff --git a/test/unit/Chainweb/Test/RestAPI.hs b/test/unit/Chainweb/Test/RestAPI.hs index 88aea9b6bb..8a66d5c61e 100644 --- a/test/unit/Chainweb/Test/RestAPI.hs +++ b/test/unit/Chainweb/Test/RestAPI.hs @@ -1,8 +1,10 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeAbstractions #-} +{-# LANGUAGE TypeApplications #-} {-# options_ghc -fno-warn-unused-local-binds -fno-warn-unused-imports #-} @@ -46,7 +48,7 @@ import Text.Read (readEither) -- internal modules -import Chainweb.Block +import Chainweb.Pact.Block import Chainweb.BlockHash (BlockHash) import Chainweb.BlockHeader import Chainweb.BlockHeaderDB @@ -54,9 +56,9 @@ import Chainweb.BlockHeaderDB.Internal (unsafeInsertBlockHeaderDb) import Chainweb.BlockHeaderDB.RestAPI import Chainweb.ChainId import Chainweb.Graph -import Chainweb.Mempool.Mempool (MempoolBackend, MockTx) -import Chainweb.Payload.PayloadStore -import Chainweb.Payload.PayloadStore.RocksDB +import Chainweb.Pact.Mempool.Mempool (MempoolBackend, MockTx) +import Chainweb.Pact.Payload.PayloadStore +import Chainweb.Pact.Payload.PayloadStore.RocksDB import Chainweb.RestAPI import Chainweb.Test.RestAPI.Client_ import Chainweb.Test.RestAPI.Utils (isFailureResponse, clientErrorStatusCode) @@ -71,29 +73,40 @@ import Chainweb.Version import Chainweb.Storage.Table.RocksDB import Servant.Client_ +import Chainweb.Parent +import Chainweb.PayloadProvider.Minimal +import qualified Network.HTTP.Client as HTTP +import Chainweb.PayloadProvider.P2P.RestAPI.Server (somePayloadServer) +import Chainweb.PayloadProvider.P2P.RestAPI (PayloadBatchLimit(PayloadBatchLimit)) +import Chainweb.Logger +import Chainweb.Chainweb.ChainResources (payloadP2pResources) +import P2P.Node.Configuration (defaultP2pConfiguration) +import System.LogLevel +import Chainweb.BlockHeaderDB.RestAPI.Client +import Control.Exception (evaluate) -- -------------------------------------------------------------------------- -- -- BlockHeaderDb queries -- TODO remove these? -hashes :: MonadIO m => BlockHeaderDb -> m [DbKey BlockHeaderDb] +hashes :: HasVersion => MonadIO m => BlockHeaderDb -> m [DbKey BlockHeaderDb] hashes db = liftIO $ SP.toList_ & keys db Nothing Nothing Nothing Nothing -headers :: MonadIO m => BlockHeaderDb -> m [DbEntry BlockHeaderDb] +headers :: HasVersion => MonadIO m => BlockHeaderDb -> m [DbEntry BlockHeaderDb] headers db = liftIO $ SP.toList_ & entries db Nothing Nothing Nothing Nothing -- -------------------------------------------------------------------------- -- -- BlockHeaderDb Utils -genesisBh :: MonadIO m => BlockHeaderDb -> m BlockHeader +genesisBh :: HasVersion => MonadIO m => BlockHeaderDb -> m BlockHeader genesisBh db = head <$> headers db -missingKey :: MonadIO m => BlockHeaderDb -> m (DbKey BlockHeaderDb) +missingKey :: HasVersion => MonadIO m => BlockHeaderDb -> m (DbKey BlockHeaderDb) missingKey db = key . head . testBlockHeadersWithNonce (Nonce 34523) - . ParentHeader + . Parent <$> genesisBh db -- -------------------------------------------------------------------------- -- @@ -116,7 +129,7 @@ tests rdb = testGroup "REST API tests" tests_ :: RocksDb -> Bool -> [TestTree] tests_ rdb tls = [ simpleSessionTests rdb tls - , pagingTests rdb tls + -- , pagingTests rdb tls ] version :: ChainwebVersion @@ -127,44 +140,65 @@ version = barebonesTestVersion singletonChainGraph -- | The type of 'TestClientEnv' that is used everywhere in this file -- -type TestClientEnv_ = TestClientEnv MockTx RocksDbTable - -mkEnv :: RocksDb -> Bool -> [(ChainId, BlockHeaderDb)] -> ResourceT IO TestClientEnv_ -mkEnv rdb tls dbs = do - let pdb = newPayloadDb rdb - liftIO $ initializePayloadDb version pdb - clientEnvWithChainwebTestServer ValidateSpec tls version emptyChainwebServerDbs +type TestClientEnv_ l = TestClientEnv l MockTx + +mkEnv + :: forall logger . HasVersion + => Logger logger + => logger + -> HTTP.Manager + -> RocksDb + -> Bool + -> ChainMap BlockHeaderDb + -> ResourceT IO (TestClientEnv_ logger) +mkEnv logger mgr rdb tls dbs = do + let mkPayloadServer cid = do + pp <- newMinimalPayloadProvider logger cid rdb (Just mgr) defaultMinimalProviderConfig + let pdb = view minimalPayloadDb pp + let queue = view minimalPayloadQueue pp + SomeChainwebVersionT @v' _ <- return someChainwebVersionVal + SomeChainIdT @c' _ <- return $ someChainIdVal cid + -- let serv = liftIO $ somePayloadServer @_ @v' @c' @'MinimalProvider + -- logger defaultP2pConfiguration myInfo peerDb pdb queue mgr + return $! somePayloadServer @_ @v' @c' @'MinimalProvider (PayloadBatchLimit 1000) pdb + payloadServers <- liftIO $ tabulateChainsM mkPayloadServer + clientEnvWithChainwebTestServer ValidateSpec tls emptyChainwebServerDbs { _chainwebServerBlockHeaderDbs = dbs - , _chainwebServerPayloadDbs = [ (cid, pdb) | (cid, _) <- dbs ] + , _chainwebServerPayloads = payloadServers } simpleSessionTests :: RocksDb -> Bool -> TestTree -simpleSessionTests rdb tls = - withResource' (testBlockHeaderDbs rdb version) $ \dbsIO -> - withResourceT (mkEnv rdb tls =<< liftIO dbsIO) +simpleSessionTests rdb tls = withVersion version $ + withResource' (HTTP.newManager HTTP.defaultManagerSettings) $ \mgrIO -> + withResource' (testBlockHeaderDbs rdb) $ \dbsIO -> + let neverLogger = genericLogger Error (\_ -> return ()) + in withResourceT (do { mgr <- liftIO mgrIO; dbs <- liftIO dbsIO; mkEnv neverLogger mgr rdb tls dbs}) $ \env -> testGroup "client session tests" - $ httpHeaderTests env (head $ toList $ chainIds version) - : (simpleClientSession env <$> toList (chainIds version)) + $ httpHeaderTests env (head $ toList chainIds) + : (simpleClientSession env <$> toList chainIds) -httpHeaderTests :: IO TestClientEnv_ -> ChainId -> TestTree +httpHeaderTests :: IO (TestClientEnv_ l) -> ChainId -> TestTree httpHeaderTests envIO cid = testGroup ("http header tests for chain " <> sshow cid) - [ testCase "headerClient" $ go $ \v h -> headerClient' v cid (key h) - , testCase "headersClient" $ go $ \v _ -> headersClient' v cid Nothing Nothing Nothing Nothing - , testCase "blocksClient" $ go $ \v _ -> blocksClient' v cid Nothing Nothing Nothing Nothing - , testCase "hashesClient" $ go $ \v _ -> hashesClient' v cid Nothing Nothing Nothing Nothing - , testCase "branchHashesClient" $ go $ \v _ -> branchHashesClient' v cid Nothing Nothing Nothing - Nothing (BranchBounds mempty mempty) - , testCase "branchHeadersClient" $ go $ \v _ -> branchHeadersClient' v cid Nothing Nothing Nothing + [ testCase "headerClient" $ go $ \h -> headerClient' cid (key h) + , testCase "headersClient" $ go $ \_ -> headersClient' cid Nothing Nothing Nothing Nothing + -- TODO: PP + -- , testCase "blocksClient" $ go $ \_ -> blocksClient' cid Nothing Nothing Nothing Nothing + , testCase "hashesClient" $ go $ \_ -> hashesClient' cid Nothing Nothing Nothing Nothing + , testCase "branchHashesClient" $ go $ \_ -> branchHashesClient' cid Nothing Nothing Nothing Nothing (BranchBounds mempty mempty) - , testCase "branchBlocksClient" $ go $ \v _ -> branchBlocksClient' v cid Nothing Nothing Nothing + , testCase "branchHeadersClient" $ go $ \_ -> branchHeadersClient' cid Nothing Nothing Nothing Nothing (BranchBounds mempty mempty) + -- TODO: PP + -- , testCase "branchBlocksClient" $ go $ \_ -> branchBlocksClient' cid Nothing Nothing Nothing + -- Nothing (BranchBounds mempty mempty) ] where + go :: Show b => (HasVersion => BlockHeader -> ClientM_ b) -> IO () go run = do env <- _envClientEnv <$> envIO - res <- flip runClientM_ env $ modifyResponse checkHeader $ - run version (genesisBlockHeader version cid) + res <- withVersion version $ flip runClientM_ env $ modifyResponse checkHeader $ + run (genesisBlockHeader cid) assertBool ("test failed: " <> sshow res) (isRight res) checkHeader res = do @@ -180,49 +214,43 @@ httpHeaderTests envIO cid = (d <= 2) return res -simpleClientSession :: IO TestClientEnv_ -> ChainId -> TestTree +simpleClientSession :: IO (TestClientEnv_ l) -> ChainId -> TestTree simpleClientSession envIO cid = testCaseSteps ("simple session for chain " <> sshow cid) $ \step -> do env <- _envClientEnv <$> envIO bhdbs <- _envBlockHeaderDbs <$> envIO - pdbs <- _envPayloadDbs <$> envIO - res <- runClientM (session bhdbs pdbs step) env + -- pdbs <- _envPayloads <$> envIO + res <- runClientM (withVersion version $ session bhdbs step) env assertBool ("test failed: " <> sshow res) (isRight res) where - session :: [(ChainId, BlockHeaderDb)] -> [(ChainId, PayloadDb RocksDbTable)] -> (String -> IO a) -> ClientM () - session bhdbs pdbs step = do + session :: HasVersion => ChainMap BlockHeaderDb -> (String -> IO a) -> ClientM () + session bhdbs step = do - let gbh0 = genesisBlockHeader version cid + let gbh0 = genesisBlockHeader cid - bhdb <- case Prelude.lookup cid bhdbs of - Just x -> return x - Nothing -> error "Chainweb.Test.RestAPI.simpleClientSession: missing block header db in test" - - pdb <- case Prelude.lookup cid pdbs of - Just x -> return x - Nothing -> error "Chainweb.Test.RestAPI.simpleClientSession: missing payload db in test" + bhdb <- liftIO $ evaluate $ bhdbs ^?! atChain cid void $ liftIO $ step "headerClient: get genesis block header" - gen0 <- headerClient version cid (key gbh0) + gen0 <- headerClient cid (key gbh0) assertExpectation "header client returned wrong entry" (Expected gbh0) (Actual gen0) void $ liftIO $ step "headerClient: get genesis block header pretty" - gen01 <- headerClientJsonPretty version cid (key gbh0) + gen01 <- headerClientJsonPretty cid (key gbh0) assertExpectation "header client returned wrong entry" (Expected gbh0) (Actual gen01) void $ liftIO $ step "headerClient: get genesis block header binary" - gen02 <- headerClientJsonBinary version cid (key gbh0) + gen02 <- headerClientJsonBinary cid (key gbh0) assertExpectation "header client returned wrong entry" (Expected gbh0) (Actual gen02) void $ liftIO $ step "headersClient: get genesis block header" - bhs1 <- headersClient version cid Nothing Nothing Nothing Nothing + bhs1 <- headersClient cid Nothing Nothing Nothing Nothing gen1 <- case _pageItems bhs1 of [] -> liftIO $ assertFailure "headersClient did return empty result" (h:_) -> return h @@ -230,34 +258,34 @@ simpleClientSession envIO cid = (Expected gbh0) (Actual gen1) - void $ liftIO $ step "blocksClient: get genesis block" - block1 <- blocksClient version cid Nothing Nothing Nothing Nothing - gen1Block <- case _pageItems block1 of - [] -> liftIO $ assertFailure "blocksClient did return empty result" - (h:_) -> return h - assertExpectation "block client returned wrong entry" - (Expected (Block gbh0 (version ^?! versionGenesis . genesisBlockPayload . atChain cid))) - (Actual gen1Block) + -- void $ liftIO $ step "blocksClient: get genesis block" + -- block1 <- blocksClient cid Nothing Nothing Nothing Nothing + -- gen1Block <- case _pageItems block1 of + -- [] -> liftIO $ assertFailure "blocksClient did return empty result" + -- (h:_) -> return h + -- assertExpectation "block client returned wrong entry" + -- (Expected (Block gbh0 (implicitVersion ^?! versionGenesis . genesisBlockPayload . atChain cid))) + -- (Actual gen1Block) void $ liftIO $ step "put 3 new blocks" - let newHeaders = take 3 $ testBlockHeaders (ParentHeader gbh0) + let newHeaders = take 3 $ testBlockHeaders (Parent gbh0) liftIO $ traverse_ (unsafeInsertBlockHeaderDb bhdb) newHeaders - liftIO $ traverse_ (\x -> addNewPayload pdb (view blockHeight x) (testBlockPayload_ x)) newHeaders + -- liftIO $ traverse_ (\x -> addNewPayload pdb (view blockHeight x) (testBlockPayload_ x)) newHeaders void $ liftIO $ step "headersClient: get all 4 block headers" - bhs2 <- headersClient version cid Nothing Nothing Nothing Nothing + bhs2 <- headersClient cid Nothing Nothing Nothing Nothing assertExpectation "headersClient returned wrong number of entries" (Expected 4) (Actual $ _pageLimit bhs2) - void $ liftIO $ step "blocksClient: get all 4 blocks" - blocks2 <- blocksClient version cid Nothing Nothing Nothing Nothing - assertExpectation "blocksClient returned wrong number of entries" - (Expected 4) - (Actual $ _pageLimit blocks2) + -- void $ liftIO $ step "blocksClient: get all 4 blocks" + -- blocks2 <- blocksClient cid Nothing Nothing Nothing Nothing + -- assertExpectation "blocksClient returned wrong number of entries" + -- (Expected 4) + -- (Actual $ _pageLimit blocks2) void $ liftIO $ step "hashesClient: get all 4 block hashes" - hs2 <- hashesClient version cid Nothing Nothing Nothing Nothing + hs2 <- hashesClient cid Nothing Nothing Nothing Nothing assertExpectation "hashesClient returned wrong number of entries" (Expected $ _pageLimit bhs2) (Actual $ _pageLimit hs2) @@ -267,7 +295,7 @@ simpleClientSession envIO cid = forM_ newHeaders $ \h -> do void $ liftIO $ step $ "headerClient: " <> T.unpack (encodeToText (view blockHash h)) - r <- headerClient version cid (key h) + r <- headerClient cid (key h) assertExpectation "header client returned wrong entry" (Expected h) (Actual r) @@ -280,9 +308,9 @@ simpleClientSession envIO cid = let query bounds = liftIO $ flip runClientM clientEnv $ branchHeadersClient - version cid Nothing Nothing Nothing Nothing bounds + cid Nothing Nothing Nothing Nothing bounds let limit = 32 - let blockHeaders = testBlockHeaders (ParentHeader gbh0) + let blockHeaders = testBlockHeaders (Parent gbh0) let maxBlockHeaders = take limit blockHeaders let excessBlockHeaders = take (limit + 1) blockHeaders @@ -325,7 +353,7 @@ simpleClientSession envIO cid = (Actual (() <$ doesntFailAtAll)) void $ liftIO $ step "branchHeadersClient: get no block headers" - bhs3 <- branchHeadersClient version cid Nothing Nothing Nothing Nothing + bhs3 <- branchHeadersClient cid Nothing Nothing Nothing Nothing (BranchBounds mempty mempty) assertExpectation "branchHeadersClient returned wrong number of entries" (Expected 0) @@ -333,14 +361,14 @@ simpleClientSession envIO cid = forM_ ([2..] `zip` newHeaders) $ \(i, h) -> do void $ liftIO $ step $ "branchHeadersClient: get " <> sshow i <> " block headers with upper bound" - bhs4 <- branchHeadersClient version cid Nothing Nothing Nothing Nothing + bhs4 <- branchHeadersClient cid Nothing Nothing Nothing Nothing (BranchBounds mempty (HS.singleton (UpperBound $ key h))) assertExpectation "branchHeadersClient returned wrong number of entries" (Expected i) (Actual $ _pageLimit bhs4) void $ liftIO $ step "branchHeadersClient: get no block headers with lower and upper bound" - bhs5 <- branchHeadersClient version cid Nothing Nothing Nothing Nothing + bhs5 <- branchHeadersClient cid Nothing Nothing Nothing Nothing (BranchBounds (HS.singleton (LowerBound $ key h)) (HS.singleton (UpperBound $ key h))) assertExpectation "branchHeadersClient returned wrong number of entries" (Expected 0) @@ -348,7 +376,7 @@ simpleClientSession envIO cid = forM_ (newHeaders `zip` drop 1 newHeaders) $ \(h0, h1) -> do void $ liftIO $ step "branchHeadersClient: get one block headers with lower and upper bound" - bhs5 <- branchHeadersClient version cid Nothing Nothing Nothing Nothing + bhs5 <- branchHeadersClient cid Nothing Nothing Nothing Nothing (BranchBounds (HS.singleton (LowerBound $ key h0)) (HS.singleton (UpperBound $ key h1))) assertExpectation "branchHeadersClient returned wrong number of entries" (Expected 1) @@ -356,7 +384,7 @@ simpleClientSession envIO cid = forM_ (newHeaders `zip` drop 2 newHeaders) $ \(h0, h1) -> do void $ liftIO $ step "branchHeadersClient: get two block headers with lower and upper bound" - bhs5 <- branchHeadersClient version cid Nothing Nothing Nothing Nothing + bhs5 <- branchHeadersClient cid Nothing Nothing Nothing Nothing (BranchBounds (HS.singleton (LowerBound $ key h0)) (HS.singleton (UpperBound $ key h1))) assertExpectation "branchHeadersClient returned wrong number of entries" (Expected 2) @@ -365,7 +393,7 @@ simpleClientSession envIO cid = -- branchHeaders void $ liftIO $ step "branchHashesClient: get no block headers" - hs3 <- branchHashesClient version cid Nothing Nothing Nothing Nothing + hs3 <- branchHashesClient cid Nothing Nothing Nothing Nothing (BranchBounds mempty mempty) assertExpectation "branchHashesClient returned wrong number of entries" (Expected 0) @@ -373,14 +401,14 @@ simpleClientSession envIO cid = forM_ ([2..] `zip` newHeaders) $ \(i, h) -> do void $ liftIO $ step $ "branchHashesClient: get " <> sshow i <> " block headers with upper bound" - hs4 <- branchHashesClient version cid Nothing Nothing Nothing Nothing + hs4 <- branchHashesClient cid Nothing Nothing Nothing Nothing (BranchBounds mempty (HS.singleton (UpperBound $ key h))) assertExpectation "branchHashesClient returned wrong number of entries" (Expected i) (Actual $ _pageLimit hs4) void $ liftIO $ step "branchHashesClient: get no block headers with lower and upper bound" - hs5 <- branchHashesClient version cid Nothing Nothing Nothing Nothing + hs5 <- branchHashesClient cid Nothing Nothing Nothing Nothing (BranchBounds (HS.singleton (LowerBound $ key h)) (HS.singleton (UpperBound $ key h))) assertExpectation "branchHashesClient returned wrong number of entries" (Expected 0) @@ -388,7 +416,7 @@ simpleClientSession envIO cid = forM_ (newHeaders `zip` drop 1 newHeaders) $ \(h0, h1) -> do void $ liftIO $ step "branchHashesClient: get one block headers with lower and upper bound" - hs5 <- branchHashesClient version cid Nothing Nothing Nothing Nothing + hs5 <- branchHashesClient cid Nothing Nothing Nothing Nothing (BranchBounds (HS.singleton (LowerBound $ key h0)) (HS.singleton (UpperBound $ key h1))) assertExpectation "branchHashesClient returned wrong number of entries" (Expected 1) @@ -396,7 +424,7 @@ simpleClientSession envIO cid = forM_ (newHeaders `zip` drop 2 newHeaders) $ \(h0, h1) -> do void $ liftIO $ step "branchHashesClient: get two block headers with lower and upper bound" - hs5 <- branchHashesClient version cid Nothing Nothing Nothing Nothing + hs5 <- branchHashesClient cid Nothing Nothing Nothing Nothing (BranchBounds (HS.singleton (LowerBound $ key h0)) (HS.singleton (UpperBound $ key h1))) assertExpectation "branchHashesClient returned wrong number of entries" (Expected 2) @@ -405,14 +433,14 @@ simpleClientSession envIO cid = -- branch hashes with fork void $ liftIO $ step "headerPutClient: put 3 new blocks on a new fork" - let newHeaders2 = take 3 $ testBlockHeadersWithNonce (Nonce 17) (ParentHeader gbh0) + let newHeaders2 = take 3 $ testBlockHeadersWithNonce (Nonce 17) (Parent gbh0) liftIO $ traverse_ (unsafeInsertBlockHeaderDb bhdb) newHeaders2 - liftIO $ traverse_ (\x -> addNewPayload pdb (view blockHeight x) (testBlockPayload_ x)) newHeaders2 + -- liftIO $ traverse_ (\x -> addNewPayload pdb (view blockHeight x) (testBlockPayload_ x)) newHeaders2 let lower = last newHeaders forM_ ([1..] `zip` newHeaders2) $ \(i, h) -> do void $ liftIO $ step "branchHashesClient: get one block headers with lower and upper bound" - hs5 <- branchHashesClient version cid Nothing Nothing Nothing Nothing + hs5 <- branchHashesClient cid Nothing Nothing Nothing Nothing (BranchBounds (HS.singleton (LowerBound $ key lower)) (HS.singleton (UpperBound $ key h))) assertExpectation "branchHashesClient returned wrong number of entries" (Expected i) @@ -423,107 +451,108 @@ simpleClientSession envIO cid = -- -------------------------------------------------------------------------- -- -- Paging Tests -pagingTests :: RocksDb -> Bool -> TestTree -pagingTests rdb tls = - withResourceT - (mkEnv rdb tls =<< - liftIO (starBlockHeaderDbs 6 =<< testBlockHeaderDbs rdb version)) - $ \env -> testGroup "paging tests" - [ testPageLimitHeadersClient env - , testPageLimitHashesClient env - ] - -pagingTest - :: Eq a - => Show a - => String - -- ^ Test name - -> (BlockHeaderDb -> IO [a]) - -- ^ Get test items from database - -> (a -> DbKey BlockHeaderDb) - -- ^ Compute paging key from item - -> Bool - -- ^ whether the result represents an finite (True) or infinite (False) - -- set - -> (ChainId -> Maybe Limit -> Maybe (NextItem (DbKey BlockHeaderDb)) -> ClientM (Page (NextItem (DbKey BlockHeaderDb)) a)) - -- ^ Request with paging parameters - -> IO TestClientEnv_ - -- ^ Test environment - -> TestTree -pagingTest name getDbItems getKey fin request envIO = testGroup name - [ testCaseSteps "test limit parameter" $ \step -> do - env <- _envClientEnv <$> envIO - [(cid, db)] <- _envBlockHeaderDbs <$> envIO - ents <- getDbItems db - let l = len ents - res <- flip runClientM env $ forM_ [0 .. (l+2)] $ \i -> - session step ents cid (Just i) Nothing - assertBool ("test of limit failed: " <> sshow res) (isRight res) - - -- TODO Did a limit value of 0 mean something else previously? - -- The two last tests that are failing now are failing when - -- hitting `Limit 0`. - - , testCaseSteps "test next parameter" $ \step -> do - env <- _envClientEnv <$> envIO - [(cid, db)] <- _envBlockHeaderDbs <$> envIO - ents <- getDbItems db - let l = len ents - res <- flip runClientM env $ forM_ [0 .. (l-1)] $ \i -> do - let es = drop i ents - session step es cid Nothing (Just . Inclusive . getKey . head $ es) - assertBool ("test limit and next failed: " <> sshow res) (isRight res) - - , testCaseSteps "test limit and next parameter" $ \step -> do - env <- _envClientEnv <$> envIO - [(cid, db)] <- _envBlockHeaderDbs <$> envIO - ents <- getDbItems db - let l = len ents - res <- flip runClientM env - $ forM_ [0 .. (l-1)] $ \i -> forM_ [0 .. (l+2-i)] $ \j -> do - let es = drop (int i) ents - session step es cid (Just j) (Just . Inclusive . getKey . head $ es) - assertBool ("test limit and next failed: " <> sshow res) (isRight res) - - , testCase "non existing next parameter" $ do - env <- _envClientEnv <$> envIO - [(cid, db)] <- _envBlockHeaderDbs <$> envIO - missing <- missingKey db - res <- flip runClientM env $ request cid Nothing (Just $ Exclusive missing) - assertBool ("test failed with unexpected result: " <> sshow res) (isErrorCode 404 res) - ] - where - session step ents cid n next = do - void $ liftIO $ step $ "limit " <> sshow n <> ", next " <> sshow next - r <- request cid n next - assertExpectation "result has wrong page 'limit' value" - (Expected . maybe id min n . int $ length ents) - (Actual $ _pageLimit r) - assertExpectation "result contains wrong page 'items'" - (Expected . maybe id (take . int) n $ ents) - (Actual $ _pageItems r) - assertExpectation "result contains wrong page 'next' value" - (Expected $ expectedNext ents n) - (Actual $ _pageNext r) - - expectedNext = if fin then expectedNextFin else expectedNextInf - - -- Finite case - expectedNextFin _ Nothing = Nothing - expectedNextFin ents (Just n) = Inclusive . getKey <$> listToMaybe (drop (int n) ents) - - -- Infinite case - expectedNextInf ents Nothing = Exclusive . getKey <$> (Just $ last ents) - expectedNextInf ents (Just n) - | n >= len ents = Exclusive . getKey <$> (Just $ last ents) - | otherwise = Inclusive . getKey <$> listToMaybe (drop (int n) ents) - -testPageLimitHeadersClient :: IO TestClientEnv_ -> TestTree -testPageLimitHeadersClient = pagingTest "headersClient" headers key False request - where - request cid l n = headersClient version cid l n Nothing Nothing - -testPageLimitHashesClient :: IO TestClientEnv_ -> TestTree -testPageLimitHashesClient = pagingTest "hashesClient" hashes id False request - where - request cid l n = hashesClient version cid l n Nothing Nothing +-- pagingTests :: RocksDb -> Bool -> TestTree +-- pagingTests rdb tls = withVersion version $ +-- withResourceT +-- (mkEnv rdb tls =<< +-- liftIO (starBlockHeaderDbs 6 =<< testBlockHeaderDbs rdb)) +-- $ \env -> testGroup "paging tests" +-- [ testPageLimitHeadersClient env +-- , testPageLimitHashesClient env +-- ] + +-- pagingTest +-- :: HasVersion +-- => Eq a +-- => Show a +-- => String +-- -- ^ Test name +-- -> (BlockHeaderDb -> IO [a]) +-- -- ^ Get test items from database +-- -> (a -> DbKey BlockHeaderDb) +-- -- ^ Compute paging key from item +-- -> Bool +-- -- ^ whether the result represents an finite (True) or infinite (False) +-- -- set +-- -> (ChainId -> Maybe Limit -> Maybe (NextItem (DbKey BlockHeaderDb)) -> ClientM (Page (NextItem (DbKey BlockHeaderDb)) a)) +-- -- ^ Request with paging parameters +-- -> IO TestClientEnv_ +-- -- ^ Test environment +-- -> TestTree +-- pagingTest name getDbItems getKey fin request envIO = testGroup name +-- [ testCaseSteps "test limit parameter" $ \step -> do +-- env <- _envClientEnv <$> envIO +-- [(cid, db)] <- _envBlockHeaderDbs <$> envIO +-- ents <- getDbItems db +-- let l = len ents +-- res <- flip runClientM env $ forM_ [0 .. (l+2)] $ \i -> +-- session step ents cid (Just i) Nothing +-- assertBool ("test of limit failed: " <> sshow res) (isRight res) + +-- -- TODO Did a limit value of 0 mean something else previously? +-- -- The two last tests that are failing now are failing when +-- -- hitting `Limit 0`. + +-- , testCaseSteps "test next parameter" $ \step -> do +-- env <- _envClientEnv <$> envIO +-- [(cid, db)] <- _envBlockHeaderDbs <$> envIO +-- ents <- getDbItems db +-- let l = len ents +-- res <- flip runClientM env $ forM_ [0 .. (l-1)] $ \i -> do +-- let es = drop i ents +-- session step es cid Nothing (Just . Inclusive . getKey . head $ es) +-- assertBool ("test limit and next failed: " <> sshow res) (isRight res) + +-- , testCaseSteps "test limit and next parameter" $ \step -> do +-- env <- _envClientEnv <$> envIO +-- [(cid, db)] <- _envBlockHeaderDbs <$> envIO +-- ents <- getDbItems db +-- let l = len ents +-- res <- flip runClientM env +-- $ forM_ [0 .. (l-1)] $ \i -> forM_ [0 .. (l+2-i)] $ \j -> do +-- let es = drop (int i) ents +-- session step es cid (Just j) (Just . Inclusive . getKey . head $ es) +-- assertBool ("test limit and next failed: " <> sshow res) (isRight res) + +-- , testCase "non existing next parameter" $ do +-- env <- _envClientEnv <$> envIO +-- [(cid, db)] <- _envBlockHeaderDbs <$> envIO +-- missing <- missingKey db +-- res <- flip runClientM env $ request cid Nothing (Just $ Exclusive missing) +-- assertBool ("test failed with unexpected result: " <> sshow res) (isErrorCode 404 res) +-- ] +-- where +-- session step ents cid n next = do +-- void $ liftIO $ step $ "limit " <> sshow n <> ", next " <> sshow next +-- r <- request cid n next +-- assertExpectation "result has wrong page 'limit' value" +-- (Expected . maybe id min n . int $ length ents) +-- (Actual $ _pageLimit r) +-- assertExpectation "result contains wrong page 'items'" +-- (Expected . maybe id (take . int) n $ ents) +-- (Actual $ _pageItems r) +-- assertExpectation "result contains wrong page 'next' value" +-- (Expected $ expectedNext ents n) +-- (Actual $ _pageNext r) + +-- expectedNext = if fin then expectedNextFin else expectedNextInf + +-- -- Finite case +-- expectedNextFin _ Nothing = Nothing +-- expectedNextFin ents (Just n) = Inclusive . getKey <$> listToMaybe (drop (int n) ents) + +-- -- Infinite case +-- expectedNextInf ents Nothing = Exclusive . getKey <$> (Just $ last ents) +-- expectedNextInf ents (Just n) +-- | n >= len ents = Exclusive . getKey <$> (Just $ last ents) +-- | otherwise = Inclusive . getKey <$> listToMaybe (drop (int n) ents) + +-- testPageLimitHeadersClient :: HasVersion => IO TestClientEnv_ -> TestTree +-- testPageLimitHeadersClient = pagingTest "headersClient" headers key False request +-- where +-- request cid l n = headersClient cid l n Nothing Nothing + +-- testPageLimitHashesClient :: HasVersion => IO TestClientEnv_ -> TestTree +-- testPageLimitHashesClient = pagingTest "hashesClient" hashes id False request +-- where +-- request cid l n = hashesClient cid l n Nothing Nothing diff --git a/test/unit/Chainweb/Test/Roundtrips.hs b/test/unit/Chainweb/Test/Roundtrips.hs index 3a08a751dc..b5da0628a7 100644 --- a/test/unit/Chainweb/Test/Roundtrips.hs +++ b/test/unit/Chainweb/Test/Roundtrips.hs @@ -1,6 +1,8 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} +{-# LANGUAGE ImportQualifiedPost #-} + {-# OPTIONS_GHC -Wno-orphans #-} -- | @@ -17,71 +19,56 @@ module Chainweb.Test.Roundtrips ) where import Chainweb.Pact.RestAPI.SPV - import Control.Monad.Catch - -import Crypto.Hash.Algorithms - import Data.Aeson import Data.Aeson.Encoding import Data.Bifunctor -import qualified Data.ByteString.Lazy as BL -import qualified Data.HashMap.Strict as HM +import Data.ByteString.Lazy qualified as BL +import Data.HashMap.Strict qualified as HM import Data.Int -import qualified Data.Text as T - -import qualified Pact.JSON.Encode as J -import Pact.Parse - -import Test.QuickCheck -import Test.QuickCheck.Instances () -import Test.Tasty -import Test.Tasty.QuickCheck - --- internal modules - +import Data.Text qualified as T +import Pact.JSON.Encode qualified as J import Chainweb.BlockHash import Chainweb.BlockHeader -import Chainweb.BlockHeaderDB.RestAPI import Chainweb.BlockHeight import Chainweb.BlockWeight import Chainweb.ChainId -import Chainweb.Chainweb import Chainweb.Chainweb.Configuration import Chainweb.Cut.Create import Chainweb.Cut.CutHashes import Chainweb.Difficulty import Chainweb.HostAddress -import Chainweb.Mempool.Mempool -import Chainweb.Mempool.RestAPI import Chainweb.MerkleLogHash import Chainweb.MerkleUniverse import Chainweb.Miner.Config import Chainweb.Miner.Pact import Chainweb.NodeVersion -import Chainweb.Pact.Types -import Chainweb.Payload +import Chainweb.Pact.Mempool.Mempool +import Chainweb.Pact.Mempool.RestAPI +import Chainweb.Pact.Payload import Chainweb.PowHash +import Chainweb.Ranked import Chainweb.RestAPI.NetworkID import Chainweb.RestAPI.NodeInfo -import Chainweb.SPV import Chainweb.SPV.EventProof -import Chainweb.SPV.PayloadProof -import Chainweb.Test.Orphans.Internal (EventPactValue(..), ProofPactEvent(..)) -import Chainweb.Test.SPV.EventProof hiding (tests) +import Chainweb.Test.Orphans.Internal () import Chainweb.Test.Utils import Chainweb.Time import Chainweb.Utils import Chainweb.Utils.Paging import Chainweb.Version - +import Chainweb.Version.Mainnet (mainnet) import Network.X509.SelfSigned - import P2P.Node import P2P.Node.Configuration import P2P.Peer import P2P.Test.Orphans () - +import Pact.Core.Gas +import Pact.Parse +import Test.QuickCheck +import Test.QuickCheck.Instances () +import Test.Tasty +import Test.Tasty.QuickCheck import Utils.Logging -- -------------------------------------------------------------------------- -- @@ -112,8 +99,8 @@ encodeDecodeTests = testGroup "Encode-Decode roundtrips" $ prop_encodeDecode decodeMerkleLogHash (encodeMerkleLogHash @ChainwebMerkleHashAlgorithm) , testProperty "BlockHash" $ prop_encodeDecode decodeBlockHash (encodeBlockHash @ChainwebMerkleHashAlgorithm) - , testProperty "BlockHash_ Keccak_256" - $ prop_encodeDecode decodeBlockHash (encodeBlockHash @Keccak_256) + -- , testProperty "BlockHash_ Keccak_256" + -- $ prop_encodeDecode decodeBlockHash (encodeBlockHash @Keccak_256) , testProperty "BlockHeight" $ prop_encodeDecode decodeBlockHeight encodeBlockHeight , testProperty "CutHeight" @@ -131,8 +118,8 @@ encodeDecodeTests = testGroup "Encode-Decode roundtrips" , testProperty "BlockHashRecord" $ prop_encodeDecode decodeBlockHashRecord encodeBlockHashRecord - , testProperty "BlockHeader" - $ prop_encodeDecode decodeBlockHeader encodeBlockHeader + -- , testProperty "BlockHeader" + -- $ prop_encodeDecode decodeBlockHeader encodeBlockHeader , testProperty "Nonce" $ prop_encodeDecode decodeNonce encodeNonce , testProperty "Time" @@ -151,16 +138,16 @@ encodeDecodeTests = testGroup "Encode-Decode roundtrips" $ prop_encodeDecode decodeBlockEventsHash (encodeBlockEventsHash @ChainwebMerkleHashAlgorithm) ] - , testGroup "Keccak_256" - [ testProperty "BlockPayloadHash" - $ prop_encodeDecode decodeBlockPayloadHash (encodeBlockPayloadHash @Keccak_256) - , testProperty "BlockTransactionsHash" - $ prop_encodeDecode decodeBlockTransactionsHash (encodeBlockTransactionsHash @Keccak_256) - , testProperty "BlockTransactionsHash" - $ prop_encodeDecode decodeBlockTransactionsHash (encodeBlockTransactionsHash @Keccak_256) - , testProperty "BlockEventsHash" - $ prop_encodeDecode decodeBlockEventsHash (encodeBlockEventsHash @Keccak_256) - ] + -- , testGroup "Keccak_256" + -- [ testProperty "BlockPayloadHash" + -- $ prop_encodeDecode decodeBlockPayloadHash (encodeBlockPayloadHash @Keccak_256) + -- , testProperty "BlockTransactionsHash" + -- $ prop_encodeDecode decodeBlockTransactionsHash (encodeBlockTransactionsHash @Keccak_256) + -- , testProperty "BlockTransactionsHash" + -- $ prop_encodeDecode decodeBlockTransactionsHash (encodeBlockTransactionsHash @Keccak_256) + -- , testProperty "BlockEventsHash" + -- $ prop_encodeDecode decodeBlockEventsHash (encodeBlockEventsHash @Keccak_256) + -- ] -- SPV , testGroup "SPV" @@ -172,42 +159,51 @@ encodeDecodeTests = testGroup "Encode-Decode roundtrips" $ prop_encodeDecode decodeBytes encodeBytes , testProperty "String" $ prop_encodeDecode decodeString encodeString - , testProperty "ModuleName" - $ prop_encodeDecode decodeModuleName encodeModuleName + -- , testProperty "ModuleName" + -- $ prop_encodeDecode decodeModuleName encodeModuleName -- FIXME limit to empty spec and info - , testProperty "ModRef" - $ prop_encodeDecode (PactEventModRef <$> decodeModRef) (encodeModRef . _getPactEventModRef) + -- TODO PP + -- , testProperty "ModRef" + -- $ prop_encodeDecode (PactEventModRef <$> decodeModRef) (encodeModRef . _getPactEventModRef) , testProperty "Integer" $ prop_encodeDecode decodeInteger encodeInteger - , testProperty "Decimal" - $ prop_encodeDecode (PactEventDecimal <$> decodeDecimal) (encodeDecimal . _getPactEventDecimal) - , testProperty "Hash" - $ prop_encodeDecode decodeHash encodeHash + -- TODO PP + -- , testProperty "Decimal" + -- $ prop_encodeDecode (PactEventDecimal <$> decodeDecimal) (encodeDecimal . _getPactEventDecimal) + -- TODO PP + -- , testProperty "Hash" + -- $ prop_encodeDecode decodeHash encodeHash , testProperty "Array[Int256]" $ prop_encodeDecode (decodeArray decodeInteger) (`encodeArray` encodeInteger) , testProperty "Array[Bytes]" $ prop_encodeDecode (decodeArray decodeBytes) (`encodeArray` encodeBytes) -- FIXME "too few bytes" - , testProperty "PactEvent" - $ prop_encodeDecode (ProofPactEvent <$> decodePactEvent) (encodePactEvent . getProofPactEvent) + -- TODO PP + -- , testProperty "PactEvent" + -- $ prop_encodeDecode (ProofPactEvent <$> decodePactEvent) (encodePactEvent . getProofPactEvent) -- FIXME "pending bytes" - , testProperty "PactParam" - $ prop_encodeDecode (EventPactValue <$> decodeParam) (encodeParam . getEventPactValue) + -- , testProperty "PactParam" + -- $ prop_encodeDecode (EventPactValue <$> decodeParam) (encodeParam . getEventPactValue) -- FIXME "pending bytes" - , testProperty "OutputEvents" - $ prop_encodeDecode decodeOutputEvents encodeOutputEvents + -- , testProperty "OutputEvents" + -- $ prop_encodeDecode decodeOutputEvents encodeOutputEvents ] -- Mining - , testProperty "SolvedWork" - $ prop_encodeDecode decodeSolvedWork encodeSolvedWork - - -- FIXME: decoding depends on version and block height (which is something - -- that we should fix) - -- , testProperty "WorkHeader" - -- $ prop_encodeDecode decodeWorkHeader encodeWorkHeader + , testProperty "MiningWork" + $ withVersion mainnet $ forAll arbitrary $ \height -> prop_encodeDecode (decodeWorkHeader height) encodeMiningWork + + -- TODO: PP + -- , testProperty "SolvedWork" + -- $ forAll arbitrary + -- $ \v -> withVersion v $ forAll arbitrary + -- $ \cid -> forAll arbitrary + -- $ \height -> forAll (arbitraryBlockHeaderVersionHeightChain height cid) + -- $ \bh -> forAll (arbitraryBlockHashRecordVersionHeightChain height cid) + -- $ \bhr -> newHeader + -- prop_encodeDecode (decodeWorkHeader (view blockHeight bh)) encodeMiningWork -- TODO Fix this! -- The following doesn't hold: @@ -222,23 +218,27 @@ pactJsonTestCases :: (forall a . Arbitrary a => Show a => J.Encode a => FromJSON a => Eq a => a -> Property) -> [TestTree] pactJsonTestCases f = - [ testGroup "SPV" - [ testProperty "SpvRequest" $ f @SpvRequest - ] + [ testGroup "SPV" [] + -- [ testProperty "SpvRequest" $ f @SpvRequest + -- ] , testGroup "Miner" [ testProperty "MinerId" $ f @MinerId - , testProperty "Miner" $ f @Miner + -- , testProperty "Miner" $ f @Miner ] , testGroup "Mempool" - [ testProperty "GasLimit" $ f @GasLimit - , testProperty "GasPrice" $ f @GasPrice - , testProperty "ParsedDecimal" $ f @ParsedDecimal + -- [ testProperty "GasLimit" $ f @GasLimit + -- , testProperty "GasPrice" $ f @GasPrice + [ testProperty "ParsedDecimal" $ f @ParsedDecimal , testProperty "ParsedInteger" $ f @ParsedInteger ] ] instance Arbitrary MockTx where - arbitrary = MockTx <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary + arbitrary = MockTx + <$> arbitrary + <*> (GasPrice <$> arbitrary) + <*> (GasLimit . Gas . fromIntegral <$> arbitrary @Word) + <*> arbitrary jsonTestCases :: (forall a . Arbitrary a => Show a => ToJSON a => FromJSON a => Eq a => a -> Property) @@ -255,14 +255,14 @@ jsonTestCases f = , testProperty "HashTarget" $ f @HashTarget , testProperty "MerkleRootType" $ f @MerkleRootType , testProperty "MerkleLogHash" $ f @(MerkleLogHash ChainwebMerkleHashAlgorithm) - , testProperty "MerkleLogHash Keccak_256" $ f @(MerkleLogHash Keccak_256) + -- , testProperty "MerkleLogHash Keccak_256" $ f @(MerkleLogHash Keccak_256) , testProperty "PowHash" $ f @PowHash , testProperty "PowHashNat" $ f @PowHashNat , testProperty "BlockHash" $ f @BlockHash - , testProperty "BlockHash_ Keccak_256" $ f @(BlockHash_ Keccak_256) + -- , testProperty "BlockHash_ Keccak_256" $ f @(BlockHash_ Keccak_256) , testProperty "BlockHashRecord" $ f @BlockHashRecord - , testProperty "BlockHeader" $ f @BlockHeader - , testProperty "HeaderUpdate" $ f @HeaderUpdate + -- , testProperty "BlockHeader" $ f @BlockHeader + -- , testProperty "HeaderUpdate" $ withVersion mainnet $ f @HeaderUpdate , testProperty "BlockWeight" $ f @BlockWeight , testProperty "P2pNodeStats" $ f @P2pNodeStats , testProperty "P2pSessionResult" $ f @P2pSessionResult @@ -276,20 +276,20 @@ jsonTestCases f = , testProperty "PeerInfo" $ f @PeerInfo , testProperty "Peer" $ f @Peer , testProperty "NetworkId" $ f @NetworkId - , testProperty "ChainDatabaseGcConfig" $ f @ChainDatabaseGcConfig + -- , testProperty "ChainDatabaseGcConfig" $ f @ChainDatabaseGcConfig , testProperty "MerkleRootType" $ f @MerkleRootType , testProperty "ChainwebConfiguration" $ f @ChainwebConfiguration , testProperty "Probability" $ f @Probability , testProperty "LogFilterRule" $ f @LogFilterRule , testProperty "LogFilter" $ f @LogFilter - , testProperty "BlockHashWithHeight" $ f @BlockHashWithHeight + , testProperty "Ranked BlockHash" $ f @(Ranked BlockHash) , testProperty "CutId" $ f @CutId - , testProperty "CutHashes" $ f @CutHashes + -- , testProperty "CutHashes" $ withVersion mainnet $ f @CutHashes , testProperty "NodeVersion" $ f @NodeVersion , testProperty "NodeInfo" $ f @NodeInfo , testProperty "EnableConfig MiningConfig" $ f @(EnableConfig MiningConfig) , testProperty "NextItem Int" $ f @(NextItem Int) - , testProperty "Page BlockHash BlockHeader" $ f @(Page BlockHash BlockHeader) + -- , testProperty "Page BlockHash BlockHeader" $ f @(Page BlockHash BlockHeader) , testProperty "X509CertPem" $ f @X509CertPem , testProperty "X509CertChainPem" $ f @X509CertChainPem , testProperty "X509KeyPem" $ f @X509KeyPem @@ -297,12 +297,12 @@ jsonTestCases f = , testGroup "SPV" [ testProperty "SpvAlgorithm" $ f @SpvAlgorithm , testProperty "SpvSubjectType" $ f @SpvAlgorithm - , testProperty "SpvSubjectIdentifier" $ f @SpvSubjectIdentifier - , testProperty "Spv2Request" $ f @Spv2Request - , testProperty "TransactionProof" $ f @(TransactionProof ChainwebMerkleHashAlgorithm) - , testProperty "TransactionOutputProof" $ f @(TransactionOutputProof ChainwebMerkleHashAlgorithm) - , testProperty "PayloadProof" $ f @(PayloadProof ChainwebMerkleHashAlgorithm) - , testProperty "SomePayloadProof" $ f @(SomePayloadProof) + -- , testProperty "SpvSubjectIdentifier" $ f @SpvSubjectIdentifier + -- , testProperty "Spv2Request" $ f @Spv2Request + -- -- , testProperty "TransactionProof" $ f @(TransactionProof ChainwebMerkleHashAlgorithm) + -- , testProperty "TransactionOutputProof" $ f @(TransactionOutputProof ChainwebMerkleHashAlgorithm) + -- , testProperty "PayloadProof" $ f @(PayloadProof ChainwebMerkleHashAlgorithm) + -- , testProperty "SomePayloadProof" $ f @(SomePayloadProof) ] , testGroup "Miner" @@ -318,7 +318,7 @@ jsonTestCases f = , testProperty "MockTx" $ f @MockTx ] - -- Chainweb.Payload + -- Chainweb.Pact.Payload , testGroup "Payload types" [ testProperty "Transaction" $ f @Transaction , testProperty "MinerData" $ f @MinerData @@ -336,25 +336,25 @@ jsonTestCases f = , testProperty "OutputTree" $ f @OutputTree , testProperty "PayloadData" $ f @PayloadData , testProperty "PayloadWithOutputs" $ f @PayloadWithOutputs - , testProperty "PayloadOutputProof" $ f @(PayloadProof ChainwebMerkleHashAlgorithm) + -- , testProperty "PayloadOutputProof" $ f @(PayloadProof ChainwebMerkleHashAlgorithm) , testProperty "BlockEventsHash" $ f @(BlockEventsHash_ ChainwebMerkleHashAlgorithm) ] - , testGroup "Keccak_256" - [ testProperty "BlockPayloadHash" $ f @(BlockPayloadHash_ Keccak_256) - , testProperty "BlockTransactionsHash" $ f @(BlockTransactionsHash_ Keccak_256) - , testProperty "BlockOutputsHash" $ f @(BlockOutputsHash_ Keccak_256) - , testProperty "PayloadData" $ f @(PayloadData_ Keccak_256) - , testProperty "BlockTransactions" $ f @(BlockTransactions_ Keccak_256) - , testProperty "BlockPayload" $ f @(BlockPayload_ Keccak_256) - , testProperty "BlockOutputs" $ f @(BlockOutputs_ Keccak_256) - , testProperty "TransactionTree" $ f @(TransactionTree_ Keccak_256) - , testProperty "OutputTree" $ f @(OutputTree_ Keccak_256) - , testProperty "PayloadData" $ f @(PayloadData_ Keccak_256) - , testProperty "PayloadWithOutputs" $ f @(PayloadWithOutputs_ Keccak_256) - , testProperty "PayloadOutputProof" $ f @(PayloadProof Keccak_256) - , testProperty "BlockEventsHash" $ f @(BlockEventsHash_ Keccak_256) - ] + -- , testGroup "Keccak_256" + -- [ testProperty "BlockPayloadHash" $ f @(BlockPayloadHash_ Keccak_256) + -- , testProperty "BlockTransactionsHash" $ f @(BlockTransactionsHash_ Keccak_256) + -- , testProperty "BlockOutputsHash" $ f @(BlockOutputsHash_ Keccak_256) + -- , testProperty "PayloadData" $ f @(PayloadData_ Keccak_256) + -- , testProperty "BlockTransactions" $ f @(BlockTransactions_ Keccak_256) + -- , testProperty "BlockPayload" $ f @(BlockPayload_ Keccak_256) + -- , testProperty "BlockOutputs" $ f @(BlockOutputs_ Keccak_256) + -- , testProperty "TransactionTree" $ f @(TransactionTree_ Keccak_256) + -- , testProperty "OutputTree" $ f @(OutputTree_ Keccak_256) + -- , testProperty "PayloadData" $ f @(PayloadData_ Keccak_256) + -- , testProperty "PayloadWithOutputs" $ f @(PayloadWithOutputs_ Keccak_256) + -- , testProperty "PayloadOutputProof" $ f @(PayloadProof Keccak_256) + -- , testProperty "BlockEventsHash" $ f @(BlockEventsHash_ Keccak_256) + -- ] ] ] -- Types with ToJSON but without FromJSON instance @@ -463,7 +463,7 @@ base64RoundtripTests = testGroup "Base64 encoding roundtrips" hasTextRepresentationTests :: TestTree hasTextRepresentationTests = testGroup "HasTextRepresentation roundtrips" - [ testProperty "ChainwebVersionName" $ prop_iso' @_ @ChainwebVersionName eitherFromText toText + [ testProperty "ChainwebVersionName" $ prop_iso' @_ @ChainwebVersionName fromText toText , testProperty "ChainId" $ prop_iso' @_ @ChainId fromText toText , testProperty "BlockHash" $ prop_iso' @_ @BlockHash fromText toText , testProperty "Seconds" $ prop_iso' @_ @Seconds fromText toText @@ -478,7 +478,7 @@ hasTextRepresentationTests = testGroup "HasTextRepresentation roundtrips" , testProperty "P2pNetworkId" $ prop_iso' @_ @NetworkId fromText toText , testProperty "Transaction" $ prop_iso' @_ @Transaction fromText toText , testProperty "TransactionOutput" $ prop_iso' @_ @TransactionOutput fromText toText - , testProperty "ChainDatabaseGcConfig" $ prop_iso' @_ @ChainDatabaseGcConfig fromText toText + -- , testProperty "ChainDatabaseGcConfig" $ prop_iso' @_ @ChainDatabaseGcConfig fromText toText , testProperty "MerkleRootType" $ prop_iso' @_ @MerkleRootType fromText toText , testProperty "Fork" $ prop_iso' @_ @Fork fromText toText ] diff --git a/test/unit/Chainweb/Test/SPV.hs b/test/unit/Chainweb/Test/SPV.hs index 2b57ea15b5..ef53130f7d 100644 --- a/test/unit/Chainweb/Test/SPV.hs +++ b/test/unit/Chainweb/Test/SPV.hs @@ -32,10 +32,10 @@ import Chainweb.Crypto.MerkleLog import Chainweb.Cut hiding (join) import Chainweb.CutDB import Chainweb.Graph -import Chainweb.Mempool.Mempool (MockTx) +import Chainweb.Pact.Mempool.Mempool (MockTx) import Chainweb.MerkleUniverse -import Chainweb.Payload -import Chainweb.Payload.PayloadStore +import Chainweb.Pact.Payload +import Chainweb.Pact.Payload.PayloadStore import Chainweb.SPV import Chainweb.SPV.CreateProof import Chainweb.SPV.OutputProof @@ -82,10 +82,10 @@ import Test.Tasty.QuickCheck -- tests :: RocksDb -> TestTree tests rdb = testGroup "SPV tests" - [ testCaseStepsN "SPV transaction proof" 10 (spvTransactionRoundtripTest rdb version) - , testCaseStepsN "SPV transaction output proof" 10 (spvTransactionOutputRoundtripTest rdb version) - , apiTests rdb version - , testCaseSteps "SPV transaction proof test" (spvTest rdb version) + [ testCaseStepsN "SPV transaction proof" 10 (withVersion version $ spvTransactionRoundtripTest rdb) + , testCaseStepsN "SPV transaction output proof" 10 (withVersion version spvTransactionOutputRoundtripTest rdb ) + , withVersion version $ apiTests rdb + , testCaseSteps "SPV transaction proof test" (withVersion version $ spvTest rdb) , properties ] where @@ -101,9 +101,9 @@ testCaseStepsN name n test = testGroup name $ flip map [1..n] $ \i -> -- Find a reachable target chain -- -targetChain :: Cut -> BlockHeader -> IO ChainId +targetChain :: HasVersion => Cut -> BlockHeader -> IO ChainId targetChain c srcBlock = do - cids <- generate (shuffle $ toList $ chainIds c) + cids <- generate (shuffle $ toList chainIds) go cids where graph = _chainGraph c @@ -202,9 +202,9 @@ prop_outputProof_valid = forAll arbitraryPayloadWithStructuredOutputs go -- -- Also checks that the size of the created proofs meets the expectations. -- -spvTest :: RocksDb -> ChainwebVersion -> Step -> IO () -spvTest rdb v step = do - withTestCutDbWithoutPact rdb v id 100 logg $ \_ cutDb -> do +spvTest :: HasVersion => RocksDb -> Step -> IO () +spvTest rdb step = do + withTestCutDbWithoutPact rdb id 100 logg $ \_ cutDb -> do curCut <- _cutMap <$> _cut cutDb -- for each blockheader h in cut @@ -214,7 +214,7 @@ spvTest rdb v step = do -- for each transaction in ah & flip S.for (getPayloads cutDb) -- for each target chain c - & flip S.for (\(a,b,c,d) -> S.each $ (a,b,c,d,) <$> toList (chainIds cutDb)) + & flip S.for (\(a,b,c,d) -> S.each $ (a,b,c,d,) <$> toList chainIds) -- Create and verify transaction output proof & S.mapM (go cutDb) -- Ingore all cases where a proof couldn't be created @@ -286,7 +286,7 @@ spvTest rdb v step = do [ int $ BL.length $ encode proof , int n , int $ view blockHeight h - , int $ distance cutDb h trgChain + , int $ distance h trgChain , int $ B.length (_transactionOutputBytes txOut) ] @@ -295,14 +295,14 @@ spvTest rdb v step = do Right x -> do let msg = "SPV proof creation succeeded although target chain is not reachable (" <> "source height: " <> sshow (view blockHeight h) - <> ", distance: " <> sshow (distance cutDb h trgChain) + <> ", distance: " <> sshow (distance h trgChain) <> ")" assertBool msg isReachable return (Just x) Left SpvExceptionTargetNotReachable{} -> do let msg = "SPV proof creation failed although target chain is reachable (" <> "source height: " <> sshow (view blockHeight h) - <> ", distance: " <> sshow (distance cutDb h trgChain) + <> ", distance: " <> sshow (distance h trgChain) <> ")" assertBool msg (not isReachable) return Nothing @@ -310,16 +310,16 @@ spvTest rdb v step = do -- Distance between source chain an target chain -- - distance cutDb h trgChain = length + distance h trgChain = length $ shortestPath (_chainId h) trgChain - $ chainGraphAt cutDb (view blockHeight h) + $ chainGraphAt (view blockHeight h) -- Check whether target chain is reachable from the source block -- reachable :: CutDb as -> BlockHeader -> ChainId -> IO Bool reachable cutDb h trgChain = do m <- maxRank $ cutDb ^?! cutDbBlockHeaderDb trgChain - return $ (int m - int (view blockHeight h)) >= distance cutDb h trgChain + return $ (int m - int (view blockHeight h)) >= distance h trgChain -- regression model with @createTransactionOutputProof@. Proof size doesn't -- depend on target height. @@ -344,10 +344,10 @@ spvTest rdb v step = do -- -------------------------------------------------------------------------- -- -- SPV Tests -spvTransactionRoundtripTest :: RocksDb -> ChainwebVersion -> Step -> IO () -spvTransactionRoundtripTest rdb v step = do +spvTransactionRoundtripTest :: HasVersion => RocksDb -> Step -> IO () +spvTransactionRoundtripTest rdb step = do step "setup cut db" - withTestCutDbWithoutPact rdb v id 100 (\_ _ -> return ()) $ \_ cutDb -> do + withTestCutDbWithoutPact rdb id 100 (\_ _ -> return ()) $ \_ cutDb -> do step "pick random transaction" (h, txIx, tx, _) <- randomTransaction cutDb @@ -380,10 +380,10 @@ spvTransactionRoundtripTest rdb v step = do step "confirm that proof subject matches transaction" assertEqual "proof subject matches transaction" tx subj -spvTransactionOutputRoundtripTest :: RocksDb -> ChainwebVersion -> Step -> IO () -spvTransactionOutputRoundtripTest rdb v step = do +spvTransactionOutputRoundtripTest :: HasVersion => RocksDb -> Step -> IO () +spvTransactionOutputRoundtripTest rdb step = do step "setup cut db" - withTestCutDbWithoutPact rdb v id 100 (\_ _ -> return ()) $ \_ cutDb -> do + withTestCutDbWithoutPact rdb id 100 (\_ _ -> return ()) $ \_ cutDb -> do step "pick random transaction output" (h, outIx, _, out) <- randomTransaction cutDb @@ -422,24 +422,24 @@ spvTransactionOutputRoundtripTest rdb v step = do type TestClientEnv_ tbl = TestClientEnv MockTx tbl -apiTests :: RocksDb -> ChainwebVersion -> TestTree -apiTests rdb v = withResourceT (withTestPayloadResource rdb v 100 (\_ _ -> pure ())) $ \dbIO -> +apiTests :: HasVersion => RocksDb -> TestTree +apiTests rdb = withResourceT (withTestPayloadResource rdb 100 (\_ _ -> pure ())) $ \dbIO -> testGroup "SPV API tests" -- TODO: there is no openapi spec for this SPV API. - [ withResourceT (join $ withPayloadServer DoNotValidateSpec False v <$> liftIO dbIO <*> (liftIO $ payloadDbs . view cutDbPayloadDb <$> dbIO)) $ \env -> + [ withResourceT (join $ withPayloadServer DoNotValidateSpec False <$> liftIO dbIO <*> (liftIO $ payloadDbs . view cutDbPayloadDb <$> dbIO)) $ \env -> testCaseStepsN "spv api tests (without tls)" 10 (txApiTests env) - , withResourceT (join $ withPayloadServer DoNotValidateSpec True v <$> liftIO dbIO <*> (liftIO $ payloadDbs . view cutDbPayloadDb <$> dbIO)) $ \env -> + , withResourceT (join $ withPayloadServer DoNotValidateSpec True <$> liftIO dbIO <*> (liftIO $ payloadDbs . view cutDbPayloadDb <$> dbIO)) $ \env -> testCaseStepsN "spv api tests (with tls)" 10 (txApiTests env) ] where - cids = toList $ chainIds v + cids = toList chainIds payloadDbs :: CanReadablePayloadCas tbl' => PayloadDb tbl' -> [(ChainId, PayloadDb tbl')] payloadDbs db = (, db) <$> cids -txApiTests :: CanReadablePayloadCas tbl => IO (TestClientEnv_ tbl) -> Step -> IO () +txApiTests :: HasVersion => CanReadablePayloadCas tbl => IO (TestClientEnv_ tbl) -> Step -> IO () txApiTests envIO step = do - PayloadTestClientEnv env cutDb _payloadDbs v <- envIO + PayloadTestClientEnv env cutDb _payloadDbs <- envIO step "pick random transaction" (h, txIx, tx, out) <- randomTransaction cutDb @@ -453,7 +453,7 @@ txApiTests envIO step = do step "request transaction proof" txProof <- flip runClientM env $ - spvGetTransactionProofClient v trgChain (_chainId h) (view blockHeight h) (int txIx) + spvGetTransactionProofClient trgChain (_chainId h) (view blockHeight h) (int txIx) case txProof of @@ -472,7 +472,7 @@ txApiTests envIO step = do step "request transaction output proof" outProof <- flip runClientM env $ - spvGetTransactionOutputProofClient v trgChain (_chainId h) (view blockHeight h) (int txIx) + spvGetTransactionOutputProofClient trgChain (_chainId h) (view blockHeight h) (int txIx) case outProof of diff --git a/test/unit/Chainweb/Test/SPV/EventProof.hs b/test/unit/Chainweb/Test/SPV/EventProof.hs index cd2752b678..2cc6f6cff3 100644 --- a/test/unit/Chainweb/Test/SPV/EventProof.hs +++ b/test/unit/Chainweb/Test/SPV/EventProof.hs @@ -5,6 +5,7 @@ {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} +{-# LANGUAGE ImportQualifiedPost #-} -- | -- Module: Chainweb.Test.SPV.EventProof @@ -39,6 +40,7 @@ import Data.Aeson.Types import Data.Bifunctor import Data.Decimal import Data.MerkleLog +import Data.MerkleLog.V1 qualified as V1 import qualified Data.Text as T import qualified Data.Vector as V @@ -54,7 +56,7 @@ import Test.Tasty.QuickCheck import Chainweb.Crypto.MerkleLog import Chainweb.MerkleUniverse -import Chainweb.Payload +import Chainweb.Pact.Payload import Chainweb.SPV.EventProof import Chainweb.SPV.OutputProof import Chainweb.SPV.PayloadProof @@ -179,14 +181,14 @@ proof_properties = testGroup "merkle proof properties" ] prop_merkleProof_run :: MerkleHashAlgorithm a => MerkleProof a -> Bool -prop_merkleProof_run p = case runMerkleProof p of !_ -> True +prop_merkleProof_run p = case V1.runMerkleProof p of !_ -> True prop_eventsProof_run :: forall a . MerkleHashAlgorithm a => Property prop_eventsProof_run = forAll (arbitraryEventsProof @a) $ \p -> - case runMerkleProof (_payloadProofBlob p) of !_ -> True + case V1.runMerkleProof (_payloadProofBlob p) of !_ -> True prop_eventsProof_run2 :: forall a @@ -294,4 +296,3 @@ eventProof_0 = [aesonQQ| "rootType": "blockEvents" } |] - diff --git a/test/unit/Chainweb/Test/Sync/WebBlockHeaderStore.hs b/test/unit/Chainweb/Test/Sync/WebBlockHeaderStore.hs index 9815872a93..c08b3950b8 100644 --- a/test/unit/Chainweb/Test/Sync/WebBlockHeaderStore.hs +++ b/test/unit/Chainweb/Test/Sync/WebBlockHeaderStore.hs @@ -27,6 +27,7 @@ import Control.Concurrent import Control.Concurrent.Async import Control.Monad import Control.Monad.IO.Class +import Control.Monad.Trans.Resource import Data.Hashable import Data.IORef @@ -50,6 +51,7 @@ import Data.TaskMap import Chainweb.Storage.Table import qualified Chainweb.Storage.Table.HashMap as HashMapTable +import Chainweb.Utils import P2P.TaskQueue @@ -128,13 +130,14 @@ testQueueServer limit q = forM_ [0..] $ session_ limit q (\_ _ -> return ()) -- TODO provide test with actual block header db -withNoopQueueServer :: (PQueue (Task env a) -> IO b) -> IO b -withNoopQueueServer a = do - q <- newEmptyPQueue _taskPriority _taskId Nothing +withNoopQueueServer :: ResourceT IO (PQueue (Task env a)) +withNoopQueueServer = do + q <- liftIO $ newEmptyPQueue _taskPriority _taskId Nothing let failTask = do task <- pQueueRemove q putIVar (_taskResult task) $ Left $ [] - withAsync (forever failTask) $ const $ a q + _ <- withAsyncR (forever failTask) + return q startNoopQueueServer :: IO (Async (), PQueue (Task env a)) startNoopQueueServer = do diff --git a/test/unit/Chainweb/Test/TreeDB.hs b/test/unit/Chainweb/Test/TreeDB.hs index aca17c229a..73c90f16c2 100644 --- a/test/unit/Chainweb/Test/TreeDB.hs +++ b/test/unit/Chainweb/Test/TreeDB.hs @@ -43,17 +43,20 @@ import Test.Tasty.QuickCheck import Chainweb.BlockHeader.Internal import Chainweb.BlockHeader.Validation +import Chainweb.Parent import Chainweb.Test.Utils import Chainweb.Test.Utils.BlockHeader import Chainweb.TreeDB import Chainweb.Utils (int, len, tryAllSynchronous) import Chainweb.Utils.Paging +import Chainweb.Version (HasVersion) type Insert db = db -> [DbEntry db] -> IO () type WithTestDb db = forall prop . Testable prop => DbEntry db -> (db -> Insert db -> IO prop) -> IO prop treeDbInvariants :: (TreeDb db, IsBlockHeader (DbEntry db), Ord (DbEntry db), Ord (DbKey db)) + => HasVersion => WithTestDb db -- ^ Given a generic entry should yield a database and insert function for -- testing, and then safely close it after use. @@ -168,7 +171,9 @@ handOfGod_prop f (SparseTree t0) = ioProperty . withTreeDb f t $ \db insert -> d -- | Property: The root node's parent must always be itself. -- rootParent_prop - :: forall db. (TreeDb db, IsBlockHeader (DbEntry db)) + :: forall db + . (TreeDb db, IsBlockHeader (DbEntry db)) + => HasVersion => WithTestDb db -> SparseTree -> Property @@ -227,6 +232,7 @@ maxRank_prop f (SparseTree t0) = ioProperty . withTreeDb f t $ \db _ -> do -- entryOrder_prop :: forall db. (TreeDb db, IsBlockHeader (DbEntry db)) + => HasVersion => WithTestDb db -> SparseTree -> Property @@ -235,7 +241,7 @@ entryOrder_prop f (SparseTree t0) = ioProperty . withTreeDb f t $ \db _ -> do pure . isJust $ foldlM g S.empty hs where g acc h = let acc' = S.insert (view blockHash h) acc - in bool Nothing (Just acc') $ isGenesisBlockHeader h || S.member (view blockParent h) acc' + in bool Nothing (Just acc') $ isGenesisBlockHeader h || S.member (unwrapParent (view blockParent h)) acc' t :: Tree (DbEntry db) t = fmap (^. from isoBH) t0 @@ -302,6 +308,7 @@ properties = prop_forkEntry :: forall db . TreeDb db + => HasVersion => IsBlockHeader (DbEntry db) => WithTestDb db -> Natural @@ -314,12 +321,12 @@ prop_forkEntry f i j = do e <- forkEntry db (head $ reverse (g : a)) (head $ reverse $ (g : b)) return $ e === g where - g = view (from isoBH) $ toyGenesis toyChainId + g = view (from isoBH) $ genesisBlockHeader toyChainId t = Node g [] a = take (int i) $ branch (Nonce 0) g b = take (int j) $ branch (Nonce 1) g - branch n x = view (from isoBH) <$> testBlockHeadersWithNonce n (ParentHeader $ view isoBH x) + branch n x = view (from isoBH) <$> testBlockHeadersWithNonce n (Parent $ view isoBH x) -- -------------------------------------------------------------------------- -- -- forward branch entries @@ -369,7 +376,7 @@ prop_getBranchIncreasing_parents f (SparseTree t0) = forAll (int <$> choose (0,m ioProperty $ withTreeDb f t $ \db _ -> do e <- maxEntry db branch <- getBranchIncreasing db e i $ \s -> P.toList_ $ P.map (view isoBH) s - return $ and $ zipWith (\a b -> view blockHash a == view blockParent b) branch (drop 1 branch) + return $ and $ zipWith (\a b -> Parent (view blockHash a) == view blockParent b) branch (drop 1 branch) where m = length $ levels t0 t = fmap (^. from isoBH) t0 diff --git a/test/unit/Chainweb/Test/Version.hs b/test/unit/Chainweb/Test/Version.hs index e1ad4ab5c3..1825dfd425 100644 --- a/test/unit/Chainweb/Test/Version.hs +++ b/test/unit/Chainweb/Test/Version.hs @@ -1,6 +1,7 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE RankNTypes #-} -- | -- Module: Chainweb.Test.Version @@ -48,12 +49,12 @@ tests = testGroup "ChainwebVersion properties" -- -------------------------------------------------------------------------- -- -- Utils -propForVersions :: String -> (ChainwebVersion -> Property) -> TestTree +propForVersions :: String -> (HasVersion => Property) -> TestTree propForVersions desc prop = testGroup desc - [ testProperty "arbitrary versions" $ prop - , testProperty "mainnet" $ prop Mainnet01 - , testProperty "testnet04" $ prop Testnet04 - , testProperty "recapDevnet" $ prop RecapDevelopment + [ testProperty "arbitrary versions" $ \v -> withVersion v prop + , testProperty "mainnet" $ withVersion Mainnet01 prop + , testProperty "testnet04" $ withVersion Testnet04 prop + , testProperty "recapDevnet" $ withVersion RecapDevelopment prop ] -- -------------------------------------------------------------------------- -- @@ -67,20 +68,20 @@ graphTests = testGroup "Graphs" , propForVersions "chainIds are chains of latest graph" prop_chainIds ] -prop_chainGraphs_sorted :: ChainwebVersion -> Property -prop_chainGraphs_sorted v - = property (ruleValid (_versionGraphs v)) +prop_chainGraphs_sorted :: HasVersion => Property +prop_chainGraphs_sorted + = property (ruleValid (_versionGraphs implicitVersion)) -prop_chainGraphs_order :: ChainwebVersion -> Property -prop_chainGraphs_order v = orders === NE.reverse (NE.sort orders) +prop_chainGraphs_order :: HasVersion => Property +prop_chainGraphs_order = orders === NE.reverse (NE.sort orders) where - orders = ruleElems $ fmap order $ _versionGraphs v + orders = ruleElems $ fmap order $ _versionGraphs implicitVersion -prop_genesisHeight :: ChainwebVersion -> Property -prop_genesisHeight v = property $ all ((>= 0) . genesisHeight v) $ chainIds v +prop_genesisHeight :: HasVersion => Property +prop_genesisHeight = property $ all ((>= 0) . genesisHeight) chainIds -prop_chainIds :: ChainwebVersion -> Property -prop_chainIds v = chainIds v === graphChainIds (snd $ ruleHead $ _versionGraphs v) +prop_chainIds :: HasVersion => Property +prop_chainIds = chainIds === graphChainIds (snd $ ruleHead $ _versionGraphs implicitVersion) -- -------------------------------------------------------------------------- -- -- Header Sizes @@ -99,50 +100,50 @@ headerSizeTests = testGroup "HeaderSize" -- | A "golden" test property. If the value changes the test will fails and must -- be manually updated. This protectes against accidentally changing this value. -- -prop_headerBaseSizeBytes_golden :: ChainwebVersion -> Property -prop_headerBaseSizeBytes_golden v = _versionHeaderBaseSizeBytes v === 208 +prop_headerBaseSizeBytes_golden :: HasVersion => Property +prop_headerBaseSizeBytes_golden = _versionHeaderBaseSizeBytes implicitVersion === 208 -prop_headerBaseSizeBytes :: ChainwebVersion -> Property -prop_headerBaseSizeBytes v = property $ do - cid <- elements $ toList $ chainIds v - let genHdr = genesisBlockHeader v cid +prop_headerBaseSizeBytes :: HasVersion => Property +prop_headerBaseSizeBytes = property $ do + cid <- elements $ toList $ chainIds + let genHdr = genesisBlockHeader cid gen = runPutS $ encodeBlockHeader genHdr as = runPutS $ encodeBlockHashRecord (view blockAdjacentHashes genHdr) - return $ _versionHeaderBaseSizeBytes v === int (B.length gen - B.length as) + return $ _versionHeaderBaseSizeBytes implicitVersion === int (B.length gen - B.length as) -prop_headerSizes_sorted :: ChainwebVersion -> Property -prop_headerSizes_sorted v - = NE.reverse (NE.sort (ruleElems (headerSizes v))) === ruleElems (headerSizes v) +prop_headerSizes_sorted :: HasVersion => Property +prop_headerSizes_sorted + = NE.reverse (NE.sort (ruleElems headerSizes)) === ruleElems headerSizes -prop_headerSizes_order :: ChainwebVersion -> Property -prop_headerSizes_order v = orders === NE.reverse (NE.sort orders) +prop_headerSizes_order :: HasVersion => Property +prop_headerSizes_order = orders === NE.reverse (NE.sort orders) where - orders = ruleElems $ fmap order $ _versionGraphs v + orders = ruleElems $ fmap order $ _versionGraphs implicitVersion -prop_headerSizeBytes_gen :: ChainwebVersion -> Property -prop_headerSizeBytes_gen v = property $ do - cid <- elements $ toList $ chainIds v - let hdr = genesisBlockHeader v cid +prop_headerSizeBytes_gen :: HasVersion => Property +prop_headerSizeBytes_gen = property $ do + cid <- elements $ toList chainIds + let hdr = genesisBlockHeader cid l = int $ B.length $ runPutS $ encodeBlockHeader $ hdr return $ counterexample ("chain: " <> sshow cid) - $ headerSizeBytes v cid (view blockHeight hdr) === l + $ headerSizeBytes cid (view blockHeight hdr) === l -prop_headerSizeBytes :: ChainwebVersion -> Property -prop_headerSizeBytes v = property $ do - h <- arbitraryBlockHeaderVersion v +prop_headerSizeBytes :: HasVersion => Property +prop_headerSizeBytes = property $ do + h <- arbitraryBlockHeaderVersion let l = int $ B.length $ runPutS $ encodeBlockHeader h return $ counterexample ("header: " <> sshow h) - $ headerSizeBytes (_chainwebVersion h) (view blockChainId h) (view blockHeight h) === l + $ headerSizeBytes (view blockChainId h) (view blockHeight h) === l -prop_workSizeBytes :: ChainwebVersion -> Property -prop_workSizeBytes v = property $ do - h <- arbitraryBlockHeaderVersion v - if (view blockHeight h == genesisHeight v (_chainId h)) +prop_workSizeBytes :: HasVersion => Property +prop_workSizeBytes = property $ do + h <- arbitraryBlockHeaderVersion + if (view blockHeight h == genesisHeight (_chainId h)) then discard else do - let l = int $ B.length $ runPutS $ encodeBlockHeaderWithoutHash h + let expectedSize = int $ B.length $ runPutS (encodeAsMiningWork h) return $ counterexample ("header: " <> sshow h) - $ workSizeBytes (_chainwebVersion h) (view blockHeight h) === l + $ workSizeBytes (view blockHeight h) === expectedSize diff --git a/test/unit/ChainwebTests.hs b/test/unit/ChainwebTests.hs index 904de768ad..8fcaaf10d9 100644 --- a/test/unit/ChainwebTests.hs +++ b/test/unit/ChainwebTests.hs @@ -1,6 +1,7 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE NumericUnderscores #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ImportQualifiedPost #-} -- | -- Module: Main @@ -14,137 +15,82 @@ module Main ( main, setTestLogLevel ) where +-- import qualified Chainweb.Test.BlockHeaderDB.PruneForks (tests) +-- import qualified Chainweb.Test.Mempool.Consensus (tests) +-- import qualified Chainweb.Test.Pact.SPVTest +-- import qualified Chainweb.Test.SPV (tests) +-- import qualified Chainweb.Test.SPV.EventProof (properties) +import Chainweb.Storage.Table.RocksDB +import Chainweb.Test.BlockHeader.Genesis qualified (tests) +import Chainweb.Test.BlockHeader.Validation qualified (tests) +import Chainweb.Test.BlockHeaderDB qualified (tests) +import Chainweb.Test.BlockHeaderDB.PruneForks qualified (tests) +import Chainweb.Test.Chainweb.Utils.Paging qualified (properties) +import Chainweb.Test.Cut qualified (properties) +import Chainweb.Test.CutDB qualified (tests) +import Chainweb.Test.Difficulty qualified (properties) +import Chainweb.Test.HostAddress qualified (properties) +import Chainweb.Test.Mempool.InMem qualified (tests) +import Chainweb.Test.Mempool.RestAPI qualified (tests) +import Chainweb.Test.Mempool.Sync qualified (tests) +import Chainweb.Test.MinerReward qualified (tests) +import Chainweb.Test.Mining qualified (tests) +import Chainweb.Test.Misc qualified (tests) +import Chainweb.Test.Pact.BlockHistoryMigrationTest qualified (tests) +import Chainweb.Test.Pact.CheckpointerTest qualified +import Chainweb.Test.Pact.HyperlanePluginTests qualified +import Chainweb.Test.Pact.SignedListPluginTests qualified +import Chainweb.Test.Pact.PactServiceTest qualified +import Chainweb.Test.Pact.RemotePactTest qualified +import Chainweb.Test.Pact.TransactionExecTest qualified +import Chainweb.Test.Pact.TransactionTests qualified +import Chainweb.Test.Pact4.NoCoinbase qualified +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.ResponseSizeLimiter qualified +import Chainweb.Test.RestAPI qualified (tests) +import Chainweb.Test.Roundtrips qualified (tests) +import Chainweb.Test.Sync.WebBlockHeaderStore qualified (properties) +import Chainweb.Test.TreeDB qualified (properties) +import Chainweb.Test.TreeDB.RemoteDB qualified +import Chainweb.Test.Version qualified (tests) import Control.Monad.IO.Class import Control.Monad.Trans.Resource - +import Data.Test.PQueue qualified (properties) +import Data.Test.Word.Encoding qualified (properties) +import P2P.Test.Node qualified (properties) +import P2P.Test.TaskQueue qualified (properties) import System.Environment import System.LogLevel - +import Test.Chainweb.SPV.Argument qualified import Test.Tasty import Test.Tasty.JsonReporter import Test.Tasty.QuickCheck --- chainweb modules - -import Chainweb.BlockHeader -import Chainweb.BlockHeaderDB -import Chainweb.Storage.Table.RocksDB -import Chainweb.Version.Development -import Chainweb.Version.RecapDevelopment -import Chainweb.Version.Registry - --- chainweb-test-tools modules - -import Chainweb.Test.Utils - (independentSequentialTestGroup, toyChainId, withToyDB) - --- internal modules - -import qualified Chainweb.Test.BlockHeader.Genesis (tests) -import qualified Chainweb.Test.BlockHeader.Validation (tests) -import qualified Chainweb.Test.BlockHeaderDB (tests) -import qualified Chainweb.Test.BlockHeaderDB.PruneForks (tests) -import qualified Chainweb.Test.Chainweb.Utils.Paging (properties) -import qualified Chainweb.Test.Cut (properties) -import qualified Chainweb.Test.CutDB (tests) -import qualified Chainweb.Test.Difficulty (properties) -import qualified Chainweb.Test.HostAddress (properties) -import qualified Chainweb.Test.Mempool.Consensus (tests) -import qualified Chainweb.Test.Mempool.InMem (tests) -import qualified Chainweb.Test.Mempool.RestAPI (tests) -import qualified Chainweb.Test.Mempool.Sync (tests) -import qualified Chainweb.Test.MinerReward (tests) -import qualified Chainweb.Test.Mining (tests) -import qualified Chainweb.Test.Misc (tests) -import qualified Chainweb.Test.Pact4.Checkpointer (tests) -import qualified Chainweb.Test.Pact4.DbCacheTest (tests) -import qualified Chainweb.Test.Pact4.GrandHash (tests) -import qualified Chainweb.Test.Pact4.ModuleCacheOnRestart (tests) -import qualified Chainweb.Test.Pact4.NoCoinbase (tests) -import qualified Chainweb.Test.Pact4.PactExec (tests) -import qualified Chainweb.Test.Pact4.PactMultiChainTest (tests) -import qualified Chainweb.Test.Pact4.PactReplay (tests) -import qualified Chainweb.Test.Pact4.PactSingleChainTest (tests) -import qualified Chainweb.Test.Pact4.RemotePactTest (tests) -import qualified Chainweb.Test.Pact4.RewardsTest (tests) -import qualified Chainweb.Test.Pact4.SPV (tests) -import qualified Chainweb.Test.Pact4.SQLite (tests) -import qualified Chainweb.Test.Pact4.TTL (tests) -import qualified Chainweb.Test.Pact4.TransactionTests (tests) -import qualified Chainweb.Test.Pact4.VerifierPluginTest (tests) -import qualified Chainweb.Test.Pact5.CheckpointerTest -import qualified Chainweb.Test.Pact5.HyperlanePluginTests -import qualified Chainweb.Test.Pact5.SignedListPluginTests -import qualified Chainweb.Test.Pact5.PactServiceTest -import qualified Chainweb.Test.Pact5.RemotePactTest -import qualified Chainweb.Test.Pact5.SPVTest -import qualified Chainweb.Test.Pact5.TransactionExecTest -import qualified Chainweb.Test.Pact5.TransactionTests -import qualified Chainweb.Test.ResponseSizeLimiter -import qualified Chainweb.Test.RestAPI (tests) -import qualified Chainweb.Test.Roundtrips (tests) -import qualified Chainweb.Test.SPV (tests) -import qualified Chainweb.Test.SPV.EventProof (properties) -import qualified Chainweb.Test.Sync.WebBlockHeaderStore (properties) -import qualified Chainweb.Test.TreeDB (properties) -import qualified Chainweb.Test.TreeDB.RemoteDB -import qualified Chainweb.Test.Version (tests) -import qualified Data.Test.PQueue (properties) -import qualified Data.Test.Word.Encoding (properties) -import qualified P2P.Test.Node (properties) -import qualified P2P.Test.TaskQueue (properties) - setTestLogLevel :: LogLevel -> IO () setTestLogLevel l = setEnv "CHAINWEB_TEST_LOG_LEVEL" (show l) main :: IO () main = do - registerVersion RecapDevelopment - registerVersion Development withTempRocksDb "chainweb-tests" $ \rdb -> runResourceT $ do - (h0, db) <- withToyDB rdb toyChainId + -- (h0, db) <- withToyDB rdb toyChainId liftIO $ defaultMainWithIngredients (consoleAndJsonReporter : defaultIngredients) $ adjustOption adj $ testGroup "Chainweb Tests" - $ pactTestSuite rdb - : mempoolTestSuite db h0 - : nodeTestSuite rdb - : suite rdb -- Coinbase Vuln Fix Tests are broken, waiting for Jose loadScript + $ suite rdb + -- : mempoolTestSuite db h0 - where + where adj NoTimeout = Timeout (1_000_000 * 60 * 10) "10m" adj x = x -mempoolTestSuite :: BlockHeaderDb -> BlockHeader -> TestTree -mempoolTestSuite db genesisBlock = testGroup "Mempool Consensus Tests" - [Chainweb.Test.Mempool.Consensus.tests db genesisBlock] - -pactTestSuite :: RocksDb -> TestTree -pactTestSuite rdb = testGroup "Chainweb-Pact Tests" - [ Chainweb.Test.Pact4.PactExec.tests -- OK: but need fixes (old broken tests) - , Chainweb.Test.Pact4.DbCacheTest.tests - , Chainweb.Test.Pact4.Checkpointer.tests - - , Chainweb.Test.Pact4.PactMultiChainTest.tests rdb -- BROKEN few tests - - , Chainweb.Test.Pact4.PactSingleChainTest.tests rdb - - , Chainweb.Test.Pact4.VerifierPluginTest.tests rdb -- BROKEN - - , Chainweb.Test.Pact4.PactReplay.tests rdb - , Chainweb.Test.Pact4.ModuleCacheOnRestart.tests rdb - , Chainweb.Test.Pact4.TTL.tests rdb - , Chainweb.Test.Pact4.RewardsTest.tests - , Chainweb.Test.Pact4.NoCoinbase.tests - , Chainweb.Test.Pact4.GrandHash.tests - ] - -nodeTestSuite :: RocksDb -> TestTree -nodeTestSuite rdb = independentSequentialTestGroup "Tests starting nodes" - [ Chainweb.Test.Pact4.RemotePactTest.tests rdb -- BROKEN - ] +-- mempoolTestSuite :: BlockHeaderDb -> BlockHeader -> TestTree +-- mempoolTestSuite db genesisBlock = testGroup "Mempool Consensus Tests" +-- [withVersion toyVersion $ Chainweb.Test.Mempool.Consensus.tests db genesisBlock] suite :: RocksDb -> [TestTree] suite rdb = @@ -153,26 +99,34 @@ suite rdb = , testGroup "BlockHeaderDb" [ Chainweb.Test.BlockHeaderDB.tests rdb , Chainweb.Test.TreeDB.RemoteDB.tests - , Chainweb.Test.BlockHeaderDB.PruneForks.tests + , Chainweb.Test.BlockHeaderDB.PruneForks.tests rdb , testProperties "Chainweb.Test.TreeDB" Chainweb.Test.TreeDB.properties ] - , Chainweb.Test.Pact4.SQLite.tests , Chainweb.Test.CutDB.tests rdb - , Chainweb.Test.Pact4.TransactionTests.tests -- TODO: fix, awaiting for Jose to add loadScript function - , Chainweb.Test.Pact5.CheckpointerTest.tests - , Chainweb.Test.Pact5.TransactionExecTest.tests rdb - , Chainweb.Test.Pact5.PactServiceTest.tests rdb - , Chainweb.Test.Pact5.SPVTest.tests rdb - , Chainweb.Test.Pact5.RemotePactTest.tests rdb - , Chainweb.Test.Pact5.HyperlanePluginTests.tests rdb - , Chainweb.Test.Pact5.SignedListPluginTests.tests rdb - , Chainweb.Test.Pact5.TransactionTests.tests + , Chainweb.Test.Pact.CheckpointerTest.tests + , Chainweb.Test.Pact.BlockHistoryMigrationTest.tests + , Chainweb.Test.Pact.TransactionExecTest.tests rdb + , Chainweb.Test.Pact.PactServiceTest.tests rdb + -- TODO: PP + -- , Chainweb.Test.Pact.SPVTest.tests rdb + , Chainweb.Test.Pact.RemotePactTest.tests rdb + , Chainweb.Test.Pact.HyperlanePluginTests.tests rdb + , Chainweb.Test.Pact.SignedListPluginTests.tests rdb + , Chainweb.Test.Pact.TransactionTests.tests , Chainweb.Test.Roundtrips.tests , Chainweb.Test.RestAPI.tests rdb - , testGroup "SPV" - [ Chainweb.Test.SPV.tests rdb - , Chainweb.Test.Pact4.SPV.tests rdb - , Chainweb.Test.SPV.EventProof.properties + -- TODO: PP + -- , testGroup "SPV" + -- [ Chainweb.Test.SPV.tests rdb + -- [ Chainweb.Test.Pact4.SPV.tests rdb + -- , Chainweb.Test.SPV.EventProof.properties + -- ] + , testGroup "Pact 4" + [ Chainweb.Test.Pact4.NoCoinbase.tests + , Chainweb.Test.Pact4.RewardsTest.tests + , Chainweb.Test.Pact4.SQLite.tests + , Chainweb.Test.Pact4.VerifierPluginTest.tests + , Chainweb.Test.Pact4.TransactionTests.tests ] , Chainweb.Test.Mempool.InMem.tests , Chainweb.Test.Mempool.Sync.tests @@ -193,4 +147,7 @@ suite rdb = , testProperties "Data.Test.Word.Encoding" Data.Test.Word.Encoding.properties , Chainweb.Test.ResponseSizeLimiter.tests ] + , testGroup "Chainweb Payload Provider Unit Tests" + [ Test.Chainweb.SPV.Argument.tests + ] ] diff --git a/test/unit/Test/Chainweb/SPV/Argument.hs b/test/unit/Test/Chainweb/SPV/Argument.hs new file mode 100644 index 0000000000..d3dc08287a --- /dev/null +++ b/test/unit/Test/Chainweb/SPV/Argument.hs @@ -0,0 +1,549 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TypeAbstractions #-} +{-# LANGUAGE TypeApplications #-} + +-- | +-- Module: Test.Chainweb.SPV.Argument +-- Copyright: Copyright © 2025 Kadena LLC. +-- License: MIT +-- Maintainer: Lars Kuhtz +-- Stability: experimental +-- +module Test.Chainweb.SPV.Argument +( tests +) where + +import Chainweb.BlockHash +import Chainweb.BlockHeader +import Chainweb.ChainId +import Chainweb.Crypto.MerkleLog +import Chainweb.MerkleLogHash +import Chainweb.MerkleUniverse +import Chainweb.Pact.Payload +import Chainweb.PayloadProvider.EVM.Header qualified as EVM +import Chainweb.PayloadProvider.EVM.Receipt qualified as EVM +import Chainweb.PayloadProvider.Pact.Genesis qualified as Pact +import Chainweb.SPV.Argument +import Chainweb.Version +import Chainweb.Version.EvmTestnet +import Chainweb.Version.Mainnet +import Control.Lens +import Control.Monad +import Data.Aeson +import Data.Coerce +import Data.List.NonEmpty qualified as NE +import Data.MerkleLog qualified as ML +import Data.MerkleLog.V1 qualified as MLV1 +import Data.Text qualified as T +import Data.Typeable +import Data.Vector qualified as V +import Numeric.Natural +import Test.Tasty +import Test.Tasty.HUnit +import Text.RawString.QQ + +-- -------------------------------------------------------------------------- -- +-- Tests + +tests :: TestTree +tests = testGroup "Chainweb.SPV.Argument" + [ testCase "Pact Output Argument" test_pactOutputArgument + , testCase "Legacy Pact Output Argument" test_legacyPactOutputArgument + , testCase "EVM JSON Roundtrips" test_jsonRoundtrips + , testCase "EVM Header Arguments" test_evmHeaderArguments + ] + +-- -------------------------------------------------------------------------- -- +-- JSON Roundrip Tests for Test Data + +test_jsonRoundtrip + :: Typeable a + => Show a + => Eq a + => ToJSON a + => FromJSON a + => a + -> IO () +test_jsonRoundtrip a = assertEqual + ("json roundtrip for type " <> show (typeOf a)) + (Right a) + (eitherDecode (encode a)) + +test_jsonRoundtrips :: IO () +test_jsonRoundtrips = withVersion evmTestnet $ do + test_jsonRoundtrip testHeader + test_jsonRoundtrip testPayload + test_jsonRoundtrip testRpcReceipt + +-- -------------------------------------------------------------------------- -- +-- Test Data + +pactMainnetGenesisPayload :: ChainId -> Maybe PayloadWithOutputs +pactMainnetGenesisPayload = withVersion Mainnet01 Pact.genesisPayload + +genesisData :: HasVersion => ChainId -> IO (BlockHeader, PayloadWithOutputs) +genesisData cid = do + let hdr = genesisBlockHeader cid + pwo <- case pactMainnetGenesisPayload cid of + Just x -> return x + Nothing -> error "genesis block for chain 0 not found" + assertEqual "block payload hash of header and payload match" + (view blockPayloadHash hdr) + (_payloadWithOutputsPayloadHash pwo) + return (hdr, pwo) + +-- evmGenesisData :: ChainId -> IO (BlockHeader, PayloadWithOutputs) +-- evmGenesisData cid = do +-- let hdr = EVM.genesisBlocks EvmDevelopment cid +-- EVM.hdr hdr +-- -- pwo <- case preview (ixg cid) (genesisPayload EvmDevelopment) of +-- -- Just x -> return x +-- -- Nothing -> error "genesis block for chain 0 not found" +-- -- assertEqual "block payload hash of header and payload match" +-- -- (view blockPayloadHash hdr) +-- -- (_payloadWithOutputsPayloadHash pwo) +-- -- return (hdr, pwo) + +-- -------------------------------------------------------------------------- -- +-- Tests + +test_pactOutputArgument :: IO () +test_pactOutputArgument = withVersion mainnet $ do + (hdr, pwo) <- genesisData (unsafeChainId 0) + hdrArg <- test_hdr hdr + + let txCount = length $ _payloadWithOutputsTransactions pwo + + -- run test for each tx in the block + forM_ [0 .. txCount - 1] $ \txPos -> do + + pwoArg <- test_txOutput txPos pwo + + -- compose pact output and header arguments + arg <- compose pwoArg hdrArg + argRoot <- runArg arg + assertEqual "composed argument gives correct root hash" + (view blockHash hdr) + argRoot + + claim <- argumentClaim arg + assertEqual "argument claim is correct" + (snd (_payloadWithOutputsTransactions pwo V.! txPos)) + claim + +test_legacyPactOutputArgument :: IO () +test_legacyPactOutputArgument = withVersion mainnet $ do + (hdr, pwo) <- genesisData (unsafeChainId 0) + + -- create tx output proof for tx 0 + let outs = snd $ payloadWithOutputsToBlockObjects pwo + let txCount = length (_blockOutputs outs) + + let pld = payloadDataToBlockPayload (payloadWithOutputsToPayloadData pwo) + let pldTree = headerTree_ @BlockOutputsHash @ChainwebMerkleHashAlgorithm pld + let hdrTree = headerTree_ @BlockPayloadHash @ChainwebMerkleHashAlgorithm hdr + + -- run test for each tx in the block + forM_ [0 .. txCount - 1] $ \txPos -> do + let (outs0, outs0Pos, outs0Tree) = + bodyTree @ChainwebMerkleHashAlgorithm outs txPos + + -- create block payload proof for for outputs + proof <- MLV1.merkleTreeProof_ outs0 $ + (outs0Pos, outs0Tree) NE.:| [ pldTree, hdrTree ] + + root <- MLV1.runMerkleProof proof + assertEqual "body proof of tx output gives correct root hash" + (view blockHash hdr) + (coerce root) + + -- create legacy pact output argument + let arg = PactLegacyProof proof + argRoot <- runArg arg + assertEqual "pact output argument gives correct root hash" + (view blockHash hdr) + argRoot + + claim <- argumentClaim arg + assertEqual "argument claim is correct" + (snd (_payloadWithOutputsTransactions pwo V.! txPos)) + claim + +test_hdr + :: HasVersion + => BlockHeader + -> IO (Argument BlockPayloadHash BlockHash) +test_hdr hdr = do + hdrProof <- headerProofV2 @BlockPayloadHash @ChainwebMerkleHashAlgorithm hdr + assertEqual "header proof gives correct root hash" + (view blockHash hdr) + (coerce $ ML.runProof hdrProof) + + -- create header argument + let hdrArg = BlockPayloadHashArgument hdrProof + hdrArgRoot <- runArg hdrArg + assertEqual "header argument gives correct root hash" + (view blockHash hdr) + hdrArgRoot + + return hdrArg + +test_txOutput + :: Int + -> PayloadWithOutputs + -> IO (Argument TransactionOutput BlockPayloadHash) +test_txOutput txPos pwo = do + -- create tx output proof for tx 0 + let outs = snd $ payloadWithOutputsToBlockObjects pwo + outs0Proof <- bodyProofV2 @ChainwebMerkleHashAlgorithm outs txPos + assertEqual "body proof of tx output gives correct root hash" + (_payloadWithOutputsOutputsHash pwo) + (coerce $ ML.runProof outs0Proof) + + -- create block payload proof for for outputs + let pld = payloadDataToBlockPayload (payloadWithOutputsToPayloadData pwo) + pldProof <- headerProofV2 @BlockOutputsHash @ChainwebMerkleHashAlgorithm pld + assertEqual "block payload proof gives correct root hash" + (_payloadWithOutputsPayloadHash pwo) + (coerce $ ML.runProof pldProof) + + -- compose proofs into pact output proof + pwoProof <- ML.composeProofs outs0Proof pldProof + assertEqual "composed pact output proof gives correct root hash" + (_payloadWithOutputsPayloadHash pwo) + (coerce $ ML.runProof pwoProof) + + -- create pact output argument + let pwoArg = PactOutputArgument @BlockPayloadHash pwoProof + pwoArgRoot <- runArg pwoArg + assertEqual "pact output argument gives correct root hash" + (_payloadWithOutputsPayloadHash pwo) + pwoArgRoot + + return pwoArg + +-- -------------------------------------------------------------------------- -- +-- EVM Receipt Tests + +data ReceiptTestData = ReceiptTestData + { _receiptTestDataHeader :: BlockHeader + , _receiptTestDataPayload :: EVM.Header + , _receiptTestDataRpcReceipts :: [EVM.RpcReceipt] + } + deriving (Show, Eq) + +simpleTestData :: HasVersion => ReceiptTestData +simpleTestData = ReceiptTestData + { _receiptTestDataHeader = testHeader + , _receiptTestDataPayload = testPayload + , _receiptTestDataRpcReceipts = [testRpcReceipt] + } + +test_evmHeaderArguments :: IO () +test_evmHeaderArguments = + withVersion evmTestnet $ test_evmHeaderArgument simpleTestData 0 + +test_evmHeaderArgument :: HasVersion => ReceiptTestData -> Natural -> IO () +test_evmHeaderArgument d _idx = do + let trieProof = EVM.rpcReceiptTrieProof rs (EVM.TransactionIndex 0) + trieProofRoot <- validateTrieProof trieProof + assertEqual "receipt proof gives correct root hash" + (EVM._hdrReceiptsRoot pld) + (EVM.ReceiptsRoot trieProofRoot) + + -- create EthReceiptArgument + let evmReceiptArg = EthReceiptArgument trieProof + evmReceiptArgRoot <- runArg evmReceiptArg + assertEqual "receipt argument gives correct root hash" + (EVM._hdrReceiptsRoot pld) + evmReceiptArgRoot + + -- create EVM Payload Proof + evmPayloadProof <- headerProofV2 @EVM.ReceiptsRoot @ChainwebMerkleHashAlgorithm + pld + assertEqual "EVM payload proof gives correct root hash" + (EVM._hdrPayloadHash pld) + (coerce $ ML.runProof evmPayloadProof) + + -- create EVM BlockHeaderArgument + let evmHdrArg = EthHeaderArgument evmPayloadProof + evmHdrArgRoot <- runArg evmHdrArg + assertEqual "header argument gives correct root hash" + (EVM._hdrPayloadHash pld) + evmHdrArgRoot + + -- compose EVM header and receipt arguments + payloadArg <- compose evmReceiptArg evmHdrArg + payloadArgRoot <- runArg payloadArg + assertEqual "composed argument gives correct root hash" + (EVM._hdrPayloadHash pld) + payloadArgRoot + + -- create Header Proof + hdrProof <- headerProofV2 @BlockPayloadHash @ChainwebMerkleHashAlgorithm hdr + assertEqual "header proof gives correct root hash" + (view blockHash hdr) + (coerce $ ML.runProof hdrProof) + + let hdrArgument = BlockPayloadHashArgument hdrProof + hdrArgumentRoot <- runArg hdrArgument + assertEqual "header argument gives correct root hash" + (view blockHash hdr) + hdrArgumentRoot + + -- compose payload argument and header argument + arg <- compose payloadArg hdrArgument >>= \a -> case a of + ComposeArgument EthReceiptArgument{} EthHeaderArgument{} -> return a + _ -> assertFailure "Argument is not composition of EthReceiptArgument and EthHeaderArgument" :: IO (Argument EVM.Receipt BlockHash) + argRoot <- runArg arg + assertEqual "composed argument gives correct root hash" + (view blockHash hdr) + argRoot + + where + rs = _receiptTestDataRpcReceipts d + pld = _receiptTestDataPayload d + hdr = _receiptTestDataHeader d + +-- -------------------------------------------------------------------------- -- +-- EVM Test Data + +-- testReceipt :: EVM.Receipt +-- testReceipt = EVM.fromRpcReceipt testRpcReceipt + +testRpcReceipt :: EVM.RpcReceipt +testRpcReceipt = case eitherDecodeStrictText jsonReceiptStr of + Left err -> error $ "failed to decode receipt: " <> show err + Right x -> x + where + jsonReceiptStr :: T.Text + jsonReceiptStr = [r| + { + "status": "0x1", + "cumulativeGasUsed": "0xb1d6", + "logs": [ + { + "address": "0x7f81bfb73cb29c3725779ec2c060787daa2f97d4", + "topics": [ + "0xb4beca5a896c70c0f896e51f0c7c91592fe79893272eb4d5f41aa376c3c2aa95", + "0x000000000000000000000000a525fcb70404336c591833a85abb1663b779cddf" + ], + "data": "0x0000000000000000000000000000000000000000000000000000000068e6c67d00000000000000000000000000000000000000000000000000000000000000020000000000000000000000000000000000000000000000000000000000004f91", + "blockHash": "0x78bc1a838d8e69c3f980d3c69ad79bf9b1dbc934ca9f9cb572408fac3259d161", + "blockNumber": "0x45426", + "blockTimestamp": "0x68e6c67d", + "transactionHash": "0x807bd8e1999cc975bd14826033e998c92d1eb604342ae0dcdc3e2dec015466c3", + "transactionIndex": "0x0", + "logIndex": "0x0", + "removed": false + } + ], + "logsBloom": "0x00000000000000000000000000000000000000000000000000000000000000000000000000000000002000000001200000000000000000000000000000000001000000000000000000000000000000000200000000000000000000000000000000000000000000000000000000080000000000000000000000000000000000000000000000000000000000000000000000000000000002000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000004000000000000000000000000000000000000000002000", + "type": "0x0", + "transactionHash": "0x807bd8e1999cc975bd14826033e998c92d1eb604342ae0dcdc3e2dec015466c3", + "transactionIndex": "0x0", + "blockHash": "0x78bc1a838d8e69c3f980d3c69ad79bf9b1dbc934ca9f9cb572408fac3259d161", + "blockNumber": "0x45426", + "gasUsed": "0xb1d6", + "effectiveGasPrice": "0x47868c08", + "from": "0xa525fcb70404336c591833a85abb1663b779cddf", + "to": "0x7f81bfb73cb29c3725779ec2c060787daa2f97d4", + "contractAddress": null + } + |] + +testPayload :: EVM.Header +testPayload = case eitherDecodeStrictText payloadStr of + Left err -> error $ "failed to decode payload: " <> show err + Right x -> x + where + -- TODO: the below is not a valid Pectra header, so the test fails + payloadStr :: T.Text + payloadStr = [r| + { + "hash": "0x78bc1a838d8e69c3f980d3c69ad79bf9b1dbc934ca9f9cb572408fac3259d161", + "parentHash": "0x2afaa2d34fb53b08aa150f9e8b0f707753ed7778d0f8ee6b22601d8a6fadcd01", + "sha3Uncles": "0x1dcc4de8dec75d7aab85b567b6ccd41ad312451b948a7413f0a142fd40d49347", + "miner": "0x8cb33ecc40c31b79ae414a3d958b1b094b8993ce", + "stateRoot": "0x6ffe7d5fe11439a683a9de6a59b9d9b2576772298d4c077ab0b262c311aa0139", + "transactionsRoot": "0xed97db66cd791a681eb8ef982285003fa51aa9bd1eba11df2a616b0b2d479a8c", + "receiptsRoot": "0xb2c672dbd3f5c41fe156dddcca90b1ebc847da3a5f338bc66b697f3a1151f582", + "logsBloom": "0x00000000000000000000000000000000000000000000000000000000000000000000000000000000002000000001200000000000000000000000000000000001000000000000000000000000000000000200000000000000000000000000000000000000000000000000000000080000000000000000000000000000000000000000000000000000000000000000000000000000000002000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000004000000000000000000000000000000000000000002000", + "difficulty": "0x0", + "number": "0x45426", + "gasLimit": "0x1c9c380", + "gasUsed": "0xb1d6", + "timestamp": "0x68e6c67d", + "extraData": "0x", + "mixHash": "0x0000000000000000000000000000000000000000000000000000000000000000", + "nonce": "0x0000000000000000", + "baseFeePerGas": "0x7", + "withdrawalsRoot": "0x7e36212b14efdeab5312650a1c64bfd672db373e97d00d4aa9e6ec1397d94b82", + "blobGasUsed": "0x0", + "excessBlobGas": "0x0", + "parentBeaconBlockRoot": "0xb2613c38880572d2467803b8a236eee297f20a1ec0bb20b6ee3ba69f85aa168c", + "requestsHash": "0xe3b0c44298fc1c149afbf4c8996fb92427ae41e4649b934ca495991b7852b855", + "size": "0x2f6", + "uncles": [], + "transactions": [ + { + "type": "0x0", + "chainId": "0x1720", + "nonce": "0x1b", + "gasPrice": "0x47868c08", + "gas": "0x10cfd", + "to": "0x7f81bfb73cb29c3725779ec2c060787daa2f97d4", + "value": "0x0", + "input": "0xef5fb05b", + "r": "0xb51a0cefb88f0a0ab6bc82720a1da7c9ba05116e76ac519740736a1f225524e9", + "s": "0x1447924901426ae0a0df648f700eb7f4760cd3b572360c6d1981077248eeeda6", + "v": "0x2e63", + "hash": "0x807bd8e1999cc975bd14826033e998c92d1eb604342ae0dcdc3e2dec015466c3", + "blockHash": "0x78bc1a838d8e69c3f980d3c69ad79bf9b1dbc934ca9f9cb572408fac3259d161", + "blockNumber": "0x45426", + "transactionIndex": "0x0", + "from": "0xa525fcb70404336c591833a85abb1663b779cddf" + } + ], + "withdrawals": [ + { + "index": "0x45426", + "validatorIndex": "0x0", + "address": "0x8cb33ecc40c31b79ae414a3d958b1b094b8993ce", + "amount": "0xde53c1b" + } + ] + } + |] + +testHeader :: HasVersion => BlockHeader +testHeader = case eitherDecodeStrictText headerStr of + Left err -> error $ "failed to decode header: " <> show err + Right (ObjectEncoded x) -> x + where + headerStr :: T.Text + headerStr = [r| + { + "featureFlags": 0, + "creationTime": 1759954586876631, + "parent": "smE8OIgFctJGeAO4ojbu4pfyCh7AuyC27jumn4WqFow", + "adjacents": { + "41": "bRgmeumz8u8L1V_HYKgL-rwUNSqKlXB-ap_7ssmpptI", + "69": "ZacCSYKvKIUoVcRLD8Y_J0SLjyHBL9lotdeWn3kFFJ4", + "79": "sefhr1YuvwtsnqOoCftjW28lytACU_5I0UmHH2EK_rM", + "86": "taX_Ekq_vacCT4G6AR6oMo0VRVt2RgAJ2sPmUiMtYDY" + }, + "target": "BgAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA", + "payloadHash": "JUXtOVmUmUCCR8O0F4qNzLdp8WU7Xr4CGpLte70Ef9E", + "chainId": 20, + "weight": "ziBRVAzQZq_oNsjiWK0LSFSwS3WbffvI28fVKKlcqFY", + "height": 283686, + "chainwebVersion": "evm-testnet", + "epochStart": 1759954428697267, + "nonce": "0x0000000000000000", + "hash": "aV9bLh5Pfb-ZnM-jFlsarg6kNZ31HFL-0hjlV1BC4DQ" + } + |] + + -- FIXME: this is actually an evm-testnet header + + +-- EVM Development block (chain 0, height 354) +-- { +-- "receipts": [ +-- { +-- "type": "0x2", +-- "status": "0x1", +-- "cumulativeGasUsed": "0x9dcf", +-- "logs": [ +-- { +-- "address": "0x0826f2fc8902ca5afe82570560ba752a7f53675c", +-- "topics": [ +-- "0xddf252ad1be2c89b69c2b068fc378daa952ba7f163c4a11628f55a4df523b3ef", +-- "0x000000000000000000000000fb8fb7f9bdc8951040a6d195764905138f7462ed", +-- "0x0000000000000000000000000000000000000000000000000000000000000000" +-- ], +-- "data": "0x0000000000000000000000000000000000000000000000056bc75e2d63100000", +-- "blockHash": "0x47c1944c382527f82044276c04a9e0d642da58316d1b963e7a623e03ac085d4f", +-- "blockNumber": "0x162", +-- "blockTimestamp": "0x67ef2c65", +-- "transactionHash": "0x3247ba77980ba47c6a59afc8d73bf5d70eff69e7f129b680b15451e45c3b4d5d", +-- "transactionIndex": "0x0", +-- "logIndex": "0x0", +-- "removed": false +-- }, +-- { +-- "address": "0x0826f2fc8902ca5afe82570560ba752a7f53675c", +-- "topics": [ +-- "0x9d2528c24edd576da7816ca2bdaa28765177c54b32fb18e2ca18567fbc2a9550", +-- "0x0000000000000000000000000000000000000000000000000000000000000001", +-- "0x000000000000000000000000ead0610198d4d802f9d14ec7e8d85d30233ccc6b", +-- "0x0000000000000000000000000000000000000000000000000000000000000001" +-- ], +-- "data": "0x0000000000000000000000000000000000000000000000000000000000000020000000000000000000000000000000000000000000000000000000000000004000000000000000000000000028f2d8ef4e0fe6b2e945cf5c33a0118a30a623540000000000000000000000000000000000000000000000056bc75e2d63100000", +-- "blockHash": "0x47c1944c382527f82044276c04a9e0d642da58316d1b963e7a623e03ac085d4f", +-- "blockNumber": "0x162", +-- "blockTimestamp": "0x67ef2c65", +-- "transactionHash": "0x3247ba77980ba47c6a59afc8d73bf5d70eff69e7f129b680b15451e45c3b4d5d", +-- "transactionIndex": "0x0", +-- "logIndex": "0x1", +-- "removed": false +-- } +-- ], +-- "logsBloom": "0x00000000000000000000000000000000000000000000000020000000000000000000000000000000000000000000000000000800000000000000000000040100000000000000000000000008000000000000000000040000000000000000000000000000020000000000000000000800000000000000000000002010000000000000000000000000000100000000004000000000000000000001000000000000000000000000000000000000000000000000000000008000000000000000002000000002000000000000000000000000000000000000000040000000000060004000000000000000000000000000000000000200000000000000000000000000", +-- "transactionHash": "0x3247ba77980ba47c6a59afc8d73bf5d70eff69e7f129b680b15451e45c3b4d5d", +-- "transactionIndex": "0x0", +-- "blockHash": "0x47c1944c382527f82044276c04a9e0d642da58316d1b963e7a623e03ac085d4f", +-- "blockNumber": "0x162", +-- "gasUsed": "0x9dcf", +-- "effectiveGasPrice": "0x3b9aca07", +-- "from": "0xfb8fb7f9bdc8951040a6d195764905138f7462ed", +-- "to": "0x0826f2fc8902ca5afe82570560ba752a7f53675c", +-- "contractAddress": null +-- } +-- ], +-- "payload": { +-- "parentHash": "0x692d784f999068270a78491f50404073f988a324598799866f740e2a52857a6a", +-- "sha3Uncles": "0x1dcc4de8dec75d7aab85b567b6ccd41ad312451b948a7413f0a142fd40d49347", +-- "miner": "0xd42d71cdc2a0a78fe7fbe7236c19925f62c442ba", +-- "stateRoot": "0x05f700ac2df8e2985433b63e3641e308976dd1a0dc0d29b600f71cc20939cba9", +-- "transactionsRoot": "0x8748b3f2e8d6a4a78a6f4b4b39e608cd3765505fd317020ba4c4a1aae4a6018c", +-- "receiptsRoot": "0x37cb5c601f1a535769d6a36c35f34c22fea9e9a1a011144381b8e3c7bb31657c", +-- "logsBloom": "0x00000000000000000000000000000000000000000000000020000000000000000000000000000000000000000000000000000800000000000000000000040100000000000000000000000008000000000000000000040000000000000000000000000000020000000000000000000800000000000000000000002010000000000000000000000000000100000000004000000000000000000001000000000000000000000000000000000000000000000000000000008000000000000000002000000002000000000000000000000000000000000000000040000000000060004000000000000000000000000000000000000200000000000000000000000000", +-- "difficulty": "0x0", +-- "number": "0x162", +-- "gasLimit": "0x1c9c380", +-- "gasUsed": "0x9dcf", +-- "timestamp": "0x67ef2c65", +-- "extraData": "0x726574682f76312e312e352f6c696e7578", +-- "mixHash": "0x0000000000000000000000000000000000000000000000000000000000000000", +-- "nonce": "0x0000000000000000", +-- "baseFeePerGas": "0x7", +-- "withdrawalsRoot": "0x2f1a2b19c3801a44641db3f88532b818b585754dc389fd18ab6a0299e2ebdbc2", +-- "blobGasUsed": "0x0", +-- "excessBlobGas": "0x0", +-- "parentBeaconBlockRoot": "0x80af8b91b32cae2e3c3b17ef0b6ce9124e01176bf953f192633a6cc718f129ba", +-- "hash": "0x47c1944c382527f82044276c04a9e0d642da58316d1b963e7a623e03ac085d4f" +-- }, +-- "nonce": "0", +-- "creationTime": 1743727718036200, +-- "parent": "gK-LkbMsri48OxfvC2zpEk4BF2v5U_GSYzpsxxjxKbo", +-- "adjacents": { +-- "10": "RJuqDTjhoclukSr7qPOkg0IOAcEJ1bIeltehw_-OHTo", +-- "5": "xOqpgPjJl0VehoCDX4se2i-cK1Ql_R75YHa1pAuSuWo", +-- "15": "B0iB0OTRlVtQgOyCpdomGfJTyXF92R8pcs06upXTOrY" +-- }, +-- "target": "PKUF-3dimGnG6F3iN6MvPUA1hTNt8eECAAAAAAAAAAA", +-- "payloadHash": "RXrRaAvhF74-xJcQzVT8ZHJqW7FtgP4y0WWQCy13w9U", +-- "chainId": 0, +-- "weight": "9puuQnDNZ7WAKQAAAAAAAAAAAAAAAAAAAAAAAAAAAAA", +-- "height": 354, +-- "chainwebVersion": "evm-development", +-- "epochStart": 1743727581567100, +-- "featureFlags": 0, +-- "hash": "9NDFjt_VVE2_fJD54eLcybRfbp_BAOR2T2HxavWe7ho" +-- }