From a1198fc61f6f50ccf8951be4e61d1967b340ed6c Mon Sep 17 00:00:00 2001 From: Edmund Noble Date: Wed, 6 Nov 2024 15:06:22 -0500 Subject: [PATCH 1/9] randomized peer ordering We randomize the peer ordering by assigning a peer a random number that is used subsequently to order it with respect to other peers upon request from the /peer GET endpoint. An alternative of generating a seed on startup that would be used to "salt" the peer ordering was considered but ran into implementation difficulties and seems equivalent. --- src/P2P/Node.hs | 8 ++- src/P2P/Node/PeerDB.hs | 82 +++++++++++++++------- test/lib/Chainweb/Test/Orphans/Internal.hs | 3 +- 3 files changed, 66 insertions(+), 27 deletions(-) diff --git a/src/P2P/Node.hs b/src/P2P/Node.hs index 7443c1cc7..a2f39af46 100644 --- a/src/P2P/Node.hs +++ b/src/P2P/Node.hs @@ -614,7 +614,13 @@ newSession :: P2pConfiguration -> P2pNode -> IO () newSession conf node = do newPeer <- findNextPeer conf node let newPeerInfo = _peerEntryInfo newPeer - logg node Debug $ "Selected new peer " <> encodeToText newPeer + logg node Debug + $ "Selected new peer " <> encodeToText newPeerInfo <> ", " + <> encodeToText (_peerEntryActiveSessionCount newPeer) <> "# sessions, " + <> if _getPeerEntrySticky (_peerEntrySticky newPeer) then "sticky, " else "not sticky, " + <> encodeToText (_peerEntrySuccessiveFailures newPeer) <> "consec. failures, " + <> encodeToText (_peerEntryLastSuccess newPeer) <> "last success" + syncFromPeer_ newPeerInfo >>= \case False -> do threadDelay =<< R.randomRIO (400000, 500000) diff --git a/src/P2P/Node/PeerDB.hs b/src/P2P/Node/PeerDB.hs index 8a22012f3..af1089811 100644 --- a/src/P2P/Node/PeerDB.hs +++ b/src/P2P/Node/PeerDB.hs @@ -15,6 +15,7 @@ {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE RankNTypes #-} +{-# LANGUAGE BangPatterns #-} -- | -- Module: P2P.Node.PeerDB @@ -35,6 +36,7 @@ module P2P.Node.PeerDB , PeerEntrySticky(..) , HostAddressIdx , hostAddressIdx +, PeerMark(..) -- * Peer Entry , PeerEntry(..) @@ -42,10 +44,11 @@ module P2P.Node.PeerDB , peerEntrySuccessiveFailures , peerEntryLastSuccess , peerEntryNetworkIds +, peerEntryMark , peerEntrySticky -- * Peer Database -, PeerDb(..) +, PeerDb(_peerDbLocalPeer) , peerDbSnapshot , peerDbSnapshotSTM , peerDbSize @@ -83,7 +86,7 @@ import Control.Concurrent.MVar import Control.Concurrent.STM.TVar import Control.DeepSeq import Control.Lens hiding (Indexable) -import Control.Monad ((<$!>), unless) +import Control.Monad ((<$!>), unless, forM) import Control.Monad.STM import Data.Aeson @@ -145,8 +148,23 @@ newtype PeerEntrySticky = PeerEntrySticky { _getPeerEntrySticky :: Bool } deriving (Show, Eq, Ord, Generic) deriving newtype (ToJSON, FromJSON, Enum, NFData) +newtype PeerMark = UnsafePeerMark { _getPeerMark :: Int } + deriving (Show, Eq, Ord, Generic) + deriving newtype (NFData) + +randomPeerMark :: IO PeerMark +randomPeerMark = UnsafePeerMark <$> randomIO + data PeerEntry = PeerEntry - { _peerEntryInfo :: !PeerInfo + { _peerEntryMark :: !PeerMark + -- ^ This "marks" a peer entry with a random number for use in the + -- `Ord` instance, allowing the peer list to be quickly sampled in a + -- consistent way that will differ across nodes. + -- A randomly ordered peer list for each node allows paging through the entire + -- peer list without allowing the order to be manipulated as easily. + -- Note that this should never be persisted, as this order should differ + -- on each node startup. + , _peerEntryInfo :: !PeerInfo -- ^ There must be only one peer per peer address. A peer id -- can be updated from 'Nothing' to 'Just' some value. If a -- peer id of 'Just' some value changes, it is considered a @@ -178,16 +196,16 @@ data PeerEntry = PeerEntry -- } deriving (Show, Eq, Ord, Generic) - deriving anyclass (ToJSON, FromJSON, NFData) + deriving anyclass (NFData) makeLenses ''PeerEntry -newPeerEntry :: NetworkId -> PeerInfo -> PeerEntry +newPeerEntry :: NetworkId -> PeerMark -> PeerInfo -> PeerEntry newPeerEntry = newPeerEntry_ False -newPeerEntry_ :: Bool -> NetworkId -> PeerInfo -> PeerEntry -newPeerEntry_ sticky nid i = - PeerEntry i 0 (LastSuccess Nothing) (S.singleton nid) 0 (PeerEntrySticky sticky) +newPeerEntry_ :: Bool -> NetworkId -> PeerMark -> PeerInfo -> PeerEntry +newPeerEntry_ sticky nid mark i = + PeerEntry mark i 0 (LastSuccess Nothing) (S.singleton nid) 0 (PeerEntrySticky sticky) -- -------------------------------------------------------------------------- -- -- Peer Entry Set @@ -258,9 +276,8 @@ addPeerEntry b m = m & case getOne (getEQ addr m) of where addr = _peerAddr $ _peerEntryInfo b replace = updateIx addr b - update a = updateIx addr $!! PeerEntry - { _peerEntryInfo = _peerEntryInfo a - , _peerEntrySuccessiveFailures = _peerEntrySuccessiveFailures a + _peerEntrySuccessiveFailures b + update a = updateIx addr $!! a + { _peerEntrySuccessiveFailures = _peerEntrySuccessiveFailures a + _peerEntrySuccessiveFailures b , _peerEntryLastSuccess = max (_peerEntryLastSuccess a) (_peerEntryLastSuccess b) , _peerEntryNetworkIds = _peerEntryNetworkIds a <> _peerEntryNetworkIds b , _peerEntryActiveSessionCount = _peerEntryActiveSessionCount a + _peerEntryActiveSessionCount b @@ -279,10 +296,11 @@ addPeerEntry b m = m & case getOne (getEQ addr m) of -- -- If the 'PeerAddr' exist with the same peer-id, the chain-id is added. -- -addPeerInfo :: NetworkId -> PeerInfo -> UTCTime -> PeerSet -> PeerSet -addPeerInfo nid pinf now = addPeerEntry $ (newPeerEntry nid pinf) - { _peerEntryLastSuccess = LastSuccess (Just now) - } +addPeerInfo :: NetworkId -> PeerMark -> PeerInfo -> UTCTime -> PeerSet -> PeerSet +addPeerInfo nid mark pinf now = addPeerEntry $ + (newPeerEntry nid mark pinf) + { _peerEntryLastSuccess = LastSuccess (Just now) + } -- | Delete a peer, identified by its host address, from the 'PeerSet'. The peer -- is delete for all network ids. @@ -294,8 +312,10 @@ deletePeer -> PeerSet -> PeerSet deletePeer i True s = deleteIx (_peerAddr i) s -deletePeer i False s = case _peerEntrySticky <$> getOne (getEQ (_peerAddr i) s) of - Just (PeerEntrySticky True) -> s +deletePeer i False s = case getOne (getEQ (_peerAddr i) s) of + Just e + | PeerEntrySticky True <- e ^. peerEntrySticky + -> s _ -> deleteIx (_peerAddr i) s insertPeerEntryList :: [PeerEntry] -> PeerSet -> PeerSet @@ -347,11 +367,12 @@ peerDbInsert :: PeerDb -> NetworkId -> PeerInfo -> IO () peerDbInsert (PeerDb True _ _ _ _) _ _ = return () peerDbInsert (PeerDb _ _ _ lock var) nid i = do now <- getCurrentTime + mark <- randomPeerMark withMVar lock . const . atomically . modifyTVar' var - $ addPeerInfo nid i now + $ addPeerInfo nid mark i now {-# INLINE peerDbInsert #-} -- | Delete a peer, identified by its host address, from the peer database. @@ -397,11 +418,13 @@ prunePeerDb lg (PeerDb _ _ _ lock var) = do writeTVar var $! s IxSet.\\\ deletes return deletes unless (IxSet.null deletes) $ - lg @Text Info $ "Pruned peers: " <> sshow (_peerAddr . _peerEntryInfo <$> IxSet.toList deletes) + lg @Text Info + $ "Pruned peers: " + <> sshow (_peerAddr . _peerEntryInfo <$> IxSet.toList deletes) peerDbInsertList :: [PeerEntry] -> PeerDb -> IO () peerDbInsertList _ (PeerDb True _ _ _ _) = return () -peerDbInsertList peers (PeerDb _ _ _ lock var) = +peerDbInsertList peers (PeerDb _ _ _ lock var) = do withMVar lock . const . atomically @@ -412,14 +435,21 @@ peerDbInsertPeerInfoList :: NetworkId -> [PeerInfo] -> PeerDb -> IO () peerDbInsertPeerInfoList _ _ (PeerDb True _ _ _ _) = return () peerDbInsertPeerInfoList nid ps db = do now <- getCurrentTime - peerDbInsertList (mkEntry now <$> ps) db + entries <- traverse (mkEntry now) ps + peerDbInsertList entries db where - mkEntry now x = newPeerEntry nid x - & set peerEntryLastSuccess (LastSuccess (Just now)) + mkEntry now x = do + mark <- randomPeerMark + return $ newPeerEntry nid mark x + & set peerEntryLastSuccess (LastSuccess (Just now)) peerDbInsertPeerInfoList_ :: Bool -> NetworkId -> [PeerInfo] -> PeerDb -> IO () peerDbInsertPeerInfoList_ _ _ _ (PeerDb True _ _ _ _) = return () -peerDbInsertPeerInfoList_ sticky nid ps db = peerDbInsertList (newPeerEntry_ sticky nid <$> ps) db +peerDbInsertPeerInfoList_ sticky nid peerInfos db = do + newEntries <- forM peerInfos $ \info -> do + mark <- randomPeerMark + return $! newPeerEntry_ sticky nid mark info + peerDbInsertList newEntries db peerDbInsertSet :: S.Set PeerEntry -> PeerDb -> IO () peerDbInsertSet _ (PeerDb True _ _ _ _) = return () @@ -436,7 +466,9 @@ updatePeerDb (PeerDb _ _ _ lock var) a f = withMVar lock . const . atomically . modifyTVar' var $ \s -> case getOne $ getEQ a s of Nothing -> s - Just x -> updateIx a (f x) s + Just x -> + let !x' = f x + in updateIx a x' s incrementActiveSessionCount :: PeerDb -> PeerInfo -> IO () incrementActiveSessionCount db i diff --git a/test/lib/Chainweb/Test/Orphans/Internal.hs b/test/lib/Chainweb/Test/Orphans/Internal.hs index c9a160cb7..41b6afd21 100644 --- a/test/lib/Chainweb/Test/Orphans/Internal.hs +++ b/test/lib/Chainweb/Test/Orphans/Internal.hs @@ -241,7 +241,7 @@ instance Arbitrary P2pConfiguration where instance Arbitrary PeerEntry where arbitrary = PeerEntry <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary - <*> arbitrary + <*> arbitrary <*> arbitrary instance Arbitrary HostAddressIdx where arbitrary = hostAddressIdx <$> arbitrary @@ -251,6 +251,7 @@ deriving newtype instance Arbitrary SuccessiveFailures deriving newtype instance Arbitrary AddedTime deriving newtype instance Arbitrary ActiveSessionCount deriving newtype instance Arbitrary PeerEntrySticky +deriving newtype instance Arbitrary PeerMark deriving via (NonEmptyList Int) instance Arbitrary NodeVersion instance Arbitrary X509KeyPem where From 0cf12a2975d2b82bd26473d5ddf2dca014c4f5c7 Mon Sep 17 00:00:00 2001 From: chessai Date: Fri, 15 Nov 2024 14:43:02 -0600 Subject: [PATCH 2/9] make cwtool its own component; split all executables into their own. Change-Id: Ib1ee24d78c2b09e7687285e1b229e1996a214afa --- .github/workflows/applications.yml | 27 +- .github/workflows/macos.yaml | 19 +- cabal.project | 4 + chainweb.cabal | 143 +------- cwtools/LICENSE | 29 ++ cwtools/README.md | 4 + .../calculate-release/Main.hs | 3 +- {compact => cwtools/compact}/Main.hs | 0 cwtools/cwtools.cabal | 337 +++++++++++++++++ .../db-checksum/Main.hs | 69 ++-- .../db-checksum/db-checksum-config.yaml | 0 {tools => cwtools}/ea/Ea.hs | 0 {tools => cwtools}/ea/Ea/Genesis.hs | 0 .../encode-decode/Main.hs | 17 +- .../GenConf.hs => cwtools/genconf/Main.hs | 58 +-- .../header-dump/Main.hs | 131 ++----- .../known-graphs/Main.hs | 21 +- {pact-diff => cwtools/pact-diff}/Main.hs | 0 .../RunNodes.hs => cwtools/run-nodes/Main.hs | 18 +- .../run-nodes/test-bootstrap-node.config | 0 .../TxStream.hs => cwtools/txstream/Main.hs | 79 ++-- default.nix | 16 +- tools/cwtool/CwTool.hs | 135 ------- tools/cwtool/TxSimulator.hs | 342 ------------------ 24 files changed, 556 insertions(+), 896 deletions(-) create mode 100644 cwtools/LICENSE create mode 100644 cwtools/README.md rename tools/calculate-release/CalculateRelease.hs => cwtools/calculate-release/Main.hs (97%) rename {compact => cwtools/compact}/Main.hs (100%) create mode 100644 cwtools/cwtools.cabal rename tools/db-checksum/CheckpointerDBChecksum.hs => cwtools/db-checksum/Main.hs (91%) rename {tools => cwtools}/db-checksum/db-checksum-config.yaml (100%) rename {tools => cwtools}/ea/Ea.hs (100%) rename {tools => cwtools}/ea/Ea/Genesis.hs (100%) rename tools/encode-decode/EncodeDecodeB64Util.hs => cwtools/encode-decode/Main.hs (90%) rename tools/genconf/GenConf.hs => cwtools/genconf/Main.hs (73%) rename tools/header-dump/HeaderDump.hs => cwtools/header-dump/Main.hs (93%) rename tools/known-graphs/KnownGraphs.hs => cwtools/known-graphs/Main.hs (83%) rename {pact-diff => cwtools/pact-diff}/Main.hs (100%) rename tools/run-nodes/RunNodes.hs => cwtools/run-nodes/Main.hs (96%) rename {tools => cwtools}/run-nodes/test-bootstrap-node.config (100%) rename tools/txstream/TxStream.hs => cwtools/txstream/Main.hs (94%) delete mode 100644 tools/cwtool/CwTool.hs delete mode 100644 tools/cwtool/TxSimulator.hs diff --git a/.github/workflows/applications.yml b/.github/workflows/applications.yml index 5877e4e6f..f21d9fed3 100644 --- a/.github/workflows/applications.yml +++ b/.github/workflows/applications.yml @@ -361,13 +361,22 @@ jobs: - name: Build chainweb applications run: | cabal build -j2 --ghc-options=-j2 \ + chainweb:bench:bench \ + exe:b64 \ + exe:calculate-release \ exe:compact \ + exe:db-checksum \ + exe:ea \ + exe:genconf \ + exe:header-dump \ + exe:known-graphs \ + exe:pact-diff \ + exe:run-nodes \ + exe:tx-list \ test:chainweb-tests \ - test:multi-node-network-tests \ test:compaction-tests \ - test:remote-tests \ - exe:cwtool \ - chainweb:bench:bench + test:multi-node-network-tests \ + test:remote-tests - name: Build chainweb-node application run: cabal build -j2 --ghc-options=-j2 chainweb-node:exe:chainweb-node @@ -390,15 +399,23 @@ 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 calculate-release) artifacts/chainweb cp $(cabal list-bin chainweb-node) artifacts/chainweb cp $(cabal list-bin chainweb-tests) artifacts/chainweb cp $(cabal list-bin compact) artifacts/chainweb cp $(cabal list-bin compaction-tests) artifacts/chainweb - cp $(cabal list-bin cwtool) 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 tx-list) artifacts/chainweb cp README.md artifacts/chainweb cp CHANGELOG.md artifacts/chainweb cp LICENSE artifacts/chainweb diff --git a/.github/workflows/macos.yaml b/.github/workflows/macos.yaml index 439bf388f..b3c182978 100644 --- a/.github/workflows/macos.yaml +++ b/.github/workflows/macos.yaml @@ -116,15 +116,24 @@ jobs: - name: Build chainweb library run: cabal build lib:chainweb - name: Build chainweb applications - run: | + run: | cabal build -j \ + chainweb:bench:bench \ + exe:b64 \ + exe:calculate-release \ exe:compact \ + exe:db-checksum \ + exe:ea \ + exe:genconf \ + exe:header-dump \ + exe:known-graphs \ + exe:pact-diff \ + exe:run-nodes \ + exe:tx-list \ test:chainweb-tests \ - test:multi-node-network-tests \ test:compaction-tests \ - test:remote-tests \ - exe:cwtool \ - chainweb:bench:bench + test:multi-node-network-tests \ + test:remote-tests - name: Build chainweb-node application run: cabal build -j chainweb-node:exe:chainweb-node - uses: actions/cache/save@v4 diff --git a/cabal.project b/cabal.project index 0da734cb8..e20b71ced 100644 --- a/cabal.project +++ b/cabal.project @@ -1,6 +1,7 @@ packages: chainweb.cabal node/chainweb-node.cabal + cwtools/cwtools.cabal debug-info: True @@ -40,6 +41,9 @@ package chainweb package chainweb-node ghc-options: -Wno-missed-extra-shared-lib +package cwtools + ghc-options: -Wno-missed-extra-shared-lib + if impl(ghc >= 9.8.1) package chainweb ghc-options: -Wno-x-partial diff --git a/chainweb.cabal b/chainweb.cabal index e829d34b6..d711aa6a6 100644 --- a/chainweb.cabal +++ b/chainweb.cabal @@ -467,6 +467,7 @@ library library chainweb-test-utils import: warning-flags, debugging-flags default-language: Haskell2010 + visibility: public ghc-options: -Wno-x-partial -Wno-unrecognised-warning-flags hs-source-dirs: test/lib @@ -798,148 +799,6 @@ test-suite remote-tests if flag(ed25519) cpp-options: -DWITH_ED25519=1 --- -------------------------------------------------------------------------- -- --- Misc Applications --- -------------------------------------------------------------------------- -- - -executable ea - import: warning-flags, debugging-flags - default-language: Haskell2010 - ghc-options: - -threaded - -rtsopts - "-with-rtsopts=-N -H1G -A64M" - -Wno-x-partial -Wno-unrecognised-warning-flags - hs-source-dirs: - tools/ea - main-is: - Ea.hs - other-modules: - Ea.Genesis - build-depends: - , chainweb - , chainweb:chainweb-test-utils - - , base - , chainweb-storage - , lens - , loglevel - , pact - , temporary - , text - , vector - -executable cwtool - import: warning-flags, debugging-flags - default-language: Haskell2010 - ghc-options: - -threaded - -rtsopts - "-with-rtsopts=-N -H1G -A64M" - -Wno-x-partial -Wno-unrecognised-warning-flags - hs-source-dirs: - tools/cwtool - tools/encode-decode - tools/genconf - tools/run-nodes - tools/txstream - tools/header-dump - tools/db-checksum - tools/known-graphs - tools/calculate-release - main-is: CwTool.hs - other-modules: - CheckpointerDBChecksum - EncodeDecodeB64Util - GenConf - HeaderDump - KnownGraphs - RunNodes - TxStream - TxSimulator - CalculateRelease - - build-depends: - -- internal - , chainweb - , chainweb:chainweb-test-utils - - -- external - , aeson >= 2.2 - , aeson-pretty >= 0.8 - , async >= 2.2 - , base >= 4.12 && < 5 - , bytestring >= 0.10.12 - , case-insensitive >= 1.2 - , cereal >= 0.5 - , chainweb-storage >= 0.1 - , configuration-tools >= 0.6 - , containers >= 0.5 - , crypton >= 0.31 - , crypton-connection >=0.4 - , digraph >= 0.2.3 - , direct-sqlite >= 2.3.27 - , directory >= 1.3 - , exceptions >= 0.8 - , http-client >= 0.5 - , http-client-tls >=0.3 - , lens >= 4.17 - , lens-aeson >= 1.2.2 - , loglevel >= 0.1 - , memory >=0.14 - , mtl >= 2.3 - , optparse-applicative >= 0.14 - , pact - , pact-json - , process >= 1.5 - , rocksdb-haskell-kadena >= 1.1.0 - , safe-exceptions >= 0.1 - , servant-client >= 0.18.2 - , servant-client-core >= 0.18.2 - , streaming >= 0.2.2 - , text >= 2.0 - , time >= 1.12.2 - , unordered-containers >= 0.2.16 - , vector >= 0.12.2 - , wreq >= 0.5 - , yaml >= 0.8 - , yet-another-logger >= 0.4.1 - - if flag(ed25519) - cpp-options: -DWITH_ED25519=1 - -executable compact - import: warning-flags, debugging-flags - default-language: Haskell2010 - ghc-options: - -threaded - -rtsopts - "-with-rtsopts=-N -A4M --disable-delayed-os-memory-return -qn1" - hs-source-dirs: compact - main-is: Main.hs - build-depends: - -- internal - , chainweb - - -- external - , base >= 4.12 && < 5 - -executable pact-diff - import: warning-flags, debugging-flags - default-language: Haskell2010 - ghc-options: - -threaded - -rtsopts - "-with-rtsopts=-N -A4M --disable-delayed-os-memory-return -qn1" - hs-source-dirs: pact-diff - main-is: Main.hs - build-depends: - -- internal - , chainweb - - -- external - , base >= 4.12 && < 5 - -- -------------------------------------------------------------------------- -- -- Benchmarks -- -------------------------------------------------------------------------- -- diff --git a/cwtools/LICENSE b/cwtools/LICENSE new file mode 100644 index 000000000..047dc735f --- /dev/null +++ b/cwtools/LICENSE @@ -0,0 +1,29 @@ +Copyright (c) 2018 - 2024 Kadena LLC +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: + +1. Redistributions of source code must retain the above copyright +notice, this list of conditions and the following disclaimer. + +2. Redistributions in binary form must reproduce the above copyright +notice, this list of conditions and the following disclaimer in the +documentation and/or other materials provided with the distribution. + +3. Neither the name of the copyright holder nor the names of its +contributors may be used to endorse or promote products derived from +this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/cwtools/README.md b/cwtools/README.md new file mode 100644 index 000000000..bd78b6245 --- /dev/null +++ b/cwtools/README.md @@ -0,0 +1,4 @@ +# Chainweb Tooling + +For details please see the documentation of the +[chainweb project](https://github.com/kadena-io/chainweb-node/README.md). diff --git a/tools/calculate-release/CalculateRelease.hs b/cwtools/calculate-release/Main.hs similarity index 97% rename from tools/calculate-release/CalculateRelease.hs rename to cwtools/calculate-release/Main.hs index 2a8f42e0a..f93879c55 100644 --- a/tools/calculate-release/CalculateRelease.hs +++ b/cwtools/calculate-release/Main.hs @@ -1,10 +1,9 @@ {-# LANGUAGE BangPatterns #-} -{-# LANGUAGE ImportQualifiedPost #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} -module CalculateRelease(main) where +module Main (main) where import Chainweb.BlockHeight import Chainweb.Version (ChainwebVersion(..)) diff --git a/compact/Main.hs b/cwtools/compact/Main.hs similarity index 100% rename from compact/Main.hs rename to cwtools/compact/Main.hs diff --git a/cwtools/cwtools.cabal b/cwtools/cwtools.cabal new file mode 100644 index 000000000..346bb3540 --- /dev/null +++ b/cwtools/cwtools.cabal @@ -0,0 +1,337 @@ +cabal-version: 3.8 + +name: cwtools +version: 2.26 +synopsis: A collection of various tools for Chainweb users and developers. +description: A collection of various tools for Chainweb users and developers. +homepage: https://github.com/kadena-io/chainweb +bug-reports: https://github.com/kadena-io/chainweb/issues +license: BSD-3-Clause +license-file: LICENSE +author: Chainweb Dev Team +maintainer: chainweb-dev@kadena.io +copyright: Copyright (C) 2018 - 2024 Kadena LLC +category: Blockchain, Currency, Bitcoin, Kadena +build-type: Simple + +tested-with: + GHC == 9.10 + GHC == 9.8 + GHC == 9.6 + +extra-source-files: + README.md + LICENSE + +source-repository head + type: git + location: https://github.com/kadena-io/chainweb-node.git + +flag ed25519 + description: + Use ED25519 certificates; depends on the master branch of the tls + package. + default: False + manual: True + +flag debug + description: + Enable various debugging features + default: False + manual: True + +flag ghc-flags + description: Enable ghc dumps of .ghc.flags and .ghc.version for tooling + default: False + manual: True + +flag remote-db + description: Enable header dumps of remote databases with the header-dump tool + default: False + manual: True + +common debugging-flags + if flag(debug) + ghc-options: + -g + cpp-options: + -DDEBUG_MULTINODE_TEST=1 + +common warning-flags + ghc-options: + -Wall + -Werror + -Wcompat + -Wpartial-fields + -Wincomplete-record-updates + -Wincomplete-uni-patterns + -Widentities + -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 + ghc-options: + -threaded + -rtsopts + "-with-rtsopts=-N -H1G -A64M" + hs-source-dirs: encode-decode + main-is: Main.hs + build-depends: + -- internal + , chainweb + + -- external + , base + , bytestring + , optparse-applicative + , text + +executable calculate-release + import: warning-flags, debugging-flags + default-language: Haskell2010 + ghc-options: + -threaded + hs-source-dirs: calculate-release + main-is: Main.hs + build-depends: + -- internal + , chainweb + + -- external + , base >= 4.12 && < 5 + , lens + , lens-aeson + , time + , wreq + +-- Compact pact state and RocksDB. +executable compact + import: warning-flags, debugging-flags + default-language: Haskell2010 + ghc-options: + -threaded + -rtsopts + "-with-rtsopts=-N -A4M --disable-delayed-os-memory-return -qn1" + hs-source-dirs: compact + main-is: Main.hs + build-depends: + -- internal + , chainweb + + -- external + , base >= 4.12 && < 5 + +executable db-checksum + import: warning-flags, debugging-flags + default-language: Haskell2010 + ghc-options: + -threaded + -rtsopts + "-with-rtsopts=-N -H1G -A64M" + hs-source-dirs: db-checksum + main-is: Main.hs + build-depends: + -- internal + , chainweb + + -- external + , base + , bytestring + , cereal >= 0.5 + , configuration-tools + , containers + , crypton + , direct-sqlite + , directory + , memory + , mtl + , pact + , safe-exceptions + , text + , unordered-containers + +-- Generate genesis headers. +executable ea + import: warning-flags, debugging-flags + default-language: Haskell2010 + ghc-options: + -threaded + -rtsopts + "-with-rtsopts=-N -H1G -A64M" + -Wno-x-partial -Wno-unrecognised-warning-flags + hs-source-dirs: + ea + main-is: + Ea.hs + other-modules: + Ea.Genesis + build-depends: + , chainweb + , chainweb:chainweb-test-utils + + , base + , chainweb-storage + , lens + , loglevel + , pact + , temporary + , text + , vector + +executable genconf + import: warning-flags, debugging-flags + default-language: Haskell2010 + ghc-options: + -threaded + -rtsopts + "-with-rtsopts=-N -H1G -A64M" + hs-source-dirs: genconf + main-is: Main.hs + build-depends: + -- internal + , chainweb + + -- external + , base + , directory + , lens + , process + , text + , yaml + +executable header-dump + import: warning-flags, debugging-flags + default-language: Haskell2010 + ghc-options: + -threaded + -rtsopts + "-with-rtsopts=-N -H1G -A64M" + hs-source-dirs: header-dump + main-is: Main.hs + if flag(remote-db) + cpp-options: + -DREMOTE_DB=1 + build-depends: + , http-client + , http-client-tls + , servant-client + build-depends: + -- internal + , chainweb + , chainweb-storage + + -- external + , aeson-pretty + , base + , bytestring + , case-insensitive + , configuration-tools + , directory + , exceptions + , lens + , lens-aeson + , loglevel + , mtl + , pact + , pact-json + , rocksdb-haskell-kadena + , streaming + , text + , unordered-containers + , vector + , yet-another-logger + +executable known-graphs + import: warning-flags, debugging-flags + default-language: Haskell2010 + ghc-options: + -threaded + hs-source-dirs: known-graphs + main-is: Main.hs + build-depends: + -- internal + , chainweb + + -- external + , aeson + , base + , bytestring + , digraph + , lens + , text + +-- Diff pact state between two DBs. +executable pact-diff + import: warning-flags, debugging-flags + default-language: Haskell2010 + ghc-options: + -threaded + -rtsopts + "-with-rtsopts=-N -A4M --disable-delayed-os-memory-return -qn1" + hs-source-dirs: pact-diff + main-is: Main.hs + build-depends: + -- internal + , chainweb + + -- external + , base >= 4.12 && < 5 + +executable run-nodes + import: warning-flags, debugging-flags + default-language: Haskell2010 + ghc-options: + -threaded + -rtsopts + "-with-rtsopts=-N -H1G -A64M" + hs-source-dirs: run-nodes + main-is: Main.hs + build-depends: + -- internal + , chainweb + , chainweb:chainweb-test-utils + + -- external + , async + , base + , directory + , optparse-applicative + , process + , text + +executable tx-list + import: warning-flags, debugging-flags + default-language: Haskell2010 + ghc-options: + -threaded + -rtsopts + "-with-rtsopts=-N -H1G -A64M" + hs-source-dirs: txstream + main-is: Main.hs + build-depends: + -- internal + , chainweb + + -- external + , aeson-pretty + , base + , bytestring + , configuration-tools + , http-client + , http-client-tls + , lens + , loglevel + , mtl + , pact + , pact-json + , servant-client + , streaming + , text + , unordered-containers + , yet-another-logger diff --git a/tools/db-checksum/CheckpointerDBChecksum.hs b/cwtools/db-checksum/Main.hs similarity index 91% rename from tools/db-checksum/CheckpointerDBChecksum.hs rename to cwtools/db-checksum/Main.hs index 16844ccab..c4b83416c 100644 --- a/tools/db-checksum/CheckpointerDBChecksum.hs +++ b/cwtools/db-checksum/Main.hs @@ -3,6 +3,7 @@ {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE ImportQualifiedPost #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE StandaloneDeriving #-} @@ -10,64 +11,53 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} -module CheckpointerDBChecksum where +module Main (main) where +import Chainweb.BlockHeight +import Chainweb.Pact.Backend.Types +import Chainweb.Pact.Backend.Utils hiding (callDb) +import Chainweb.Pact.Service.Types +import Chainweb.Utils hiding (check) import Configuration.Utils hiding (Error, Lens', action, encode) - import Control.Exception.Safe (tryAny) import Control.Monad (foldM, when, void) import Control.Monad.Reader - import Crypto.Hash - import Data.ByteArray (convert) -import qualified Data.ByteString as B (ByteString, writeFile) +import Data.ByteString qualified as B (ByteString, writeFile) import Data.ByteString.Builder -import qualified Data.HashSet as HashSet +import Data.HashSet qualified as HashSet import Data.Int import Data.Map (Map) -import qualified Data.Map as M +import Data.Map qualified as M import Data.Monoid import Data.Serialize -import qualified Data.Text as T -import qualified Data.Text.Encoding as T - -import Database.SQLite3.Direct as SQ3 - +import Data.Text qualified as T +import Data.Text.Encoding qualified as T +import Database.SQLite3.Direct (Database, Utf8(..)) import GHC.Generics - +import Pact.Types.SQLite import System.Directory - import Text.Printf --- pact imports -import Pact.Types.SQLite - --- chainweb imports -import Chainweb.BlockHeight -import Chainweb.Pact.Backend.Types -import Chainweb.Pact.Backend.Utils hiding (callDb) -import Chainweb.Pact.Service.Types -import Chainweb.Utils hiding (check) - main :: IO () main = runWithConfiguration mainInfo $ \args -> do (entiredb, tables) <- work args - case _getAllTables args of - True -> do - putStrLn "----------Computing \"entire\" db----------" - let !checksum = convert @(Digest SHA1) @B.ByteString . hashlazy $ toLazyByteString entiredb - exists <- doesFileExist $ _entireDBOutputFile args - -- Just rewrite the file. Let's not do anything complicated here. - when exists $ removeFile $ _entireDBOutputFile args - B.writeFile (_entireDBOutputFile args) checksum - False -> do - putStrLn "----------Computing tables----------" - let dir = _tablesOutputLocation args - createDirectoryIfMissing True dir - files <- listDirectory dir - mapM_ (\file -> removeFile (dir <> "/" <> file)) files - void $ M.traverseWithKey (go (_tablesOutputLocation args)) tables + if _getAllTables args + then do + putStrLn "----------Computing \"entire\" db----------" + let !checksum = convert @(Digest SHA1) @B.ByteString . hashlazy $ toLazyByteString entiredb + exists <- doesFileExist $ _entireDBOutputFile args + -- Just rewrite the file. Let's not do anything complicated here. + when exists $ removeFile $ _entireDBOutputFile args + B.writeFile (_entireDBOutputFile args) checksum + else do + putStrLn "----------Computing tables----------" + let dir = _tablesOutputLocation args + createDirectoryIfMissing True dir + files <- listDirectory dir + mapM_ (\file -> removeFile (dir <> "/" <> file)) files + void $ M.traverseWithKey (go (_tablesOutputLocation args)) tables putStrLn "----------All done----------" where go :: String -> B.ByteString -> B.ByteString -> IO () @@ -329,5 +319,4 @@ deriving instance Generic SType deriving instance Serialize SType deriving instance Generic Utf8 deriving instance Serialize Utf8 - deriving instance Read BlockHeight diff --git a/tools/db-checksum/db-checksum-config.yaml b/cwtools/db-checksum/db-checksum-config.yaml similarity index 100% rename from tools/db-checksum/db-checksum-config.yaml rename to cwtools/db-checksum/db-checksum-config.yaml diff --git a/tools/ea/Ea.hs b/cwtools/ea/Ea.hs similarity index 100% rename from tools/ea/Ea.hs rename to cwtools/ea/Ea.hs diff --git a/tools/ea/Ea/Genesis.hs b/cwtools/ea/Ea/Genesis.hs similarity index 100% rename from tools/ea/Ea/Genesis.hs rename to cwtools/ea/Ea/Genesis.hs diff --git a/tools/encode-decode/EncodeDecodeB64Util.hs b/cwtools/encode-decode/Main.hs similarity index 90% rename from tools/encode-decode/EncodeDecodeB64Util.hs rename to cwtools/encode-decode/Main.hs index 7df98fb5e..6f8d5fd14 100644 --- a/tools/encode-decode/EncodeDecodeB64Util.hs +++ b/cwtools/encode-decode/Main.hs @@ -1,21 +1,16 @@ +{-# LANGUAGE ImportQualifiedPost #-} {-# LANGUAGE LambdaCase #-} -module EncodeDecodeB64Util where +module Main (main) where +import Chainweb.Utils import Control.Monad - import Data.ByteString (ByteString) -import qualified Data.ByteString.Char8 as B - -import qualified Data.Text as T import Data.Text (Text) -import qualified Data.Text.IO as T - import Options.Applicative - --- internal imports - -import Chainweb.Utils +import Data.ByteString.Char8 qualified as B +import Data.Text qualified as T +import Data.Text.IO qualified as T main :: IO () main = execParser opts >>= \case diff --git a/tools/genconf/GenConf.hs b/cwtools/genconf/Main.hs similarity index 73% rename from tools/genconf/GenConf.hs rename to cwtools/genconf/Main.hs index 9422f425b..9b5ae6277 100644 --- a/tools/genconf/GenConf.hs +++ b/cwtools/genconf/Main.hs @@ -1,32 +1,27 @@ {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE ImportQualifiedPost #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeApplications #-} -module GenConf where +module Main (main) where +import Chainweb.Chainweb.Configuration +import Chainweb.HostAddress +import Chainweb.Miner.Config +import Chainweb.Version.Mainnet import Control.Lens - import Data.Maybe import Data.Text (Text) -import qualified Data.Text as T -import qualified Data.Text.IO as T -import qualified Data.Yaml as Y - +import Data.Text qualified as T +import Data.Text.IO qualified as T +import Data.Yaml qualified as Y +import P2P.Node.Configuration +import P2P.Peer import System.Directory import System.Exit import System.IO import System.Process --- chainweb imports -import Chainweb.Chainweb -import Chainweb.Chainweb.Configuration -import Chainweb.HostAddress -import Chainweb.Miner.Config -import Chainweb.Version.Mainnet - -import P2P.Node.Configuration -import P2P.Peer - -- three items to ask the user -- 1) ask for their hostname (or public ip address) -- 2) ask for a usable port number (test to see if this is actually open) @@ -61,9 +56,6 @@ getUserInput prompt defaultVal parse safetyCheck = do getUserInput prompt defaultVal parse safetyCheck Right y' -> return y' -validate :: (a -> Bool) -> String -> Maybe (a -> Either String a) -validate f msg = Just $ \a -> if f a then Right a else Left msg - getConf :: IO ChainwebConfiguration getConf = do ip <- getIP @@ -80,24 +72,17 @@ getConf = do portMsg = "Which port would you like to use (default: 443)?" mineCoordMsg = "Would you like to turn mining coordination (default: yes)?" --- This was not exported by the Chainweb.Chainweb module -defaultThrottlingConfig :: ThrottlingConfig -defaultThrottlingConfig = ThrottlingConfig - { _throttlingRate = 50 -- per second - , _throttlingPeerRate = 11 -- per second, one each 2 seconds for each p2p network - , _throttlingMempoolRate = 5 -- per second, one each 4 seconds for each mempool - } - main :: IO () main = do conf <- getConf exist <- doesFileExist defaultfile - case exist of - True -> - getUserInput msg (Just True) (return . yesorno2Bool) Nothing >>= \case - True -> writeStuff conf - False -> putStrLn "Not writing configuration file" - False -> writeStuff conf + if exist + then do + getUserInput msg (Just True) (return . yesorno2Bool) Nothing >>= \case + True -> writeStuff conf + False -> putStrLn "Not writing configuration file" + else do + writeStuff conf exitSuccess where msg = "Would you like to write the configuration to " <> defaultfile <> "?" @@ -113,12 +98,5 @@ yesorno2Bool text = "no" -> Just False _ -> Nothing -checkIP :: Text -> IO (Maybe Hostname) -checkIP ip = do - value <- getIP - if value == ip - then return $ hostnameFromText ip - else return Nothing - getIP :: IO Text getIP = T.pack . (read @String) <$> readProcess "dig" (words "TXT +short o-o.myaddr.l.google.com @ns1.google.com") "" diff --git a/tools/header-dump/HeaderDump.hs b/cwtools/header-dump/Main.hs similarity index 93% rename from tools/header-dump/HeaderDump.hs rename to cwtools/header-dump/Main.hs index 6909d1898..3a23e6943 100644 --- a/tools/header-dump/HeaderDump.hs +++ b/cwtools/header-dump/Main.hs @@ -1,13 +1,12 @@ {-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveFoldable #-} -{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} +{-# LANGUAGE ImportQualifiedPost #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} @@ -23,111 +22,70 @@ -- Maintainer: Lars Kuhtz -- Stability: experimental -- -module HeaderDump -( main -, run -, mainWithConfig - --- * Configuration -, Output(..) -, Config(..) -, defaultConfig - --- * ChainData -, ChainData(..) -, cdChainId -, cdHeight -, cdData - --- * Tools -, progress -, miner -, coinbaseOutput -, coinbaseResult -, pactResult -, failures -, transactionsWithOutputs -, commandValue -, commandWithOutputsValue -, withChainDbs -) where +module Main (main) where +import Chainweb.BlockHash +import Chainweb.BlockHeader +import Chainweb.BlockHeader.Validation +import Chainweb.BlockHeaderDB +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.Storage.Table.RocksDB +import Chainweb.Time +import Chainweb.TreeDB hiding (key) +import Chainweb.Utils hiding (progress) +import Chainweb.Version +import Chainweb.Version.RecapDevelopment +import Chainweb.Version.Registry import Configuration.Utils hiding (Lens) import Configuration.Utils.Validation - import Control.Exception import Control.Lens hiding ((.=)) import Control.Monad import Control.Monad.Catch (MonadThrow, throwM) import Control.Monad.Except import Control.Monad.IO.Class - import Data.Aeson.Encode.Pretty hiding (Config) import Data.Aeson.Lens import Data.Bitraversable -import qualified Data.ByteString.Lazy as BL -import qualified Data.CaseInsensitive as CI +import Data.ByteString.Lazy qualified as BL +import Data.CaseInsensitive qualified as CI import Data.Foldable import Data.Functor.Of -import qualified Data.HashSet as HS +import Data.HashSet qualified as HS import Data.LogMessage import Data.Maybe import Data.Semigroup -import qualified Data.Text as T -import qualified Data.Text.Encoding as T -import qualified Data.Text.IO as T -import qualified Data.Vector as V - -import qualified Database.RocksDB.Base as R - +import Data.Text qualified as T +import Data.Text.Encoding qualified as T +import Data.Text.IO qualified as T +import Data.Vector qualified as V +import Database.RocksDB.Base qualified as R import GHC.Generics hiding (to) - import Numeric.Natural - -import qualified Streaming.Prelude as S - -import System.Directory -import qualified System.Logger as Y -import System.LogLevel - --- internal modules - -import Chainweb.BlockHash -import Chainweb.BlockHeader -import Chainweb.BlockHeader.Validation -import Chainweb.BlockHeight -import Chainweb.BlockHeaderDB -import Chainweb.ChainValue -import Chainweb.Logger -import Chainweb.Miner.Pact -import Chainweb.Payload -import Chainweb.Payload.PayloadStore -import Chainweb.Payload.PayloadStore.RocksDB -import Chainweb.Time -import Chainweb.TreeDB hiding (key) -import Chainweb.Utils hiding (progress) -import Chainweb.Version -import Chainweb.Version.RecapDevelopment -import Chainweb.Version.Registry - -import Chainweb.Storage.Table.RocksDB - -import qualified Pact.JSON.Encode as J +import Pact.JSON.Encode qualified as J import Pact.Types.Command import Pact.Types.PactError +import Streaming.Prelude qualified as S +import System.Directory +import System.LogLevel +import System.Logger qualified as Y -- -------------------------------------------------------------------------- -- #define REMOTE_DB 0 #if REMOTE_DB +import Chainweb.BlockHeaderDB.RemoteDB +import Chainweb.HostAddress import Network.HTTP.Client import Network.HTTP.Client.TLS - import Servant.Client - -import Chainweb.HostAddress -import Chainweb.BlockHeaderDB.RemoteDB #endif -- -------------------------------------------------------------------------- -- @@ -330,7 +288,7 @@ data ChainData a = ChainData } deriving (Show, Eq, Ord, Functor, Foldable, Traversable) -makeLenses ''ChainData +makeLensesFor [("_cdData", "cdData")] ''ChainData instance ToJSON a => ToJSON (ChainData a) where toJSON o = object @@ -569,13 +527,6 @@ coinbaseResult coinbaseResult l = S.mapM $ l (decodeStrictOrThrow' . _coinbaseOutput . _payloadWithOutputsCoinbase) -pactResult - :: Monad m - => Traversal a b (CommandResult T.Text) PactResult - -> S.Stream (Of a) m r - -> S.Stream (Of b) m r -pactResult l = S.map $ over l _crResult - failures :: Monad m => Traversal a b (CommandResult T.Text) (Maybe PactError) @@ -612,16 +563,6 @@ commandWithOutputsValue (c, o) = object , "output" .= J.toJsonViaEncode o ] -commandValue :: Command T.Text -> Value -commandValue c = object - [ "sigs" .= fmap J.toJsonViaEncode (_cmdSigs c) - , "hash" .= J.toJsonViaEncode (_cmdHash c) - , "payload" .= either - (const $ String $ _cmdPayload c) - (id @Value) - (eitherDecodeStrict' $ T.encodeUtf8 $ _cmdPayload c) - ] - -- -------------------------------------------------------------------------- -- -- Streaming Tools diff --git a/tools/known-graphs/KnownGraphs.hs b/cwtools/known-graphs/Main.hs similarity index 83% rename from tools/known-graphs/KnownGraphs.hs rename to cwtools/known-graphs/Main.hs index cf324d836..df8b8559f 100644 --- a/tools/known-graphs/KnownGraphs.hs +++ b/cwtools/known-graphs/Main.hs @@ -1,4 +1,6 @@ +{-# LANGUAGE ImportQualifiedPost #-} {-# LANGUAGE OverloadedStrings #-} + {-# OPTIONS_GHC -fno-warn-orphans #-} -- | @@ -8,24 +10,17 @@ -- Maintainer: Lars Kuhtz -- Stability: experimental -- -module KnownGraphs -( main -) where +module Main (main) where +import Chainweb.Graph +import Chainweb.Utils import Control.Lens hiding ((.=)) - import Data.Aeson -import qualified Data.ByteString.Lazy.Char8 as BL8 -import qualified Data.DiGraph as G -import qualified Data.Text as T - +import Data.ByteString.Lazy.Char8 qualified as BL8 +import Data.DiGraph qualified as G +import Data.Text qualified as T import System.Environment --- internal modules - -import Chainweb.Graph -import Chainweb.Utils - main :: IO () main = do args <- getArgs diff --git a/pact-diff/Main.hs b/cwtools/pact-diff/Main.hs similarity index 100% rename from pact-diff/Main.hs rename to cwtools/pact-diff/Main.hs diff --git a/tools/run-nodes/RunNodes.hs b/cwtools/run-nodes/Main.hs similarity index 96% rename from tools/run-nodes/RunNodes.hs rename to cwtools/run-nodes/Main.hs index 825225551..a85caf1a3 100644 --- a/tools/run-nodes/RunNodes.hs +++ b/cwtools/run-nodes/Main.hs @@ -1,31 +1,23 @@ +{-# LANGUAGE ImportQualifiedPost #-} {-# LANGUAGE MultiWayIf #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} -module RunNodes ( main, runNodesOpts ) where +module Main (main) where import Chainweb.Graph (petersonChainGraph) +import Chainweb.Test.TestVersions +import Chainweb.Utils import Chainweb.Version import Chainweb.Version.Registry - import Control.Concurrent import Control.Concurrent.Async import Control.Exception - -import qualified Data.Text as T import Data.Word - import Options.Applicative - import System.Directory (executable, getPermissions) import System.Process (callProcess) - --- internal modules - -import Chainweb.Test.TestVersions -import Chainweb.Utils - ---- +import Data.Text qualified as T data Env = Env { exe :: FilePath diff --git a/tools/run-nodes/test-bootstrap-node.config b/cwtools/run-nodes/test-bootstrap-node.config similarity index 100% rename from tools/run-nodes/test-bootstrap-node.config rename to cwtools/run-nodes/test-bootstrap-node.config diff --git a/tools/txstream/TxStream.hs b/cwtools/txstream/Main.hs similarity index 94% rename from tools/txstream/TxStream.hs rename to cwtools/txstream/Main.hs index 2fcac4faa..7c0d18ade 100644 --- a/tools/txstream/TxStream.hs +++ b/cwtools/txstream/Main.hs @@ -5,6 +5,7 @@ {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE ImportQualifiedPost #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} @@ -23,71 +24,45 @@ -- -- Print all transactions in a chain starting with the most recent block -- -module TxStream -( main -, mainWithConfig -, testLogfun -, run -, runOutputs -) where - -import Chainweb.Cut.CutHashes -import Chainweb.Payload.RestAPI.Client - -import Configuration.Utils - -import Control.Lens hiding ((.=)) -import Control.Monad ((<=<), when) -import Control.Monad.Reader - -import Data.Aeson.Encode.Pretty hiding (Config) -import Data.Bitraversable -import qualified Data.ByteString.Lazy as BL -import Data.Functor.Of -import qualified Data.HashMap.Strict as HM -import qualified Data.HashSet as HS -import qualified Data.Text as T -import qualified Data.Text.Encoding as T -import qualified Data.Text.IO as T - -import GHC.Generics - -import Network.HTTP.Client -import Network.HTTP.Client.TLS - -import Servant.Client - -import qualified Streaming.Prelude as S - -import qualified System.Logger as Y -import System.LogLevel - --- internal modules +module Main (main) where import Chainweb.BlockHeader +import Chainweb.BlockHeaderDB.RemoteDB import Chainweb.BlockHeight +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.TreeDB -import Chainweb.BlockHeaderDB.RemoteDB import Chainweb.Utils import Chainweb.Version import Chainweb.Version.RecapDevelopment import Chainweb.Version.Registry import Chainweb.Version.Utils - +import Configuration.Utils +import Control.Lens hiding ((.=)) +import Control.Monad ((<=<), when) +import Control.Monad.Reader +import Data.Aeson.Encode.Pretty hiding (Config) +import Data.Bitraversable +import Data.Functor.Of import Data.LogMessage - -import qualified Pact.JSON.Encode as J +import GHC.Generics +import Network.HTTP.Client +import Network.HTTP.Client.TLS import Pact.Types.Command - --- -------------------------------------------------------------------------- -- --- GHCI - -testLogfun :: LogFunction -testLogfun _ = T.putStrLn . logText +import Servant.Client +import System.LogLevel +import Data.ByteString.Lazy qualified as BL +import Data.HashMap.Strict qualified as HM +import Data.HashSet qualified as HS +import Data.Text qualified as T +import Data.Text.Encoding qualified as T +import Pact.JSON.Encode qualified as J +import Streaming.Prelude qualified as S +import System.Logger qualified as Y -- -------------------------------------------------------------------------- -- -- Configuration @@ -368,7 +343,9 @@ mainWithConfig config = withLog $ \logger -> do & addLabel ("host", toText $ _configNode config) & addLabel ("version", toText $ _versionName $ _configChainwebVersion config) & addLabel ("chain", toText $ _configChainId config) - liftIO $ if _configOutputs config + liftIO $ do + registerVersion (_configChainwebVersion config) + if _configOutputs config then runOutputs config logg else run config logg diff --git a/default.nix b/default.nix index f3a419a33..45fd36d48 100644 --- a/default.nix +++ b/default.nix @@ -112,8 +112,20 @@ let haskellSrc = with nix-filter.lib; filter { } { - name = "chainweb"; - exes = ["cwtool" "compact" "ea" "pact-diff"]; + name = "cwtools"; + exes = [ + "b64" + "calculate-release" + "compact" + "db-checksum" + "ea" + "genconf" + "header-dump" + "known-graphs" + "pact-diff" + "run-nodes" + "tx-list" + ]; } ]; diff --git a/tools/cwtool/CwTool.hs b/tools/cwtool/CwTool.hs deleted file mode 100644 index 61bd4f09a..000000000 --- a/tools/cwtool/CwTool.hs +++ /dev/null @@ -1,135 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -module Main where - -import Chainweb.Version.Development -import Chainweb.Version.RecapDevelopment -import Chainweb.Version.Registry - -import System.Environment -import System.Exit -import Text.Printf - -import Chainweb.Pact.Backend.Compaction (main) -import Chainweb.Pact.Backend.PactState.GrandHash.Calc (pactCalcMain) -import Chainweb.Pact.Backend.PactState.GrandHash.Import (pactImportMain) - -import qualified CheckpointerDBChecksum -import qualified EncodeDecodeB64Util -import qualified GenConf -import qualified HeaderDump -import qualified RunNodes -import qualified TxStream -import qualified KnownGraphs -import qualified TxSimulator -import qualified CalculateRelease - -main :: IO () -main = do - registerVersion RecapDevelopment - registerVersion Development - args <- getArgs - case args of - [] -> printHelp topLevelCommands - ["-h"] -> printHelp topLevelCommands - ["--help"] -> printHelp topLevelCommands - (cmd:restOfArgs) -> do - case filter (\cs -> cmd == csCmd cs) topLevelCommands of - [] -> do - printf "Error: \"%s\" is not a valid command\n\n" cmd - printHelp topLevelCommands - exitFailure - [cs] -> do - progName <- getProgName - withArgs restOfArgs $ withProgName (unwords [progName, cmd]) $ csAction cs - _ -> error "Duplicate command encountered. This shouldn't happen!" - -data CommandSpec = CommandSpec - { csCmd :: String - , csDescription :: String - , csAction :: IO () - } - -padRight :: Int -> String -> String -padRight n s = s ++ padding - where - padding = replicate (max 0 (n - length s)) ' ' - - -cmdHelpLine :: CommandSpec -> String -cmdHelpLine cs = printf " %s%s" (padRight 25 $ csCmd cs) (csDescription cs) - -topLevelCommands :: [CommandSpec] -topLevelCommands = - [ CommandSpec - "run-nodes" - "Run a local cluster of chainweb-node binaries" - RunNodes.main - , CommandSpec - "tx-list" - "List all transactions in a chain starting with the most recent block" - TxStream.main - , CommandSpec - "genconf" - "Interactively generate a chainweb-node config" - GenConf.main - , CommandSpec - "header-dump" - "Dump Block Headers to a JSON array" - HeaderDump.main - , CommandSpec - "b64" - "Command line utlis for Chainweb's base64 encode/decode" - EncodeDecodeB64Util.main - , CommandSpec - "db-checksum" - "Generate a checksum of all the checkpointer database tables between\ - \\n an inclusive range of blocks." - CheckpointerDBChecksum.main - , CommandSpec - "known-graphs" - "Encode know graphs as JSON values" - KnownGraphs.main - , CommandSpec - "tx-sim" - "Simulate tx execution against real pact dbs" - TxSimulator.simulateMain - , CommandSpec - "compact" - "Compact pact database" - Chainweb.Pact.Backend.Compaction.main - , CommandSpec - "pact-calc" - "Calculate the GrandHashes for a pact database at a particular blockheight" - Chainweb.Pact.Backend.PactState.GrandHash.Calc.pactCalcMain - , CommandSpec - "pact-import" - "Cryptographically verify the pact database, and import it to be used in your node" - Chainweb.Pact.Backend.PactState.GrandHash.Import.pactImportMain - , CommandSpec - "calculate-release" - "Calculate next service date and block heights for upgrades" - CalculateRelease.main - ] - -printHelp :: [CommandSpec] -> IO () -printHelp commands = do - progName <- getProgName - putStrLn $ unlines $ - header progName ++ - map cmdHelpLine commands - where - header progName = - [ "Chainweb Tool" - , "" - , "This executable contains misc commands that have been created for various" - , "reasons in the course of Chainweb development. Linking executables is slow and" - , "the resulting binaries are large, so it is more efficient in terms of build" - , "time, space usage, download time, etc to consolidate them into one binary." - , "" - , "Usage: "++progName++" COMMAND" - , "" - , "Available options:" - , " -h,--help Show this help text" - , "" - , "Available commands:" - ] diff --git a/tools/cwtool/TxSimulator.hs b/tools/cwtool/TxSimulator.hs deleted file mode 100644 index 250a3e415..000000000 --- a/tools/cwtool/TxSimulator.hs +++ /dev/null @@ -1,342 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE ScopedTypeVariables #-} - -module TxSimulator - where - -import Control.Concurrent.MVar -import Control.Lens -import Control.Monad -import Control.Monad.Catch -import Control.Monad.IO.Class -import Crypto.Hash.Algorithms -import Data.Aeson (decodeStrict') -import qualified Data.Map.Strict as M -import Data.Maybe -import qualified Data.Text as T -import qualified Data.Text.Encoding as T -import qualified Data.Text.IO as T -import qualified Data.Vector as V -import Options.Applicative -import System.LogLevel - -import Chainweb.BlockHeader -import Chainweb.BlockHeaderDB.RestAPI.Client -import Chainweb.BlockHeaderDB.Internal -import Chainweb.BlockHeight -import Chainweb.Crypto.MerkleLog -import Chainweb.Logger -import Chainweb.Miner.Pact -import Chainweb.Pact.Backend.RelationalCheckpointer -import Chainweb.Pact.Backend.Types -import Chainweb.Pact.Backend.Utils -import Chainweb.Pact.PactService -import Chainweb.Pact.PactService.Checkpointer -import Chainweb.Pact.PactService.ExecBlock -import Chainweb.Pact.RestAPI.Server -import Chainweb.Pact.Service.Types -import Chainweb.Pact.TransactionExec -import Chainweb.Pact.Types -import Chainweb.Payload -import Chainweb.Payload.PayloadStore -import Chainweb.Payload.PayloadStore.RocksDB (newPayloadDb) -import Chainweb.Payload.RestAPI.Client -import Chainweb.SPV -import Chainweb.Transaction -import Chainweb.Utils -import Chainweb.Utils.Paging -import Chainweb.Version -import Chainweb.Version.Guards -import Chainweb.Version.Mainnet -import Chainweb.Version.Registry - -import Network.Connection -import Network.HTTP.Client.TLS -import Servant.Client.Core -import Servant.Client - -import Chainweb.Storage.Table.RocksDB - -import Pact.Gas -import Pact.Interpreter -import Pact.Native -import Pact.Runtime.Utils -import Pact.Typechecker -import Pact.Types.ChainMeta (noPublicMeta) -import Pact.Types.Command -import Pact.Types.Hash -import Pact.Types.Info ---import Pact.Types.Logger -import Pact.Types.Namespace -import Pact.Types.Persistence -import Pact.Types.Pretty -import Pact.Types.RPC -import Pact.Types.Runtime (runEval,keys,RefStore(..), emptyExecutionConfig, emptyEvalState) -import Pact.Types.SPV -import Pact.Types.Term -import Pact.Types.Typecheck - -import qualified Pact.JSON.Encode as J - -import Utils.Logging.Trace -import Chainweb.Payload.RestAPI (BatchBody(WithHeights)) - -data SimConfig = SimConfig - { scDbDir :: FilePath - -- ^ db dir containing sqlite pact db files - , scTxIndex :: Maybe Int - -- ^ index in payload transactions list - , scApiHostUrl :: BaseUrl - , scRange :: (BlockHeight,BlockHeight) - , scChain :: ChainId - , scVersion :: ChainwebVersion - , scGasLog :: Bool - , scTypecheck :: Bool - } - -simulate :: SimConfig -> IO () -simulate sc@(SimConfig dbDir txIdx' _ _ cid ver gasLog doTypecheck) = do - cenv <- setupClient sc - (ph:hdrs) <- fetchHeaders sc cenv - let parent = ParentHeader ph - pwos <- fetchOutputs sc cenv hdrs - withSqliteDb cid cwLogger dbDir False $ \sqlenv -> do - cp <- - initRelationalCheckpointer defaultModuleCacheLimit sqlenv DoNotPersistIntraBlockWrites logger ver cid - case (txIdx',doTypecheck) of - (Just txIdx,_) -> do -- single-tx simulation - let pwo = unsafeHead "cwtool::TxSimulator.simulate" pwos - let txs = _payloadWithOutputsTransactions pwo - let md = _payloadWithOutputsMiner pwo - miner <- decodeStrictOrThrow $ _minerData md - let Transaction tx = fst $ txs V.! txIdx - cmdTx <- decodeStrictOrThrow tx - case validateCommand ver cid cmdTx of - Left _ -> error "bad cmd" - Right cmdPwt -> do - let cmd = payloadObj <$> cmdPwt - let txc = TxContext parent $ publicMetaOf cmd - -- This rocksdb isn't actually used, it's just to satisfy - -- PactServiceEnv - withTempRocksDb "txsim-rocksdb" $ \rdb -> do - withBlockHeaderDb rdb ver cid $ \bdb -> do - let payloadDb = newPayloadDb rdb - let psEnv = PactServiceEnv - { _psMempoolAccess = Nothing - , _psCheckpointer = cp - , _psPdb = payloadDb - , _psBlockHeaderDb = bdb - , _psGasModel = getGasModel - , _psMinerRewards = readRewards - , _psPreInsertCheckTimeout = defaultPreInsertCheckTimeout - , _psReorgLimit = RewindLimit 0 - , _psOnFatalError = ferr - , _psVersion = ver - , _psAllowReadsInLocal = False - , _psLogger = logger - , _psGasLogger = gasLogger - , _psBlockGasLimit = testBlockGasLimit - , _psEnableLocalTimeout = False - , _psTxFailuresCounter = Nothing - } - evalPactServiceM (PactServiceState mempty) psEnv - $ (throwIfNoHistory =<<) - $ readFrom (Just parent) - $ do - mc <- readInitModules - T3 !cr _mc _ <- do - dbEnv <- view psBlockDbEnv - liftIO $ trace (logFunction cwLogger) "applyCmd" () 1 $ - applyCmd ver logger gasLogger Nothing (_cpPactDbEnv dbEnv) miner (getGasModel txc) - txc noSPVSupport cmd (initGas cmdPwt) mc ApplySend - liftIO $ T.putStrLn (J.encodeText (J.Array <$> cr)) - (_,True) -> do - (throwIfNoHistory =<<) $ _cpReadFrom (_cpReadCp cp) (Just parent) $ \dbEnv -> do - let refStore = RefStore nativeDefs - pd = ctxToPublicData $ TxContext parent noPublicMeta - loadMod = fmap inlineModuleData . getModule noInfo - ee <- setupEvalEnv (_cpPactDbEnv dbEnv) Nothing Local (initMsgData pactInitialHash) refStore freeGasEnv - permissiveNamespacePolicy noSPVSupport pd emptyExecutionConfig - void $ runEval emptyEvalState ee $ do - mods <- keys noInfo Modules - coin <- loadMod "coin" - let dynEnv = M.singleton "fungible-v2" coin - forM mods $ \mn -> do - md <- loadMod mn - case _mdModule md of - MDInterface _ -> return () - MDModule _ -> do - tcr :: Either CheckerException ([TopLevel Node],[Failure]) <- - try $ liftIO $ typecheckModule False dynEnv md - case tcr of - Left (CheckerException ei e) -> - liftIO $ putStrLn $ "TC_FAILURE: " ++ showPretty mn ++ ": " - ++ renderInfo ei ++ ": " ++ showPretty e - Right (_,[]) -> liftIO $ putStrLn $ "TC_SUCCESS: " ++ showPretty mn - Right (_,fails) -> - liftIO $ putStrLn $ "TC_FAILURE: " ++ showPretty mn ++ ": " - ++ "Unable to resolve all types: " ++ show (length fails) ++ " failures" - - - (Nothing,False) -> do -- blocks simulation - -- This rocksdb is unused, it exists to satisfy PactServiceEnv - withTempRocksDb "txsim-rocksdb" $ \rdb -> - withBlockHeaderDb rdb ver cid $ \bdb -> do - let payloadDb = newPayloadDb rdb - let - pse = PactServiceEnv - { _psMempoolAccess = Nothing - , _psCheckpointer = cp - , _psPdb = payloadDb - , _psBlockHeaderDb = bdb - , _psGasModel = getGasModel - , _psMinerRewards = readRewards - , _psPreInsertCheckTimeout = defaultPreInsertCheckTimeout - , _psReorgLimit = RewindLimit 0 - , _psOnFatalError = ferr - , _psVersion = ver - , _psAllowReadsInLocal = False - , _psLogger = logger - , _psGasLogger = gasLogger - , _psBlockGasLimit = testBlockGasLimit - , _psEnableLocalTimeout = False - , _psTxFailuresCounter = Nothing - } - pss = PactServiceState - { _psInitCache = mempty - } - evalPactServiceM pss pse $ doBlock True parent (zip hdrs pwos) - - where - - cwLogger = genericLogger Debug T.putStrLn - initGas cmd = initialGasOf (_cmdPayload cmd) - logger = addLabel ("cwtool", "TxSimulator") $ cwLogger - gasLogger | gasLog = Just cwLogger - | otherwise = Nothing - ferr e _ = throwM e - - doBlock - :: (CanReadablePayloadCas cas) - => Bool - -> ParentHeader - -> [(BlockHeader,PayloadWithOutputs)] - -> PactServiceM GenericLogger cas () - doBlock _ _ [] = return () - doBlock initMC parent ((hdr,pwo):rest) = do - (throwIfNoHistory =<<) $ readFrom (Just parent) $ do - when initMC $ do - mc <- readInitModules - updateInitCacheM mc - void $ trace (logFunction cwLogger) "execBlock" () 1 $ - execBlock hdr (CheckablePayloadWithOutputs pwo) - doBlock False (ParentHeader hdr) rest - --- | Block-scoped SPV mock by matching cont proofs to payload txs. --- Transactions are eliminated by searching for matching proof in input; --- there should always be as many exact matches as proofs. -spvSim :: SimConfig -> BlockHeader -> PayloadWithOutputs -> IO SPVSupport -spvSim sc bh pwo = do - mv <- newMVar (V.toList (_payloadWithOutputsTransactions pwo)) - return $ SPVSupport (_spvSupport noSPVSupport) (go mv) - where - go mv cp = modifyMVar mv $ searchOuts cp - searchOuts _ [] = return ([],Left "spv: proof not found") - searchOuts cp@(ContProof pf) ((Transaction ti,TransactionOutput _o):txs) = - case codecDecode (chainwebPayloadCodec (pactParserVersion (scVersion sc) (_chainId bh) (view blockHeight bh))) ti of - Left {} -> internalError "input decode failed" - Right cmd -> case _pPayload $ payloadObj $ _cmdPayload cmd of - Continuation cm | _cmProof cm == Just cp -> do - -- the following adapted from Chainweb.Pact.SPV.verifyCont with matching errors - t <- decodeB64UrlNoPaddingText $ T.decodeUtf8 pf - case decodeStrict' t of - Nothing -> internalError "unable to decode continuation proof" - Just (TransactionOutputProof pcid p :: TransactionOutputProof SHA512t_256) -> do - unless (pcid == scChain sc) $ - internalError "cannot redeem continuation proof on wrong target chain" - TransactionOutput tout <- proofSubject p - case decodeStrict' tout :: Maybe (CommandResult Hash) of - Nothing -> internalError "unable to decode spv transaction output" - Just cro -> case _crContinuation cro of - Nothing -> return (txs,Left "no pact exec found in command result") - Just pe -> return (txs,Right pe) - _ -> searchOuts cp txs - -setupClient :: SimConfig -> IO ClientEnv -setupClient sc = flip mkClientEnv (scApiHostUrl sc) <$> newTlsManagerWith mgrSettings - where - mgrSettings = mkManagerSettings - (TLSSettingsSimple True False False defaultSupportedTlsSettings) - Nothing - --- | note, fetches [low - 1, hi] to have parent headers -fetchHeaders :: SimConfig -> ClientEnv -> IO [BlockHeader] -fetchHeaders sc cenv = do - r <- (`runClientM` cenv) $ - headersClient (scVersion sc) (scChain sc) Nothing Nothing - (Just $ fromIntegral $ pred $ fst $ scRange sc) - (Just $ fromIntegral $ snd $ scRange sc) - case r of - Left e -> throwM e - Right p -> return $! _pageItems p - -fetchOutputs :: SimConfig -> ClientEnv -> [BlockHeader] -> IO [PayloadWithOutputs] -fetchOutputs sc cenv bhs = do - r <- (`runClientM` cenv) $ do - outputsBatchClient (scVersion sc) (scChain sc) (WithHeights $ map (\bh -> (view blockHeight bh, view blockPayloadHash bh)) bhs) - case r of - Left e -> throwM e - Right ps -> return (_payloadWithOutputsList ps) - -simulateMain :: IO () -simulateMain = do - execParser opts >>= \(d,s,e,i,h,c,v,g,r) -> do - vv <- findKnownVersion $ ChainwebVersionName (T.pack v) - cc <- chainIdFromText (T.pack c) - u <- parseBaseUrl h - let rng = (fromIntegral @Integer s,fromIntegral @Integer (fromMaybe s e)) - simulate $ SimConfig d i u rng cc vv g r - where - opts = info (parser <**> helper) - (fullDesc <> progDesc "Single Transaction simulator") - parser = (,,,,,,,,) - <$> strOption - (short 'd' - <> metavar "DBDIR" - <> help "Pact database directory") - <*> option auto - (short 's' - <> metavar "START_BLOCK_HEIGHT" - <> help "Starting block height") - <*> optional (option auto - (short 'e' - <> metavar "END_BLOCK_HEIGHT" - <> help "Ending block height, if running more than one block")) - <*> optional (option auto - (short 'i' - <> metavar "INDEX" - <> help "Transaction index in payload list. If provided, only runs first block with this tx.")) - <*> (fromMaybe "api.chainweb.com" <$> optional (strOption - (short 'h' - <> metavar "API_HOST" - <> help "API host, default is api.chainweb.com"))) - <*> (strOption - (short 'c' - <> metavar "CHAIN" - <> help "Chain ID")) - <*> (fromMaybe (show Mainnet01) <$> optional (strOption - (short 'v' - <> metavar "VERSION" - <> help ("Chainweb version, default is " - ++ show Mainnet01)))) - <*> switch - (short 'g' - <> help "Enable gas logging") - <*> switch - (short 't' - <> help "Typecheck modules") From d03dfa671e82d26c63df477cf6fdd5187e1a1ab2 Mon Sep 17 00:00:00 2001 From: chessai Date: Tue, 19 Nov 2024 10:33:46 -0600 Subject: [PATCH 3/9] fix ea call in macos ci --- .github/workflows/macos.yaml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.github/workflows/macos.yaml b/.github/workflows/macos.yaml index b3c182978..17b8da787 100644 --- a/.github/workflows/macos.yaml +++ b/.github/workflows/macos.yaml @@ -163,7 +163,7 @@ jobs: mv cabal.project.freeze.backup cabal.project.freeze - name: Run ea and verify consistency of genesis headers run: | - cabal run cwtool -- ea + cabal run ea mv cabal.project.freeze cabal.project.freeze.backup git checkout -- cabal.project.freeze || true if ! git diff --exit-code; then From bd5d6af959a986cc3cf690e0eb2180d62f78e51e Mon Sep 17 00:00:00 2001 From: chessai Date: Mon, 18 Nov 2024 15:19:38 -0600 Subject: [PATCH 4/9] add error messages for assertCommand failures in pact api Change-Id: Ifbad9a2e9c28810f34b80a6c02cc08d68c955cff --- src/Chainweb/Pact/PactService/ExecBlock.hs | 2 +- src/Chainweb/Pact/RestAPI/Server.hs | 11 +-- src/Chainweb/Pact/Validations.hs | 99 ++++++++++++++++++---- 3 files changed, 86 insertions(+), 26 deletions(-) diff --git a/src/Chainweb/Pact/PactService/ExecBlock.hs b/src/Chainweb/Pact/PactService/ExecBlock.hs index 217481b10..78b3ef88f 100644 --- a/src/Chainweb/Pact/PactService/ExecBlock.hs +++ b/src/Chainweb/Pact/PactService/ExecBlock.hs @@ -248,7 +248,7 @@ validateChainwebTxs logger v cid dbEnv txValidationTime bh txs doBuyGas checkTxSigs :: ChainwebTransaction -> IO (Either InsertError ChainwebTransaction) checkTxSigs t - | assertValidateSigs validSchemes webAuthnPrefixLegal hsh signers sigs = pure $ Right t + | isRight (assertValidateSigs validSchemes webAuthnPrefixLegal hsh signers sigs) = pure $ Right t | otherwise = return $ Left InsertErrorInvalidSigs where hsh = P._cmdHash t diff --git a/src/Chainweb/Pact/RestAPI/Server.hs b/src/Chainweb/Pact/RestAPI/Server.hs index a00d62317..226476b73 100644 --- a/src/Chainweb/Pact/RestAPI/Server.hs +++ b/src/Chainweb/Pact/RestAPI/Server.hs @@ -114,7 +114,7 @@ import Chainweb.Transaction import qualified Chainweb.TreeDB as TreeDB import Chainweb.Utils import Chainweb.Version -import Chainweb.Pact.Validations (assertCommand) +import Chainweb.Pact.Validations (assertCommand, displayAssertCommandError) import Chainweb.Version.Guards (isWebAuthnPrefixLegal, pactParserVersion, validPPKSchemes) import Chainweb.WebPactExecutionService @@ -689,12 +689,9 @@ toPactTx (Transaction b) = note "toPactTx failure" (decodeStrict' b) validateCommand :: ChainwebVersion -> ChainId -> Command Text -> Either String ChainwebTransaction validateCommand v cid (fmap encodeUtf8 -> cmdBs) = case parsedCmd of Right (commandParsed :: ChainwebTransaction) -> - if assertCommand - commandParsed - (validPPKSchemes v cid bh) - (isWebAuthnPrefixLegal v cid bh) - then Right commandParsed - else Left "Command failed validation" + case assertCommand commandParsed (validPPKSchemes v cid bh) (isWebAuthnPrefixLegal v cid bh) of + Left err -> Left $ "Command failed validation: " ++ displayAssertCommandError err + Right () -> Right commandParsed Left e -> Left $ "Pact parsing error: " ++ e where bh = maxBound :: BlockHeight diff --git a/src/Chainweb/Pact/Validations.hs b/src/Chainweb/Pact/Validations.hs index dd9f859af..d66978cac 100644 --- a/src/Chainweb/Pact/Validations.hs +++ b/src/Chainweb/Pact/Validations.hs @@ -1,6 +1,9 @@ {-# LANGUAGE DataKinds #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} + -- | -- Module: Chainweb.Pact.Validations -- Copyright: Copyright © 2018,2019,2020,2021,2022 Kadena LLC. @@ -25,9 +28,13 @@ module Chainweb.Pact.Validations , assertTxSize , IsWebAuthnPrefixLegal(..) , assertValidateSigs +, AssertValidateSigsError(..) +, displayAssertValidateSigsError , assertTxTimeRelativeToParent , assertTxNotInFuture , assertCommand +, AssertCommandError(..) +, displayAssertCommandError -- * Defaults , defaultMaxCommandUserSigListSize , defaultMaxCoinDecimalPlaces @@ -38,6 +45,7 @@ module Chainweb.Pact.Validations import Control.Lens import Data.Decimal (decimalPlaces) +import Data.Bifunctor (first) import Data.Maybe (isJust, catMaybes, fromMaybe) import Data.Either (isRight) import Data.List.NonEmpty (NonEmpty, nonEmpty) @@ -104,7 +112,7 @@ assertLocalMetadata cmd@(P.Command pay sigs hsh) txCtx sigVerify = do where sigValidate validSchemes webAuthnPrefixLegal signers | Just NoVerify <- sigVerify = True - | otherwise = assertValidateSigs validSchemes webAuthnPrefixLegal hsh signers sigs + | otherwise = isRight $ assertValidateSigs validSchemes webAuthnPrefixLegal hsh signers sigs pct = ParentCreationTime . view blockCreationTime @@ -160,22 +168,68 @@ assertSigSize sigs = length sigs <= defaultMaxCommandUserSigListSize assertTxSize :: P.Gas -> P.GasLimit -> Bool assertTxSize initialGas gasLimit = initialGas < fromIntegral gasLimit +data AssertValidateSigsError + = SignersAndSignaturesLengthMismatch + { _signersLength :: !Int + , _signaturesLength :: !Int + } + | InvalidSignerScheme + { _position :: !Int + } + | InvalidSignerWebAuthnPrefix + { _position :: !Int + } + | InvalidUserSig + { _position :: !Int + , _errMsg :: String + } + +displayAssertValidateSigsError :: AssertValidateSigsError -> String +displayAssertValidateSigsError = \case + SignersAndSignaturesLengthMismatch signersLength sigsLength -> + "The number of signers and signatures do not match. Number of signers: " ++ show signersLength ++ ". Number of signatures: " ++ show sigsLength ++ "." + InvalidSignerScheme pos -> + "The signer at position " ++ show pos ++ " has an invalid signature scheme." + InvalidSignerWebAuthnPrefix pos -> + "The signer at position " ++ show pos ++ " has an invalid WebAuthn prefix." + InvalidUserSig pos errMsg -> + "The signature at position " ++ show pos ++ " is invalid: " ++ errMsg ++ "." + -- | Check and assert that signers and user signatures are valid for a given -- transaction hash. -- -assertValidateSigs :: [P.PPKScheme] -> IsWebAuthnPrefixLegal -> P.PactHash -> [P.Signer] -> [P.UserSig] -> Bool -assertValidateSigs validSchemes webAuthnPrefixLegal hsh signers sigs - | length signers /= length sigs = False - | otherwise = and $ zipWith verifyUserSig sigs signers - where verifyUserSig sig signer = - let - sigScheme = fromMaybe P.ED25519 (P._siScheme signer) - okScheme = sigScheme `elem` validSchemes - okPrefix = - webAuthnPrefixLegal == WebAuthnPrefixLegal || - not (P.webAuthnPrefix `T.isPrefixOf` P._siPubKey signer) - okSignature = isRight $ P.verifyUserSig hsh sig signer - in okScheme && okPrefix && okSignature +assertValidateSigs :: () + => [P.PPKScheme] + -> IsWebAuthnPrefixLegal + -> P.PactHash + -> [P.Signer] + -> [P.UserSig] + -> Either AssertValidateSigsError () +assertValidateSigs validSchemes webAuthnPrefixLegal hsh signers sigs = do + let signersLength = length signers + let sigsLength = length sigs + checkE (signersLength == sigsLength) + $ SignersAndSignaturesLengthMismatch + { _signersLength = signersLength + , _signaturesLength = sigsLength + } + + iforM_ (zip sigs signers) $ \pos (sig, signer) -> do + checkE + (fromMaybe P.ED25519 (P._siScheme signer) `elem` validSchemes) + (InvalidSignerScheme pos) + checkE + (webAuthnPrefixLegal == WebAuthnPrefixLegal || not (P.webAuthnPrefix `T.isPrefixOf` P._siPubKey signer)) + (InvalidSignerWebAuthnPrefix pos) + case P.verifyUserSig hsh sig signer of + Left errMsg -> Left (InvalidUserSig pos errMsg) + Right () -> Right () + + pure () + + where + checkE :: Bool -> e -> Either e () + checkE b e = if b then Right () else Left e -- prop_tx_ttl_newBlock/validateBlock -- @@ -212,13 +266,22 @@ assertTxNotInFuture (ParentCreationTime (BlockCreationTime txValidationTime)) tx P.TxCreationTime txOriginationTime = view cmdCreationTime tx lenientTxValidationTime = add (scaleTimeSpan defaultLenientTimeSlop second) txValidationTime +data AssertCommandError + = InvalidPayloadHash + | AssertValidateSigsError AssertValidateSigsError + +displayAssertCommandError :: AssertCommandError -> String +displayAssertCommandError = \case + InvalidPayloadHash -> "The hash of the payload was invalid." + AssertValidateSigsError err -> displayAssertValidateSigsError err -- | Assert that the command hash matches its payload and -- its signatures are valid, without parsing the payload. -assertCommand :: P.Command PayloadWithText -> [P.PPKScheme] -> IsWebAuthnPrefixLegal -> Bool -assertCommand (P.Command pwt sigs hsh) ppkSchemePassList webAuthnPrefixLegal = - isRight assertHash && - assertValidateSigs ppkSchemePassList webAuthnPrefixLegal hsh signers sigs +assertCommand :: P.Command PayloadWithText -> [P.PPKScheme] -> IsWebAuthnPrefixLegal -> Either AssertCommandError () +assertCommand (P.Command pwt sigs hsh) ppkSchemePassList webAuthnPrefixLegal = do + if isRight assertHash + then first AssertValidateSigsError $ assertValidateSigs ppkSchemePassList webAuthnPrefixLegal hsh signers sigs + else Left InvalidPayloadHash where cmdBS = SBS.fromShort $ payloadBytes pwt signers = P._pSigners (payloadObj pwt) From 1038f75ef8e09dc7841780375861c576188e1aea Mon Sep 17 00:00:00 2001 From: chessai Date: Mon, 18 Nov 2024 16:11:09 -0600 Subject: [PATCH 5/9] sendHandler: include position of first command to fail Change-Id: Ife3bc9380cce0fd1ea568e8fe40a1aed903c5643 --- src/Chainweb/Pact/RestAPI/Server.hs | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/src/Chainweb/Pact/RestAPI/Server.hs b/src/Chainweb/Pact/RestAPI/Server.hs index 226476b73..460fcf181 100644 --- a/src/Chainweb/Pact/RestAPI/Server.hs +++ b/src/Chainweb/Pact/RestAPI/Server.hs @@ -35,7 +35,7 @@ import Control.Applicative import Control.Concurrent.STM (atomically) import Control.Concurrent.STM.TVar import Control.DeepSeq -import Control.Lens (set, view, preview) +import Control.Lens (set, view, preview, itraverse) import Control.Monad import Control.Monad.Catch hiding (Handler) import Control.Monad.Reader @@ -43,7 +43,7 @@ import Control.Monad.State.Strict import Control.Monad.Trans.Except (ExceptT, runExceptT, except) import Data.Aeson as Aeson -import Data.Bifunctor (second) +import Data.Bifunctor (first, second) import qualified Data.ByteString.Lazy as BSL import qualified Data.ByteString.Lazy.Char8 as BSL8 import qualified Data.ByteString.Short as SB @@ -253,14 +253,14 @@ sendHandler -> Handler RequestKeys sendHandler logger v cid mempool (SubmitBatch cmds) = Handler $ do liftIO $ logg Info (PactCmdLogSend cmds) - case traverse (validateCommand v cid) cmds of + case itraverse (\i cmd -> first (i,) (validateCommand v cid cmd)) cmds of Right enriched -> do let txs = V.fromList $ NEL.toList enriched -- If any of the txs in the batch fail validation, we reject them all. liftIO (mempoolInsertCheck mempool txs) >>= checkResult liftIO (mempoolInsert mempool UncheckedInsert txs) return $! RequestKeys $ NEL.map cmdToRequestKey enriched - Left err -> failWith $ "Validation failed: " <> T.pack err + Left (pos, err) -> failWith $ "Validation of command at position " <> sshow pos <> " failed: " <> T.pack err where failWith :: Text -> ExceptT ServerError IO a failWith err = throwError $ setErrText err err400 From d80eaf454134dea71e8a841a6e092a5b4a135f05 Mon Sep 17 00:00:00 2001 From: chessai Date: Tue, 19 Nov 2024 15:35:17 -0600 Subject: [PATCH 6/9] remove redundant $ in test lib Change-Id: I796db312622794cb7a8ab8679a2297859a682bbc --- test/lib/Chainweb/Test/Pact/Utils.hs | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/test/lib/Chainweb/Test/Pact/Utils.hs b/test/lib/Chainweb/Test/Pact/Utils.hs index 30d5f6e71..55a66312f 100644 --- a/test/lib/Chainweb/Test/Pact/Utils.hs +++ b/test/lib/Chainweb/Test/Pact/Utils.hs @@ -494,7 +494,8 @@ mkEd25519Signer pubKey privKey caps = CmdSigner { _siScheme = Nothing , _siPubKey = pubKey , _siAddress = Nothing - , _siCapList = caps } + , _siCapList = caps + } mkEd25519Signer' :: SimpleKeyPair -> [SigCapability] -> CmdSigner mkEd25519Signer' (pub,priv) = mkEd25519Signer pub priv @@ -598,7 +599,7 @@ mkDynKeyPairs (CmdSigner Signer{..} privKey) = (ED25519, pub, priv) -> do pub' <- either diePubKey return $ parseEd25519PubKey =<< parseB16TextOnly pub priv' <- either diePrivKey return $ parseEd25519SecretKey =<< parseB16TextOnly priv - return $ (DynEd25519KeyPair (pub', priv'), _siCapList) + return (DynEd25519KeyPair (pub', priv'), _siCapList) (WebAuthn, pub, priv) -> do let (pubKeyStripped, wasPrefixed) = fromMaybe @@ -608,7 +609,7 @@ mkDynKeyPairs (CmdSigner Signer{..} privKey) = either diePubKey return (parseWebAuthnPublicKey =<< parseB16TextOnly pubKeyStripped) privWebAuthn <- either diePrivKey return (parseWebAuthnPrivateKey =<< parseB16TextOnly priv) - return $ (DynWebAuthnKeyPair wasPrefixed pubWebAuthn privWebAuthn, _siCapList) + return (DynWebAuthnKeyPair wasPrefixed pubWebAuthn privWebAuthn, _siCapList) where diePubKey str = error $ "pubkey: " <> str diePrivKey str = error $ "privkey: " <> str From de0b85b53cbe9c8be97877e6e0d9effc21933526 Mon Sep 17 00:00:00 2001 From: chessai Date: Tue, 19 Nov 2024 15:35:29 -0600 Subject: [PATCH 7/9] add remote pact test for send error messages Change-Id: I2046ab2a28a2951c71ef4909e580e51256673716 --- .../unit/Chainweb/Test/Pact/RemotePactTest.hs | 112 ++++++++++++++++++ 1 file changed, 112 insertions(+) diff --git a/test/unit/Chainweb/Test/Pact/RemotePactTest.hs b/test/unit/Chainweb/Test/Pact/RemotePactTest.hs index 23186aeb3..c214e244a 100644 --- a/test/unit/Chainweb/Test/Pact/RemotePactTest.hs +++ b/test/unit/Chainweb/Test/Pact/RemotePactTest.hs @@ -75,6 +75,7 @@ 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 @@ -184,6 +185,7 @@ tests rdb = testGroup "Chainweb.Test.Pact.RemotePactTest" join $ webAuthnSignatureTest <$> iot <*> cenv ] , testCase "txlogsCompactionTest" $ txlogsCompactionTest rdb + , testCase "invalid command test" $ invalidCommandTest rdb ] responseGolden :: ClientEnv -> RequestKeys -> IO LBS.ByteString @@ -193,6 +195,116 @@ responseGolden cenv rks = do (NEL.toList $ _rkRequestKeys rks) return $ foldMap J.encode values +invalidCommandTest :: RocksDb -> IO () +invalidCommandTest rdb = runResourceT $ do + nodeDbDirs <- withNodeDbDirs rdb nNodes + net <- withNodesAtLatestBehavior v id nodeDbDirs + let cenv = _getServiceClientEnv net + + let sendExpect :: [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 + + 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] (== "Validation of command at position 0 failed: Pact parsing 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] (== "Validation of command at position 0 failed: Command failed validation: The hash of the payload was invalid.") + + 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] (== "Validation of command at position 0 failed: Command failed validation: 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] (== "Validation of command at position 0 failed: Command failed validation: 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] (== "Validation of command at position 0 failed: Command failed validation: 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] (== "Validation of command at position 0 failed: Command failed validation: 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] (== "Validation of command at position 1 failed: Command failed validation: 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. -- From 8d00677d9f34107849b010d5cd27becdf2dc0852 Mon Sep 17 00:00:00 2001 From: Lars Kuhtz Date: Mon, 25 Nov 2024 10:46:44 -0800 Subject: [PATCH 8/9] remove redundant sbv pin from cabal.project --- cabal.project | 8 -------- 1 file changed, 8 deletions(-) diff --git a/cabal.project b/cabal.project index e20b71ced..585f73b7d 100644 --- a/cabal.project +++ b/cabal.project @@ -132,14 +132,6 @@ source-repository-package tag: 8b3227c59305f7e5ca6af7c0b9bc5435e78875a0 --sha256: 08xpx3vwl8w7gn6z9s5smc383b962mxal3nav0fd5qh55yxqsp97 --- Patch merged into master (upcoming verison 10.0). We are currently using 9.2. --- This fork contains additional fixes for using 9.2 with recent compilers. -source-repository-package - type: git - location: https://github.com/larskuhtz/sbv - tag: 1f2d042718fcf9a140398bd3dedac77c207cce27 - --sha256: 0l3nhsdxsyx17i29dw691d6bbqz26af6lg6pi1c2kb34v59m2rk3 - -- Required for non-canonical decode in base64-bytestring (remove after 2.20 fork) source-repository-package type: git From 7101176779da8b8de0a51c0d9493fc1807c7a771 Mon Sep 17 00:00:00 2001 From: Lars Kuhtz Date: Wed, 27 Nov 2024 23:55:44 -0800 Subject: [PATCH 9/9] fix command validation test outputs --- src/Chainweb/Pact/RestAPI/Server.hs | 2 +- test/unit/Chainweb/Test/Pact4/RemotePactTest.hs | 16 +++++++++------- 2 files changed, 10 insertions(+), 8 deletions(-) diff --git a/src/Chainweb/Pact/RestAPI/Server.hs b/src/Chainweb/Pact/RestAPI/Server.hs index 43ff88494..251d5582a 100644 --- a/src/Chainweb/Pact/RestAPI/Server.hs +++ b/src/Chainweb/Pact/RestAPI/Server.hs @@ -267,7 +267,7 @@ sendHandler logger mempool (Pact4.SubmitBatch cmds) = Handler $ do liftIO (mempoolInsertCheck mempool cmdsWithParsedPayloadsV) >>= checkResult liftIO (mempoolInsert mempool UncheckedInsert cmdsWithParsedPayloadsV) return $! Pact4.RequestKeys $ NEL.map Pact4.cmdToRequestKey cmdsWithParsedPayloads - Left err -> failWith $ "JSON of transaction failed: " <> T.pack err + Left err -> failWith $ "reading JSON for transaction failed: " <> T.pack err where failWith :: Text -> ExceptT ServerError IO a failWith err = do diff --git a/test/unit/Chainweb/Test/Pact4/RemotePactTest.hs b/test/unit/Chainweb/Test/Pact4/RemotePactTest.hs index de7420e83..c3a3a4f41 100644 --- a/test/unit/Chainweb/Test/Pact4/RemotePactTest.hs +++ b/test/unit/Chainweb/Test/Pact4/RemotePactTest.hs @@ -226,6 +226,8 @@ invalidCommandTest rdb = runResourceT $ do iot <- liftIO $ toTxCreationTime @Integer <$> getCurrentTimeIntegral + let prefix cmd = "Validation failed for hash " <> sshow (_cmdHash cmd) <> ": " + cmdParseFailure <- liftIO $ buildTextCmd "bare-command" v $ set cbSigners [mkEd25519Signer' sender00 []] $ set cbTTL defaultMaxTTL @@ -234,7 +236,7 @@ invalidCommandTest rdb = runResourceT $ do $ set cbRPC (mkExec "(+ 1" (mkKeySetData "sender00" [sender00])) $ defaultCmd -- Why does pact just return 'mzero' here... - sendExpect [cmdParseFailure] (== "Validation of command at position 0 failed: Pact parsing error: Failed reading: mzero") + sendExpect [cmdParseFailure] (== (prefix cmdParseFailure <> "Pact parse error: Failed reading: mzero")) cmdInvalidPayloadHash <- liftIO $ do bareCmd <- buildTextCmd "bare-command" v @@ -247,7 +249,7 @@ invalidCommandTest rdb = runResourceT $ do pure $ bareCmd { _cmdHash = Pact.hash "fakehash" } - sendExpect [cmdInvalidPayloadHash] (== "Validation of command at position 0 failed: Command failed validation: The hash of the payload was invalid.") + sendExpect [cmdInvalidPayloadHash] (== (prefix cmdInvalidPayloadHash <> "Invalid transaction hash")) cmdSignersSigsLengthMismatch1 <- liftIO $ do bareCmd <- buildTextCmd "bare-command" v @@ -260,7 +262,7 @@ invalidCommandTest rdb = runResourceT $ do pure $ bareCmd { _cmdSigs = [] } - sendExpect [cmdSignersSigsLengthMismatch1] (== "Validation of command at position 0 failed: Command failed validation: The number of signers and signatures do not match. Number of signers: 1. Number of signatures: 0.") + sendExpect [cmdSignersSigsLengthMismatch1] (== (prefix cmdSignersSigsLengthMismatch1 <> "Invalid transaction sigs")) cmdSignersSigsLengthMismatch2 <- liftIO $ do bareCmd <- buildTextCmd "bare-command" v @@ -274,7 +276,7 @@ invalidCommandTest rdb = runResourceT $ do { -- This is an invalid ED25519 signature, but length signers == length signatures is checked first _cmdSigs = [ED25519Sig "fakeSig"] } - sendExpect [cmdSignersSigsLengthMismatch2] (== "Validation of command at position 0 failed: Command failed validation: The number of signers and signatures do not match. Number of signers: 0. Number of signatures: 1.") + sendExpect [cmdSignersSigsLengthMismatch2] (== (prefix cmdSignersSigsLengthMismatch2 <> "Invalid transaction sigs")) -- TODO: It's hard to test for invalid schemes, because it's baked into -- chainwebversion. @@ -293,7 +295,7 @@ invalidCommandTest rdb = runResourceT $ do pure $ bareCmd { _cmdSigs = [ED25519Sig "fakeSig"] } - sendExpect [cmdInvalidUserSig] (== "Validation of command at position 0 failed: Command failed validation: The signature at position 0 is invalid: failed to parse ed25519 signature: invalid bytestring size.") + sendExpect [cmdInvalidUserSig] (== (prefix cmdInvalidUserSig <> "Invalid transaction sigs")) cmdGood <- liftIO $ buildTextCmd "good-command" v $ set cbSigners [mkEd25519Signer' sender00 []] @@ -304,12 +306,12 @@ invalidCommandTest rdb = runResourceT $ do $ 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] (== "Validation of command at position 0 failed: Command failed validation: The signature at position 0 is invalid: failed to parse ed25519 signature: invalid bytestring size.") + sendExpect [cmdInvalidUserSig, cmdGood] (== (prefix cmdInvalidUserSig <> "Invalid transaction sigs")) -- 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] (== "Validation of command at position 1 failed: Command failed validation: The signature at position 0 is invalid: failed to parse ed25519 signature: invalid bytestring size.") + sendExpect [cmdGood, cmdInvalidUserSig] (== (prefix cmdInvalidUserSig <> "Invalid transaction sigs")) -- | Check that txlogs don't problematically access history -- post-compaction.