From 3fa69e89f5f17c97569b3cc5ee8ecead1162f56a Mon Sep 17 00:00:00 2001 From: Lars Kuhtz Date: Fri, 20 Sep 2024 05:50:55 -0700 Subject: [PATCH] support ghc-9.10 (#1976) * format cabal file more consistently * remove redundant upper bound on unliftio * raise lower bound on unordered containers * add missing other-modules in cabal file * fix upper bound of crypton-connection * raise lower bound on crypton-connection to 0.4 * update freeze file * support ghc-9.10 * support ghc-9.10 * update freeze file * remove redundant upper bound on mwc-probability * update cabal CI workflows * update pact pin * update nix hackage * deprecate rosetta * update ethereum pin and hashes package * fix flaky tests * update freeze file * update pact pin to latest master * update nix flake lock * allow-newer for hashable * add arch to macos tools cache * reenable unfrozen docker image * fix dist-newstyle cache key * more caching fixes for macos build * use arm64 for mac build * exclude musl regression test on macos --- .github/workflows/applications.yml | 48 ++- .github/workflows/macos.yaml | 47 ++- cabal.project | 30 +- cabal.project.freeze | 172 ++++++++-- chainweb.cabal | 44 +-- flake.lock | 6 +- src/Chainweb/Mempool/CurrentTxs.hs | 3 + src/Chainweb/Mempool/InMem.hs | 5 + .../Pact/Backend/RelationalCheckpointer.hs | 24 +- src/Chainweb/Rosetta/Internal.hs | 5 + src/Chainweb/Rosetta/Utils.hs | 3 + src/Chainweb/Utils.hs | 5 +- src/Numeric/Additive.hs | 317 ------------------ src/Numeric/AffineSpace.hs | 110 ------ src/P2P/Node/PeerDB.hs | 3 + test/Chainweb/Test/Pact/PactMultiChainTest.hs | 6 +- .../Chainweb/Test/Pact/PactSingleChainTest.hs | 56 ++-- test/Chainweb/Test/Pact/SQLite.hs | 2 +- test/Chainweb/Test/Rosetta/RestAPI.hs | 45 ++- test/Chainweb/Test/Utils.hs | 3 +- test/golden/new-block-0-expected.txt | 12 +- tools/cwtool/TxSimulator.hs | 2 +- 22 files changed, 361 insertions(+), 587 deletions(-) delete mode 100644 src/Numeric/Additive.hs delete mode 100644 src/Numeric/AffineSpace.hs diff --git a/.github/workflows/applications.yml b/.github/workflows/applications.yml index d206244707..f32d7877e4 100644 --- a/.github/workflows/applications.yml +++ b/.github/workflows/applications.yml @@ -134,10 +134,17 @@ jobs: if "${{ github.event_name == 'schedule' }}" == "true"; then MATRIX="$(jq -c '.' < Dockerfile <= 3.8 + , Cabal >= 3.8 , base >= 4.12 && < 5 , bytestring >= 0.10.12 , directory >= 1.3 @@ -132,7 +132,7 @@ library c-sources: c/shathree.c cc-options: -DSQLITE_CORE exposed-modules: - Chainweb.Backup + , Chainweb.Backup , Chainweb.BlockCreationTime , Chainweb.BlockHash , Chainweb.BlockHeader @@ -284,8 +284,6 @@ library , Network.X509.SelfSigned , Numeric.Cast - , Numeric.Additive - , Numeric.AffineSpace , P2P.BootstrapNodes , P2P.Node @@ -359,7 +357,7 @@ library , Utils.Logging.Trace build-depends: - Decimal >= 0.4.2 + , Decimal >= 0.4.2 , aeson >= 2.2 , asn1-encoding >=0.9 , asn1-types >=0.3 @@ -375,10 +373,9 @@ library , chainweb-storage >= 0.1 , clock >= 0.7 , configuration-tools >= 0.6 - , crypton-connection >= 0.2 && < 0.4 , containers >= 0.5 , crypton >= 0.31 - , crypton-connection >= 0.2 && < 0.4 + , crypton-connection >= 0.4 , crypton-x509 >=1.7 , crypton-x509-system >=1.6 , crypton-x509-validation >=1.6 @@ -414,12 +411,13 @@ library , mmorph >= 1.1 , monad-control >= 1.0 , mtl >= 2.3 - , mwc-probability >= 2.0 && <2.4 + , mwc-probability >= 2.0 , mwc-random >= 0.13 , network >= 3.1.2 , optparse-applicative >= 0.14 , pact >= 4.2.0.1 , pact-json >= 0.1 + , pact-time:numeric >=0.3.0.1 , parallel >= 3.2.2.0 , patience >= 0.3 , pem >=0.2 @@ -447,8 +445,8 @@ library , token-bucket >= 0.1 , transformers >= 0.5 , trifecta >= 2.1 - , unliftio ^>= 0.2 - , unordered-containers >= 0.2.16 + , unliftio >= 0.2 + , unordered-containers >= 0.2.20 , uuid >= 1.3.15 , vector >= 0.12.2 , vector-algorithms >= 0.7 @@ -550,6 +548,7 @@ test-suite chainweb-tests Data.Test.Word.Encoding -- P2P + P2P.Test.Node P2P.Test.Orphans P2P.Test.TaskQueue @@ -571,7 +570,7 @@ test-suite chainweb-tests , bytestring >= 0.10.12 , case-insensitive >= 1.2 , chainweb-storage >= 0.1 - , crypton-connection >=0.2 + , crypton-connection >=0.4 , containers >= 0.5 , crypton >= 0.31 , data-default >=0.7 @@ -597,6 +596,7 @@ test-suite chainweb-tests , http-client-tls >=0.3 , pact , pact-json >= 0.1 + , pact-time:numeric >=0.3.0.1 , quickcheck-instances >= 0.3 , random >= 1.2 , resource-pool >= 0.4 @@ -622,7 +622,7 @@ test-suite chainweb-tests , time >= 1.12.2 , transformers >= 0.5 , unliftio >= 0.2.25 - , unordered-containers >= 0.2.16 + , unordered-containers >= 0.2.20 , vector >= 0.12.2 , wai >= 3.2 , wai-middleware-validation @@ -665,7 +665,7 @@ executable chainweb-node PkgInfo build-depends: -- internal - chainweb + , chainweb -- external , async >= 2.2 @@ -712,14 +712,18 @@ executable cwtool main-is: CwTool.hs other-modules: Allocations + Chainweb.Test.Cut + Chainweb.Test.Cut.TestBlockDb Chainweb.Test.HostAddress Chainweb.Test.MultiNode Chainweb.Test.Orphans.Internal Chainweb.Test.Orphans.Pact Chainweb.Test.Orphans.Time - Chainweb.Test.Pact.Utils Chainweb.Test.P2P.Peer.BootstrapConfig + Chainweb.Test.Pact.Utils + Chainweb.Test.TestVersions Chainweb.Test.Utils + Chainweb.Test.Utils.APIValidation Chainweb.Test.Utils.BlockHeader CheckpointerDBChecksum Ea @@ -738,7 +742,7 @@ executable cwtool build-depends: -- internal - chainweb + , chainweb -- external , QuickCheck >= 2.14 @@ -755,7 +759,7 @@ executable cwtool , chainweb-storage >= 0.1 , chronos >= 1.1 , configuration-tools >= 0.6 - , crypton-connection >=0.2 + , crypton-connection >=0.4 , containers >= 0.5 , crypton >= 0.31 , data-default >=0.7 @@ -780,6 +784,7 @@ executable cwtool , optparse-applicative >= 0.14 , pact , pact-json + , pact-time:numeric >=0.3.0.1 , patience >= 0.3 , process >= 1.5 , quickcheck-instances >= 0.3 @@ -802,7 +807,7 @@ executable cwtool , time >= 1.9 , text >= 2.0 , unliftio >= 0.2.25 - , unordered-containers >= 0.2.16 + , unordered-containers >= 0.2.20 , vector >= 0.12.2 , wai >= 3.2 , wai-middleware-validation @@ -870,10 +875,11 @@ benchmark bench Chainweb.Test.Orphans.Internal Chainweb.Test.Orphans.Pact Chainweb.Test.Orphans.Time + Chainweb.Test.TestVersions P2P.Test.Orphans build-depends: - Decimal >= 0.4.2 + , Decimal >= 0.4.2 , aeson >= 2.2 , async >= 2.2 , base >= 4.12 && < 5 @@ -902,6 +908,6 @@ benchmark bench , crypton >= 0.31 , quickcheck-instances >= 0.3 , streaming-commons >= 0.2 - , unordered-containers >= 0.2.16 + , unordered-containers >= 0.2.20 , yet-another-logger >= 0.4.1 , pact-json >= 0.1 diff --git a/flake.lock b/flake.lock index 9fb9311963..af40055c27 100644 --- a/flake.lock +++ b/flake.lock @@ -85,11 +85,11 @@ "hackage": { "flake": false, "locked": { - "lastModified": 1722990360, - "narHash": "sha256-FkfLz/+j02/3t9QZaZBOXmn/noA2Gt0MlkvSNlhT4QM=", + "lastModified": 1722385397, + "narHash": "sha256-rccC2HsYG7SUEo5dhLRhwx7RWRotvlzeF/TZ3IU4mZY=", "owner": "input-output-hk", "repo": "hackage.nix", - "rev": "b21329e3b7431ad475ffc848e55be3b7a795ea9c", + "rev": "cb8f6dc140b3bcfe14589f5a191fa912bef2464f", "type": "github" }, "original": { diff --git a/src/Chainweb/Mempool/CurrentTxs.hs b/src/Chainweb/Mempool/CurrentTxs.hs index 32f50b1921..aa9a47f039 100644 --- a/src/Chainweb/Mempool/CurrentTxs.hs +++ b/src/Chainweb/Mempool/CurrentTxs.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -35,7 +36,9 @@ module Chainweb.Mempool.CurrentTxs import qualified Data.ByteString as B import qualified Data.ByteString.Short as BS +#if !MIN_VERSION_base(4,20,0) import Data.Foldable +#endif import qualified Data.List as L import qualified Data.Set as S import qualified Data.Vector as V diff --git a/src/Chainweb/Mempool/InMem.hs b/src/Chainweb/Mempool/InMem.hs index 233b9c6ccd..6f35df1aa5 100644 --- a/src/Chainweb/Mempool/InMem.hs +++ b/src/Chainweb/Mempool/InMem.hs @@ -1,5 +1,6 @@ {-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE NumericUnderscores #-} @@ -36,7 +37,11 @@ import Data.Aeson import Data.Bifunctor (bimap) import qualified Data.ByteString.Short as SB import Data.Decimal +#if MIN_VERSION_base(4,20,0) +import Data.Foldable (foldlM) +#else import Data.Foldable (foldl', foldlM) +#endif import Data.Function (on) import Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as HashMap diff --git a/src/Chainweb/Pact/Backend/RelationalCheckpointer.hs b/src/Chainweb/Pact/Backend/RelationalCheckpointer.hs index 3775475c4a..7a80196143 100644 --- a/src/Chainweb/Pact/Backend/RelationalCheckpointer.hs +++ b/src/Chainweb/Pact/Backend/RelationalCheckpointer.hs @@ -1,4 +1,5 @@ {-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NumericUnderscores #-} @@ -32,7 +33,9 @@ import Control.Monad.IO.Class import Data.ByteString (intercalate) import qualified Data.ByteString.Short as BS +#if !MIN_VERSION_base(4,20,0) import Data.Foldable (foldl') +#endif import Data.Int import qualified Data.Map.Strict as M import Data.Maybe @@ -278,8 +281,7 @@ doGetEarliestBlock db = do [] -> return Nothing (!o:_) -> return (Just o) where - qtext = "SELECT blockheight, hash FROM BlockHistory \ - \ ORDER BY blockheight ASC LIMIT 1" + 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 @@ -293,8 +295,7 @@ doGetLatestBlock db = do [] -> return Nothing (!o:_) -> return (Just o) where - qtext = "SELECT blockheight, hash FROM BlockHistory \ - \ ORDER BY blockheight DESC LIMIT 1" + 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 @@ -309,8 +310,7 @@ doLookupBlock db (bheight, bhash) = do [SInt n] -> return $! n == 1 _ -> internalError "doLookupBlock: output type mismatch" where - qtext = "SELECT COUNT(*) FROM BlockHistory WHERE blockheight = ? \ - \ AND hash = ?;" + qtext = "SELECT COUNT(*) FROM BlockHistory WHERE blockheight = ? AND hash = ?;" doGetBlockParent :: ChainwebVersion -> ChainId -> SQLiteEnv -> (BlockHeight, BlockHash) -> IO (Maybe BlockHash) doGetBlockParent v cid db (bh, hash) @@ -336,11 +336,13 @@ doLookupSuccessful curHeight hashes = do callDb "doLookupSuccessful" $ \db -> do let hss = V.toList hashes - params = Utf8 $ intercalate "," (map (const "?") hss) - qtext = "SELECT blockheight, hash, txhash FROM \ - \TransactionIndex INNER JOIN BlockHistory \ - \USING (blockheight) WHERE txhash IN (" <> params <> ")" - <> " AND blockheight <= ?;" + params = intercalate "," (map (const "?") hss) + qtext = Utf8 $ intercalate " " + [ "SELECT blockheight, hash, txhash" + , "FROM TransactionIndex" + , "INNER JOIN BlockHistory USING (blockheight)" + , "WHERE txhash IN (" <> params <> ")" <> " AND blockheight <= ?;" + ] qvals -- match query params above. first, hashes = map (\(TypedHash h) -> SBlob $ BS.fromShort h) hss diff --git a/src/Chainweb/Rosetta/Internal.hs b/src/Chainweb/Rosetta/Internal.hs index 48a7a88c5e..00de8a2aec 100644 --- a/src/Chainweb/Rosetta/Internal.hs +++ b/src/Chainweb/Rosetta/Internal.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -24,7 +25,11 @@ import Control.Monad.Except (throwError) import Control.Monad.IO.Class import Control.Monad.Trans.Except import Data.Map (Map) +#if MIN_VERSION_base(4,20,0) +import Data.List (find) +#else import Data.List (foldl', find) +#endif import Data.Default (def) import Data.Decimal import Data.Word (Word64) diff --git a/src/Chainweb/Rosetta/Utils.hs b/src/Chainweb/Rosetta/Utils.hs index 5aaf84e3f6..ebf777c20f 100644 --- a/src/Chainweb/Rosetta/Utils.hs +++ b/src/Chainweb/Rosetta/Utils.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} @@ -19,7 +20,9 @@ import Data.Aeson import Data.Aeson.Types (Pair) import qualified Data.Aeson.KeyMap as KM import Data.Bifunctor (first) +#if !MIN_VERSION_base(4,20,0) import Data.Foldable (foldl') +#endif import Data.Decimal ( Decimal, DecimalRaw(Decimal) ) import Data.Hashable (Hashable(..)) import Data.List (sortOn, inits) diff --git a/src/Chainweb/Utils.hs b/src/Chainweb/Utils.hs index 1f58ea1e85..a274191420 100644 --- a/src/Chainweb/Utils.hs +++ b/src/Chainweb/Utils.hs @@ -249,6 +249,7 @@ import qualified Data.ByteString.Builder as BB import qualified Data.ByteString.Lazy as BL import qualified Data.Csv as CSV import Data.Decimal +import Data.Default (def) import Data.Functor.Of import Data.Hashable import qualified Data.HashMap.Strict as HM @@ -1348,12 +1349,12 @@ manager micros = HTTP.newManager unsafeManager :: Int -> IO HTTP.Manager unsafeManager micros = HTTP.newTlsManagerWith $ setManagerRequestTimeout micros - $ HTTP.mkManagerSettings (HTTP.TLSSettingsSimple True True True) Nothing + $ HTTP.mkManagerSettings (HTTP.TLSSettingsSimple True True True def) Nothing unsafeManagerWithSettings :: (HTTP.ManagerSettings -> HTTP.ManagerSettings) -> IO HTTP.Manager unsafeManagerWithSettings settings = HTTP.newTlsManagerWith $ settings - $ HTTP.mkManagerSettings (HTTP.TLSSettingsSimple True True True) Nothing + $ HTTP.mkManagerSettings (HTTP.TLSSettingsSimple True True True def) Nothing setManagerRequestTimeout :: Int -> HTTP.ManagerSettings -> HTTP.ManagerSettings setManagerRequestTimeout micros settings = settings diff --git a/src/Numeric/Additive.hs b/src/Numeric/Additive.hs deleted file mode 100644 index 41234fa989..0000000000 --- a/src/Numeric/Additive.hs +++ /dev/null @@ -1,317 +0,0 @@ -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE ScopedTypeVariables #-} - --- | --- Module: Numeric.Additive --- Copyright: Copyright © 2018 Kadena LLC. --- License: MIT --- Maintainer: Lars Kuhtz --- Stability: experimental --- --- Haskell's @Num@ class doesn't support fine grained control --- over what arithmetic operations are defined for a type. --- Sometimes only some operations have a well defined semantics --- and @Num@ instances are notorious for including undefined/error --- values or unlawful workarounds. --- -module Numeric.Additive -( --- * Additive Semigroup - AdditiveSemigroup(..) -, AdditiveAbelianSemigroup -, (^+^) - --- * Additive Monoid -, AdditiveMonoid(..) -, AdditiveAbelianMonoid - --- * Additive Group -, AdditiveGroup(..) - --- * Additive Abelian Group -, AdditiveAbelianGroup -, (^-^) -) where - -import Data.DoubleWord -import Data.Int -import Data.Word - -import Numeric.Natural - --- -------------------------------------------------------------------------- -- --- | Additive Semigroup --- --- prop> (a `plus` b) `plus` c == a `plus` (b `plus` c) --- -class AdditiveSemigroup g where - plus :: g -> g -> g - -instance AdditiveSemigroup Integer where - plus = (+) - {-# INLINE plus #-} - -instance AdditiveSemigroup Rational where - plus = (+) - {-# INLINE plus #-} - -instance AdditiveSemigroup Natural where - plus = (+) - {-# INLINE plus #-} - -instance AdditiveSemigroup Int where - plus = (+) - {-# INLINE plus #-} - -instance AdditiveSemigroup Word where - plus = (+) - {-# INLINE plus #-} - -instance AdditiveSemigroup Word8 where - plus = (+) - {-# INLINE plus #-} - -instance AdditiveSemigroup Word16 where - plus = (+) - {-# INLINE plus #-} - -instance AdditiveSemigroup Word32 where - plus = (+) - {-# INLINE plus #-} - -instance AdditiveSemigroup Word64 where - plus = (+) - {-# INLINE plus #-} - -instance AdditiveSemigroup Word128 where - plus = (+) - {-# INLINE plus #-} - -instance AdditiveSemigroup Word256 where - plus = (+) - {-# INLINE plus #-} - -instance AdditiveSemigroup Int8 where - plus = (+) - {-# INLINE plus #-} - -instance AdditiveSemigroup Int16 where - plus = (+) - {-# INLINE plus #-} - -instance AdditiveSemigroup Int32 where - plus = (+) - {-# INLINE plus #-} - -instance AdditiveSemigroup Int64 where - plus = (+) - {-# INLINE plus #-} - --- -------------------------------------------------------------------------- -- --- | Additive Abelian Semigroup --- --- prop> a `plus` b == b `plus` a --- -class AdditiveSemigroup g => AdditiveAbelianSemigroup g - -instance AdditiveAbelianSemigroup Integer -instance AdditiveAbelianSemigroup Rational -instance AdditiveAbelianSemigroup Natural -instance AdditiveAbelianSemigroup Int -instance AdditiveAbelianSemigroup Int8 -instance AdditiveAbelianSemigroup Int16 -instance AdditiveAbelianSemigroup Int32 -instance AdditiveAbelianSemigroup Int64 -instance AdditiveAbelianSemigroup Word -instance AdditiveAbelianSemigroup Word8 -instance AdditiveAbelianSemigroup Word16 -instance AdditiveAbelianSemigroup Word32 -instance AdditiveAbelianSemigroup Word64 -instance AdditiveAbelianSemigroup Word128 -instance AdditiveAbelianSemigroup Word256 - -infixl 6 ^+^ -(^+^) :: AdditiveAbelianSemigroup g => g -> g -> g -(^+^) = plus -{-# INLINE (^+^) #-} - --- -------------------------------------------------------------------------- -- --- | Additive Monoid --- --- prop> a `plus` zero == a --- prop> zero `plus` a == a --- -class AdditiveSemigroup g => AdditiveMonoid g where - zero :: g - -instance AdditiveMonoid Integer where - zero = 0 - {-# INLINE zero #-} - -instance AdditiveMonoid Rational where - zero = 0 - {-# INLINE zero #-} - -instance AdditiveMonoid Natural where - zero = 0 - {-# INLINE zero #-} - -instance AdditiveMonoid Int where - zero = 0 - {-# INLINE zero #-} - -instance AdditiveMonoid Word where - zero = 0 - {-# INLINE zero #-} - -instance AdditiveMonoid Word8 where - zero = 0 - {-# INLINE zero #-} - -instance AdditiveMonoid Word16 where - zero = 0 - {-# INLINE zero #-} - -instance AdditiveMonoid Word32 where - zero = 0 - {-# INLINE zero #-} - -instance AdditiveMonoid Word64 where - zero = 0 - {-# INLINE zero #-} - -instance AdditiveMonoid Word128 where - zero = 0 - {-# INLINE zero #-} - -instance AdditiveMonoid Word256 where - zero = 0 - {-# INLINE zero #-} - -instance AdditiveMonoid Int8 where - zero = 0 - {-# INLINE zero #-} - -instance AdditiveMonoid Int16 where - zero = 0 - {-# INLINE zero #-} - -instance AdditiveMonoid Int32 where - zero = 0 - {-# INLINE zero #-} - -instance AdditiveMonoid Int64 where - zero = 0 - {-# INLINE zero #-} - -type AdditiveAbelianMonoid g = (AdditiveMonoid g, AdditiveAbelianSemigroup g) - --- -------------------------------------------------------------------------- -- --- | Additive Group --- --- prop> a `plus` inverse a == zero --- prop> inverse a `plus` a == zero --- -class AdditiveMonoid g => AdditiveGroup g where - invert :: g -> g - invert a = zero `minus` a - - minus :: g -> g -> g - minus a b = a `plus` invert b - - {-# MINIMAL invert | minus #-} - -instance AdditiveGroup Integer where - invert a = -a - minus = (-) - {-# INLINE invert #-} - {-# INLINE minus #-} - -instance AdditiveGroup Rational where - invert a = -a - minus = (-) - {-# INLINE invert #-} - {-# INLINE minus #-} - -instance AdditiveGroup Int where - invert a = -a - minus = (-) - {-# INLINE invert #-} - {-# INLINE minus #-} - -instance AdditiveGroup Word where - invert a = -a - minus = (-) - {-# INLINE invert #-} - {-# INLINE minus #-} - -instance AdditiveGroup Word8 where - invert a = -a - minus = (-) - {-# INLINE invert #-} - {-# INLINE minus #-} - -instance AdditiveGroup Word16 where - invert a = -a - minus = (-) - {-# INLINE invert #-} - {-# INLINE minus #-} - -instance AdditiveGroup Word32 where - invert a = -a - minus = (-) - {-# INLINE invert #-} - {-# INLINE minus #-} - -instance AdditiveGroup Word64 where - invert a = -a - minus = (-) - {-# INLINE invert #-} - {-# INLINE minus #-} - -instance AdditiveGroup Word128 where - invert a = -a - minus = (-) - {-# INLINE invert #-} - {-# INLINE minus #-} - -instance AdditiveGroup Word256 where - invert a = -a - minus = (-) - {-# INLINE invert #-} - {-# INLINE minus #-} - -instance AdditiveGroup Int8 where - invert a = -a - minus = (-) - {-# INLINE invert #-} - {-# INLINE minus #-} - -instance AdditiveGroup Int16 where - invert a = -a - minus = (-) - {-# INLINE invert #-} - {-# INLINE minus #-} - -instance AdditiveGroup Int32 where - invert a = -a - minus = (-) - {-# INLINE invert #-} - {-# INLINE minus #-} - -instance AdditiveGroup Int64 where - invert a = -a - minus = (-) - {-# INLINE invert #-} - {-# INLINE minus #-} - --- -------------------------------------------------------------------------- -- --- | Additive Abelian Group --- -type AdditiveAbelianGroup g = (AdditiveGroup g, AdditiveAbelianMonoid g) - -infix 6 ^-^ -(^-^) :: AdditiveAbelianGroup g => g -> g -> g -(^-^) = minus -{-# INLINE (^-^) #-} diff --git a/src/Numeric/AffineSpace.hs b/src/Numeric/AffineSpace.hs deleted file mode 100644 index 7d95e77c81..0000000000 --- a/src/Numeric/AffineSpace.hs +++ /dev/null @@ -1,110 +0,0 @@ -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} - --- | --- Module: Numeric.AffineSpace --- Copyright: Copyright © 2018 Kadena LLC. --- License: MIT --- Maintainer: Lars Kuhtz --- Stability: experimental --- -module Numeric.AffineSpace -( --- * Torsor - LeftTorsor(..) -, (.+^) -, (^+.) -, (.-.) -, (.-^) - --- * Vector Space -, FractionalVectorSpace(..) - --- * AfficeSpace -, AffineSpace -) where - -import Numeric.Additive - --- -------------------------------------------------------------------------- -- --- Torsor - --- | A torsor is a generalization of affine spaces. It doesn't require the --- underlying structure to be vector space, but an additive group suffices. --- This means that it doesn't support scalar multiplication. In particular --- it doesn't require an inverse operation to multiplication, which would --- add unneeded complexity to the formal definition of the operational --- semantics. --- --- A Torsor is also called principal homogeous space. --- --- prop> zero `add` a == a --- prop> (a `plus` b) `add` t == a `add` (b `add` t) --- prop> (s `diff` t) `add` t == s --- --- The last property is states that `add` is a bijection. --- -class (AdditiveGroup (Diff t)) => LeftTorsor t where - type Diff t - add :: Diff t -> t -> t - diff :: t -> t -> Diff t - -instance LeftTorsor Integer where - type Diff Integer = Integer - add = (+) - diff = (-) - {-# INLINE add #-} - {-# INLINE diff #-} - -instance LeftTorsor Rational where - type Diff Rational = Rational - add = (+) - diff = (-) - {-# INLINE add #-} - {-# INLINE diff #-} - -infix 6 .-. -(.-.) :: AdditiveAbelianGroup (Diff t) => LeftTorsor t => t -> t -> Diff t -(.-.) = diff - -infixl 6 ^+. -(^+.) :: AdditiveAbelianGroup (Diff t) => LeftTorsor t => Diff t -> t -> t -(^+.) = add - -infixl 6 .+^ -(.+^) :: AdditiveAbelianGroup (Diff t) => LeftTorsor t => t -> Diff t -> t -(.+^) = flip add - -infixl 6 .-^ -(.-^) :: AdditiveAbelianGroup (Diff t) => LeftTorsor t => t -> Diff t -> t -(.-^) t d = t .+^ invert d - --- -------------------------------------------------------------------------- -- --- | Vector Space over Fractional Numbers --- --- A real vector space is an additive abelian group that forms an module --- with the field of real numbers. --- --- prop> a * (b `scale` c) == (a * b) `scale` c --- prop> 1 `scale` a == a --- prop> a `scale` (b `plus` c) == (a `scale` b) `plus` (a `scale` c) --- prop> (a + b) `scale` c == (a `scale` c) `plus` (b `scale` c) --- -class (AdditiveAbelianGroup v, Fractional (Scalar v)) => FractionalVectorSpace v where - type Scalar v - scale :: Scalar v -> v -> v - -instance FractionalVectorSpace Rational where - type Scalar Rational = Rational - scale = (*) - --- -------------------------------------------------------------------------- -- --- Affine Space - --- | An affine space is a torsor for the action of the additive group --- of a vector space. --- -type AffineSpace t = (FractionalVectorSpace (Diff t), LeftTorsor t) diff --git a/src/P2P/Node/PeerDB.hs b/src/P2P/Node/PeerDB.hs index 6ad8a83575..12e677d0b8 100644 --- a/src/P2P/Node/PeerDB.hs +++ b/src/P2P/Node/PeerDB.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} @@ -85,7 +86,9 @@ import Control.Monad.STM import Data.Aeson import Data.Bits +#if !MIN_VERSION_base(4,20,0) import Data.Foldable (foldl') +#endif import qualified Data.Foldable as F import Data.Hashable import Data.IxSet.Typed diff --git a/test/Chainweb/Test/Pact/PactMultiChainTest.hs b/test/Chainweb/Test/Pact/PactMultiChainTest.hs index c85998ad07..0fdf0ff235 100644 --- a/test/Chainweb/Test/Pact/PactMultiChainTest.hs +++ b/test/Chainweb/Test/Pact/PactMultiChainTest.hs @@ -197,7 +197,11 @@ txTimeoutTest = do ] chid <- view menvChainId - mempoolBadlistRef <- setPactMempool $ PactMempool $ List.singleton $ blockForChain chid $ MempoolBlock $ \_ -> pure pts + mempoolBadlistRef <- setPactMempool + $ PactMempool + $ List.singleton + $ blockForChain chid + $ MempoolBlock $ \_ -> pure pts blockBefore <- currentCut <&> (^?! (cutMap . ix chid)) diff --git a/test/Chainweb/Test/Pact/PactSingleChainTest.hs b/test/Chainweb/Test/Pact/PactSingleChainTest.hs index fa30444f25..e40cdba8e7 100644 --- a/test/Chainweb/Test/Pact/PactSingleChainTest.hs +++ b/test/Chainweb/Test/Pact/PactSingleChainTest.hs @@ -1049,37 +1049,41 @@ goldenNewBlock name mpIO mpRefIO reqIO = golden name $ do assertSatisfies ("golden tx succeeds, input: " ++ show txIn) (_crResult cr) (isRight . (\(PactResult r) -> r)) goldenBytes resp blockInProgress 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 {..} = object - [ "pendingData" .= - let SQLitePendingData{..} = _blockInProgressPendingData - in object - [ "pendingTableCreation" .= - (T.decodeUtf8 <$> toList _pendingTableCreation) - , "pendingWrites" .= HM.fromList - [ (T.decodeUtf8 _dkTable, HM.fromList - [ (T.decodeUtf8 _dkRowKey, HM.fromList - [ (fromIntegral @TxId @Word _deltaTxId, T.decodeUtf8 _deltaData) - | SQLiteRowDelta {..} <- toList rowKeyWrites - ]) - | (_dkRowKey, rowKeyWrites) <- hmToSortedList tableWrites - ]) - | (_dkTable, tableWrites) <- hmToSortedList _pendingWrites - ] - , "pendingSuccessfulTxs" .= - (encodeB64UrlNoPaddingText <$> toList _pendingSuccessfulTxs) - ] - , "txId" .= fromIntegral @TxId @Word _blockInProgressTxId - , "blockGasLimit" .= fromIntegral @GasLimit @Int _blockInProgressRemainingGasLimit - , "parentHeader" .= _parentHeader _blockInProgressParentHeader + + blockInProgressToJSON BlockInProgress {..} = J.object + [ "blockGasLimit" J..= J.Aeson (fromIntegral @_ @Int _blockInProgressRemainingGasLimit) + , "parentHeader" J..= J.encodeWithAeson (_parentHeader _blockInProgressParentHeader) + , "pendingData" J..= J.object + [ "pendingSuccessfulTxs" J..= J.array + (encodeB64UrlNoPaddingText <$> List.sort (toList _pendingSuccessfulTxs)) + , "pendingTableCreation" J..= J.array + (T.decodeUtf8 <$> List.sort (toList _pendingTableCreation)) + , "pendingWrites" J..= pendingWritesJson + ] + , "txId" J..= J.Aeson (fromIntegral @_ @Int _blockInProgressTxId) ] + where + SQLitePendingData{..} = _blockInProgressPendingData + pendingWritesJson = J.Object + [ (T.decodeUtf8 _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 -> IO BL.ByteString - goldenBytes a b = return $ BL.fromStrict $ encodeYaml $ object - [ "test-group" .= ("new-block" :: T.Text) - , "results" .= a - , "blockInProgress" .= blockInProgressToJSON b + 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 diff --git a/test/Chainweb/Test/Pact/SQLite.hs b/test/Chainweb/Test/Pact/SQLite.hs index e10cdf6d32..0c6877712b 100644 --- a/test/Chainweb/Test/Pact/SQLite.hs +++ b/test/Chainweb/Test/Pact/SQLite.hs @@ -280,7 +280,7 @@ testAgg n dbVarIO tblIO = do 512 -> hashToByteString <$> SHA3.hashByteString @SHA3.Sha3_512 b _ -> error $ "unsupported SHA3 digest size: " <> show d -hashToByteString :: (SHA3.Hash a, Coercible a BS.ShortByteString) => a -> B.ByteString +hashToByteString :: SHA3.Hash a => Coercible a BS.ShortByteString => a -> B.ByteString hashToByteString = BS.fromShort . coerce -- -------------------------------------------------------------------------- -- diff --git a/test/Chainweb/Test/Rosetta/RestAPI.hs b/test/Chainweb/Test/Rosetta/RestAPI.hs index 1c6c46ffd1..f4a4bd8b58 100644 --- a/test/Chainweb/Test/Rosetta/RestAPI.hs +++ b/test/Chainweb/Test/Rosetta/RestAPI.hs @@ -217,20 +217,35 @@ blockTransactionTests tio envIo = step "send in block tx request" resp <- blockTransaction v cenv req - (fundtx,cred,deb,redeem,reward) <- + (fundtx,deb,cred,redeem,reward) <- case _transaction_operations $ _blockTransactionResp_transaction resp of [a,b,c,d,e] -> return (a,b,c,d,e) _ -> assertFailure "transfer should have resulted in 5 transactions" + -- The order in which operations are returned is flaky and may break. Use + -- the following to double check the order in case this test fails. + -- + -- print "fundtx: ----------------------" + -- print fundtx + -- print "cred: ----------------------" + -- print cred + -- print "deb: ----------------------" + -- print deb + -- print "redeem: ----------------------" + -- print redeem + -- print "reward: ----------------------" + -- print reward + -- print "----------------------" + step "validate initial gas buy at op index 0" validateOp 0 "FundTx" sender00ks Successful (negate defFundGas) fundtx - step "validate sender01 credit at op index 1" - validateOp 1 "TransferOrCreateAcct" sender01ks Successful 1.0 cred + step "validate sender00 debit at op index 1" + validateOp 1 "TransferOrCreateAcct" sender00ks Successful (negate 1.0) deb - step "validate sender00 debit at op index 2" - validateOp 2 "TransferOrCreateAcct" sender00ks Successful (negate 1.0) deb + step "validate sender01 credit at op index 2" + validateOp 2 "TransferOrCreateAcct" sender01ks Successful 1.0 cred step "validate sender00 gas redemption at op index 3" validateOp 3 "GasPayment" sender00ks Successful (defFundGas - transferGasCost) redeem @@ -295,7 +310,21 @@ blockTests testname tio envIo = testCaseSteps testname $ \step -> do validateBlock $ _blockResp_block resp - validateTxs remeds cbase fundtx cred deb gasRedeem gasReward = do + validateTxs remeds cbase fundtx deb cred gasRedeem gasReward = do + -- The order in which operations are returned is flaky and may break. Use + -- the following to double check the order in case this test fails. + -- + -- step $ "fundtx: ----------------------" + -- step $ debugShowOperation fundtx + -- step $ "deb: ----------------------" + -- step $ debugShowOperation deb + -- step $ "cred: ----------------------" + -- step $ debugShowOperation cred + -- step $ "redeem: ----------------------" + -- step $ debugShowOperation gasRedeem + -- step $ "reward: ----------------------" + -- step $ debugShowOperation gasReward + -- step $ "----------------------" -- coinbase is considered a separate tx list validateOp 0 "CoinbaseReward" noMinerks Successful defMiningReward cbase @@ -307,8 +336,8 @@ blockTests testname tio envIo = testCaseSteps testname $ \step -> do -- rest txs (i.e. transfer transaction) validateOp 0 "FundTx" sender00ks Successful (negate defFundGas) fundtx - validateOp 1 "TransferOrCreateAcct" sender01ks Successful 1.0 cred - validateOp 2 "TransferOrCreateAcct" sender00ks Successful (negate 1.0) deb + validateOp 1 "TransferOrCreateAcct" sender00ks Successful (negate 1.0) deb + validateOp 2 "TransferOrCreateAcct" sender01ks Successful 1.0 cred validateOp 3 "GasPayment" sender00ks Successful (defFundGas - transferGasCost) gasRedeem validateOp 4 "GasPayment" noMinerks Successful transferGasCost gasReward diff --git a/test/Chainweb/Test/Utils.hs b/test/Chainweb/Test/Utils.hs index ad63307441..6318a9c52c 100644 --- a/test/Chainweb/Test/Utils.hs +++ b/test/Chainweb/Test/Utils.hs @@ -138,6 +138,7 @@ import Data.Bifunctor hiding (second) import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as BL import Data.Coerce (coerce) +import Data.Default (def) import Data.Foldable import qualified Data.HashMap.Strict as HashMap import Data.IORef @@ -1142,7 +1143,7 @@ getClientEnv :: BaseUrl -> IO ClientEnv getClientEnv url = flip mkClientEnv url <$> HTTP.newTlsManagerWith mgrSettings where mgrSettings = HTTP.mkManagerSettings - (HTTP.TLSSettingsSimple True False False) + (HTTP.TLSSettingsSimple True False False def) Nothing -- | Backoff up to a constant 250ms, limiting to ~40s diff --git a/test/golden/new-block-0-expected.txt b/test/golden/new-block-0-expected.txt index cb35aac103..21653a85df 100644 --- a/test/golden/new-block-0-expected.txt +++ b/test/golden/new-block-0-expected.txt @@ -4,16 +4,16 @@ blockInProgress: pendingData: pendingSuccessfulTxs: - IkPz8x9v7U-0jNuzXMq3S9Z_T4L6qWaM_yRqO7Q1_bo - - w2xTGIy73x8XLCGhRWrrwYeyMdaMuL-s9jPO_xS3r8k - - _Rjy1AmV6r_jJhJ3xwNK1n5CDzUxBt0dT903-H7IJC0 - - pzJND8MS-U_R7v7OD-wZlOSN9GAd9Z-Q-Fei-f8CH9U - - 82x3O9lcDlxUYGaNBXK-bFodlv-6USQTjQQQtRbnqKU - K8beZ4jwOfRVUygjpQnb4q87av-uJh53pDQRXENgvL8 - - ygR88vxqgLcv5hhuJsp3S1QQlfui-CMd9YdXc04gQdc + - URqS0A3IjJzk___9dA75TI1FMX78BVyRWImqr1S19Jo - esf2SuRiWmWGkSNEnsxkLVDxPBUmZfQcLRMVCy9Ef_s - nJr1AEl0cHqrNLByEWLFnsVfWg_6vBOKiKW-yfq5mwo - - URqS0A3IjJzk___9dA75TI1FMX78BVyRWImqr1S19Jo - pEjgUKleRXqqo-wk3KO0VxcRqX9VknkFBbhOBw_eCsw + - pzJND8MS-U_R7v7OD-wZlOSN9GAd9Z-Q-Fei-f8CH9U + - w2xTGIy73x8XLCGhRWrrwYeyMdaMuL-s9jPO_xS3r8k + - ygR88vxqgLcv5hhuJsp3S1QQlfui-CMd9YdXc04gQdc + - 82x3O9lcDlxUYGaNBXK-bFodlv-6USQTjQQQtRbnqKU + - _Rjy1AmV6r_jJhJ3xwNK1n5CDzUxBt0dT903-H7IJC0 pendingTableCreation: - free.test1_accounts pendingWrites: diff --git a/tools/cwtool/TxSimulator.hs b/tools/cwtool/TxSimulator.hs index a500fc7238..e3d750a1f2 100644 --- a/tools/cwtool/TxSimulator.hs +++ b/tools/cwtool/TxSimulator.hs @@ -270,7 +270,7 @@ setupClient :: SimConfig -> IO ClientEnv setupClient sc = flip mkClientEnv (scApiHostUrl sc) <$> newTlsManagerWith mgrSettings where mgrSettings = mkManagerSettings - (TLSSettingsSimple True False False) + (TLSSettingsSimple True False False def) Nothing -- | note, fetches [low - 1, hi] to have parent headers