diff --git a/CHANGELOG.md b/CHANGELOG.md index 3da610e603..9a78c12a81 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -6,3 +6,5 @@ This project contains multiple packages. Their changelogs are listed and linked - [sop-extras/CHANGELOG.md](./sop-extras/CHANGELOG.md) - [strict-sop-core/CHANGELOG.md](./strict-sop-core/CHANGELOG.md) - [ouroboros-consensus-protocol/CHANGELOG.md](./ouroboros-consensus-protocol/CHANGELOG.md) +- [resource-registry/CHANGELOG.md](./resource-registry/CHANGELOG.md) +- [nf-vars/CHANGELOG.md](./nf-vars/CHANGELOG.md) diff --git a/README.md b/README.md index 88f41084a1..baafb2d707 100644 --- a/README.md +++ b/README.md @@ -6,6 +6,9 @@ [![cardano](https://img.shields.io/badge/ouroboros--consensus--cardano-0.18.0.0-blue)](https://chap.intersectmbo.org/package/ouroboros-consensus-cardano-0.18.0.0/) [![sop-extras](https://img.shields.io/badge/sop--extras-0.2.0.0-blue)](https://chap.intersectmbo.org/package/sop-extras-0.2.0.0/) [![strict-sop-core](https://img.shields.io/badge/strict--sop--core-0.1.1.0-blue)](https://chap.intersectmbo.org/package/strict-sop-core-0.1.1.0/) +[![resource-registry](https://img.shields.io/badge/resource--registry-0.1.0.0-blue)](https://chap.intersectmbo.org/package/resource-registry-0.1.0.0/) +[![nf-vars](https://img.shields.io/badge/nf--vars-0.1.0.0-blue)](https://chap.intersectmbo.org/package/nf-vars-0.1.0.0/) + [![docs](https://img.shields.io/badge/Documentation-yellow)][webpage] @@ -24,6 +27,12 @@ flowchart TD B --> C[ouroboros-consensus] ``` +Some other supporting libraries are provided, namely: +- `strict-sop-core` +- `sop-extras` +- `resource-registry` +- `nf-vars` + The packages contain many test-suites that complicate the dependency graph as they create new depencency arcs. diff --git a/cabal.project b/cabal.project index 8f33510928..6dfb1a574a 100644 --- a/cabal.project +++ b/cabal.project @@ -19,6 +19,8 @@ index-state: , cardano-haskell-packages 2024-07-24T06:25:44Z packages: + nf-vars + resource-registry ouroboros-consensus ouroboros-consensus-cardano ouroboros-consensus-protocol diff --git a/nf-vars/CHANGELOG.md b/nf-vars/CHANGELOG.md new file mode 100644 index 0000000000..1839497f97 --- /dev/null +++ b/nf-vars/CHANGELOG.md @@ -0,0 +1,8 @@ +# nf-vars Changelog + +# Changelog entries + + +## 0.1.0.0 — 2024-06-21 + +- First release, extracted from `ouroboros-consensus`. diff --git a/nf-vars/LICENSE b/nf-vars/LICENSE new file mode 100644 index 0000000000..d645695673 --- /dev/null +++ b/nf-vars/LICENSE @@ -0,0 +1,202 @@ + + Apache License + Version 2.0, January 2004 + http://www.apache.org/licenses/ + + TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION + + 1. Definitions. + + "License" shall mean the terms and conditions for use, reproduction, + and distribution as defined by Sections 1 through 9 of this document. + + "Licensor" shall mean the copyright owner or entity authorized by + the copyright owner that is granting the License. + + "Legal Entity" shall mean the union of the acting entity and all + other entities that control, are controlled by, or are under common + control with that entity. For the purposes of this definition, + "control" means (i) the power, direct or indirect, to cause the + direction or management of such entity, whether by contract or + otherwise, or (ii) ownership of fifty percent (50%) or more of the + outstanding shares, or (iii) beneficial ownership of such entity. + + "You" (or "Your") shall mean an individual or Legal Entity + exercising permissions granted by this License. + + "Source" form shall mean the preferred form for making modifications, + including but not limited to software source code, documentation + source, and configuration files. + + "Object" form shall mean any form resulting from mechanical + transformation or translation of a Source form, including but + not limited to compiled object code, generated documentation, + and conversions to other media types. + + "Work" shall mean the work of authorship, whether in Source or + Object form, made available under the License, as indicated by a + copyright notice that is included in or attached to the work + (an example is provided in the Appendix below). + + "Derivative Works" shall mean any work, whether in Source or Object + form, that is based on (or derived from) the Work and for which the + editorial revisions, annotations, elaborations, or other modifications + represent, as a whole, an original work of authorship. For the purposes + of this License, Derivative Works shall not include works that remain + separable from, or merely link (or bind by name) to the interfaces of, + the Work and Derivative Works thereof. + + "Contribution" shall mean any work of authorship, including + the original version of the Work and any modifications or additions + to that Work or Derivative Works thereof, that is intentionally + submitted to Licensor for inclusion in the Work by the copyright owner + or by an individual or Legal Entity authorized to submit on behalf of + the copyright owner. For the purposes of this definition, "submitted" + means any form of electronic, verbal, or written communication sent + to the Licensor or its representatives, including but not limited to + communication on electronic mailing lists, source code control systems, + and issue tracking systems that are managed by, or on behalf of, the + Licensor for the purpose of discussing and improving the Work, but + excluding communication that is conspicuously marked or otherwise + designated in writing by the copyright owner as "Not a Contribution." + + "Contributor" shall mean Licensor and any individual or Legal Entity + on behalf of whom a Contribution has been received by Licensor and + subsequently incorporated within the Work. + + 2. Grant of Copyright License. Subject to the terms and conditions of + this License, each Contributor hereby grants to You a perpetual, + worldwide, non-exclusive, no-charge, royalty-free, irrevocable + copyright license to reproduce, prepare Derivative Works of, + publicly display, publicly perform, sublicense, and distribute the + Work and such Derivative Works in Source or Object form. + + 3. Grant of Patent License. Subject to the terms and conditions of + this License, each Contributor hereby grants to You a perpetual, + worldwide, non-exclusive, no-charge, royalty-free, irrevocable + (except as stated in this section) patent license to make, have made, + use, offer to sell, sell, import, and otherwise transfer the Work, + where such license applies only to those patent claims licensable + by such Contributor that are necessarily infringed by their + Contribution(s) alone or by combination of their Contribution(s) + with the Work to which such Contribution(s) was submitted. If You + institute patent litigation against any entity (including a + cross-claim or counterclaim in a lawsuit) alleging that the Work + or a Contribution incorporated within the Work constitutes direct + or contributory patent infringement, then any patent licenses + granted to You under this License for that Work shall terminate + as of the date such litigation is filed. + + 4. Redistribution. You may reproduce and distribute copies of the + Work or Derivative Works thereof in any medium, with or without + modifications, and in Source or Object form, provided that You + meet the following conditions: + + (a) You must give any other recipients of the Work or + Derivative Works a copy of this License; and + + (b) You must cause any modified files to carry prominent notices + stating that You changed the files; and + + (c) You must retain, in the Source form of any Derivative Works + that You distribute, all copyright, patent, trademark, and + attribution notices from the Source form of the Work, + excluding those notices that do not pertain to any part of + the Derivative Works; and + + (d) If the Work includes a "NOTICE" text file as part of its + distribution, then any Derivative Works that You distribute must + include a readable copy of the attribution notices contained + within such NOTICE file, excluding those notices that do not + pertain to any part of the Derivative Works, in at least one + of the following places: within a NOTICE text file distributed + as part of the Derivative Works; within the Source form or + documentation, if provided along with the Derivative Works; or, + within a display generated by the Derivative Works, if and + wherever such third-party notices normally appear. The contents + of the NOTICE file are for informational purposes only and + do not modify the License. You may add Your own attribution + notices within Derivative Works that You distribute, alongside + or as an addendum to the NOTICE text from the Work, provided + that such additional attribution notices cannot be construed + as modifying the License. + + You may add Your own copyright statement to Your modifications and + may provide additional or different license terms and conditions + for use, reproduction, or distribution of Your modifications, or + for any such Derivative Works as a whole, provided Your use, + reproduction, and distribution of the Work otherwise complies with + the conditions stated in this License. + + 5. Submission of Contributions. Unless You explicitly state otherwise, + any Contribution intentionally submitted for inclusion in the Work + by You to the Licensor shall be under the terms and conditions of + this License, without any additional terms or conditions. + Notwithstanding the above, nothing herein shall supersede or modify + the terms of any separate license agreement you may have executed + with Licensor regarding such Contributions. + + 6. Trademarks. This License does not grant permission to use the trade + names, trademarks, service marks, or product names of the Licensor, + except as required for reasonable and customary use in describing the + origin of the Work and reproducing the content of the NOTICE file. + + 7. Disclaimer of Warranty. Unless required by applicable law or + agreed to in writing, Licensor provides the Work (and each + Contributor provides its Contributions) on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or + implied, including, without limitation, any warranties or conditions + of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A + PARTICULAR PURPOSE. You are solely responsible for determining the + appropriateness of using or redistributing the Work and assume any + risks associated with Your exercise of permissions under this License. + + 8. Limitation of Liability. In no event and under no legal theory, + whether in tort (including negligence), contract, or otherwise, + unless required by applicable law (such as deliberate and grossly + negligent acts) or agreed to in writing, shall any Contributor be + liable to You for damages, including any direct, indirect, special, + incidental, or consequential damages of any character arising as a + result of this License or out of the use or inability to use the + Work (including but not limited to damages for loss of goodwill, + work stoppage, computer failure or malfunction, or any and all + other commercial damages or losses), even if such Contributor + has been advised of the possibility of such damages. + + 9. Accepting Warranty or Additional Liability. While redistributing + the Work or Derivative Works thereof, You may choose to offer, + and charge a fee for, acceptance of support, warranty, indemnity, + or other liability obligations and/or rights consistent with this + License. However, in accepting such obligations, You may act only + on Your own behalf and on Your sole responsibility, not on behalf + of any other Contributor, and only if You agree to indemnify, + defend, and hold each Contributor harmless for any liability + incurred by, or claims asserted against, such Contributor by reason + of your accepting any such warranty or additional liability. + + END OF TERMS AND CONDITIONS + + APPENDIX: How to apply the Apache License to your work. + + To apply the Apache License to your work, attach the following + boilerplate notice, with the fields enclosed by brackets "[]" + replaced with your own identifying information. (Don't include + the brackets!) The text should be enclosed in the appropriate + comment syntax for the file format. We also recommend that a + file or class name and description of purpose be included on the + same "printed page" as the copyright notice for easier + identification within third-party archives. + + Copyright [yyyy] [name of copyright owner] + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. diff --git a/nf-vars/nf-vars.cabal b/nf-vars/nf-vars.cabal new file mode 100644 index 0000000000..8fcc4e951d --- /dev/null +++ b/nf-vars/nf-vars.cabal @@ -0,0 +1,75 @@ +cabal-version: 3.0 +name: nf-vars +version: 0.1.0.0 +synopsis: @strict-checked-vars@ with @NoThunks@ invariants +description: @strict-checked-vars@ with @NoThunks@ invariants. +license: Apache-2.0 +license-file: LICENSE +author: IOG Engineering Team +maintainer: hackage@iohk.io +copyright: + 2019-2023 Input Output Global Inc (IOG) + 2023-2024 INTERSECT + 2024 Input Output Global Inc (IOG) + +category: Data +build-type: Simple +extra-doc-files: CHANGELOG.md + +common common-lib + default-language: Haskell2010 + ghc-options: + -Wall + -Wcompat + -Wincomplete-uni-patterns + -Wincomplete-record-updates + -Wpartial-fields + -Widentities + -Wredundant-constraints + -Wmissing-export-lists + -Wunused-packages + -Wno-unticked-promoted-constructors + +common common-test + import: common-lib + ghc-options: + -threaded + -rtsopts + +library + import: common-lib + exposed-modules: + Control.Concurrent.Class.MonadMVar.NormalForm + Control.Concurrent.Class.MonadSTM.NormalForm + Control.Concurrent.Class.MonadSTM.NormalForm.SVar + Control.Concurrent.Class.MonadSTM.NormalForm.TVar + Control.Concurrent.Class.MonadSTM.Strict.SVar + + other-modules: + NoThunks.Invariant + + build-depends: + base >=4.14 && <4.21, + io-classes ^>=1.5, + nothunks ^>=0.1.5, + strict-checked-vars ^>=0.2, + strict-stm ^>=1.5, + + hs-source-dirs: src + default-language: Haskell2010 + +test-suite tests + import: common-test + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Main.hs + build-depends: + base, + io-classes, + io-sim, + nf-vars, + nothunks, + tasty, + tasty-quickcheck, + + default-language: Haskell2010 diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util/NormalForm/StrictMVar.hs b/nf-vars/src/Control/Concurrent/Class/MonadMVar/NormalForm.hs similarity index 90% rename from ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util/NormalForm/StrictMVar.hs rename to nf-vars/src/Control/Concurrent/Class/MonadMVar/NormalForm.hs index eca85640d6..45a8110cb3 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util/NormalForm/StrictMVar.hs +++ b/nf-vars/src/Control/Concurrent/Class/MonadMVar/NormalForm.hs @@ -14,7 +14,7 @@ -- The exports of this module (should) mirror the exports of the -- "Control.Concurrent.Class.MonadMVar.Strict.Checked" module from the -- @strict-checked-vars@ package. -module Ouroboros.Consensus.Util.NormalForm.StrictMVar ( +module Control.Concurrent.Class.MonadMVar.NormalForm ( -- * StrictMVar newEmptyMVar , newEmptyMVarWithInvariant @@ -36,7 +36,8 @@ import Control.Concurrent.Class.MonadMVar.Strict.Checked hiding import qualified Control.Concurrent.Class.MonadMVar.Strict.Checked as Checked import Data.Proxy (Proxy (..)) import GHC.Stack (HasCallStack) -import NoThunks.Class (NoThunks (..), unsafeNoThunks) +import NoThunks.Class (NoThunks (..)) +import NoThunks.Invariant {------------------------------------------------------------------------------- StrictMVar @@ -74,13 +75,6 @@ newEmptyMVarWithInvariant :: newEmptyMVarWithInvariant inv = Checked.newEmptyMVarWithInvariant (\x -> inv x <> noThunksInvariant x) -{------------------------------------------------------------------------------- - Invariant --------------------------------------------------------------------------------} - -noThunksInvariant :: NoThunks a => a -> Maybe String -noThunksInvariant = fmap show . unsafeNoThunks - {------------------------------------------------------------------------------- NoThunks instance -------------------------------------------------------------------------------} diff --git a/nf-vars/src/Control/Concurrent/Class/MonadSTM/NormalForm.hs b/nf-vars/src/Control/Concurrent/Class/MonadSTM/NormalForm.hs new file mode 100644 index 0000000000..69583c869c --- /dev/null +++ b/nf-vars/src/Control/Concurrent/Class/MonadSTM/NormalForm.hs @@ -0,0 +1,13 @@ +module Control.Concurrent.Class.MonadSTM.NormalForm ( + module Control.Concurrent.Class.MonadSTM.NormalForm.SVar + , module Control.Concurrent.Class.MonadSTM.NormalForm.TVar + , module Control.Concurrent.Class.MonadSTM.Strict.TBQueue + , module Control.Concurrent.Class.MonadSTM.Strict.TMVar + , module Control.Concurrent.Class.MonadSTM.Strict.TQueue + ) where + +import Control.Concurrent.Class.MonadSTM.NormalForm.SVar +import Control.Concurrent.Class.MonadSTM.NormalForm.TVar +import Control.Concurrent.Class.MonadSTM.Strict.TBQueue +import Control.Concurrent.Class.MonadSTM.Strict.TMVar +import Control.Concurrent.Class.MonadSTM.Strict.TQueue diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util/MonadSTM/NormalForm.hs b/nf-vars/src/Control/Concurrent/Class/MonadSTM/NormalForm/SVar.hs similarity index 73% rename from ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util/MonadSTM/NormalForm.hs rename to nf-vars/src/Control/Concurrent/Class/MonadSTM/NormalForm/SVar.hs index d7593709f5..9185e43a7b 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util/MonadSTM/NormalForm.hs +++ b/nf-vars/src/Control/Concurrent/Class/MonadSTM/NormalForm/SVar.hs @@ -1,7 +1,5 @@ -module Ouroboros.Consensus.Util.MonadSTM.NormalForm ( - module LazySTM - , module Ouroboros.Consensus.Util.MonadSTM.StrictSVar - , module StrictSTM +module Control.Concurrent.Class.MonadSTM.NormalForm.SVar ( + module Control.Concurrent.Class.MonadSTM.Strict.SVar , newEmptySVar , newSVar -- * Temporary @@ -9,18 +7,14 @@ module Ouroboros.Consensus.Util.MonadSTM.NormalForm ( , uncheckedNewSVar ) where -import Control.Concurrent.Class.MonadSTM.Strict.TMVar as StrictSTM hiding - (newTMVar, newTMVarIO, traceTMVar, traceTMVarIO) -import Control.Concurrent.Class.MonadSTM.TBQueue as LazySTM -import Control.Concurrent.Class.MonadSTM.TQueue as LazySTM +import Control.Concurrent.Class.MonadSTM.Strict.SVar hiding + (newEmptySVar, newEmptySVarWithInvariant, newSVar, + newSVarWithInvariant) +import qualified Control.Concurrent.Class.MonadSTM.Strict.SVar as Strict import Control.Monad.Class.MonadSTM as StrictSTM hiding (traceTVar, traceTVarIO) import GHC.Stack import NoThunks.Class (NoThunks (..), unsafeNoThunks) -import Ouroboros.Consensus.Util.MonadSTM.StrictSVar hiding - (newEmptySVar, newEmptySVarWithInvariant, newSVar, - newSVarWithInvariant) -import qualified Ouroboros.Consensus.Util.MonadSTM.StrictSVar as Strict -- TODO: use strict versions of 'TQueue' and 'TBQueue'. Previously the -- 'Control.Monad.Class.MonadSTM.Strict' was imported which diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util/NormalForm/StrictTVar.hs b/nf-vars/src/Control/Concurrent/Class/MonadSTM/NormalForm/TVar.hs similarity index 95% rename from ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util/NormalForm/StrictTVar.hs rename to nf-vars/src/Control/Concurrent/Class/MonadSTM/NormalForm/TVar.hs index d17be2215d..700c984542 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util/NormalForm/StrictTVar.hs +++ b/nf-vars/src/Control/Concurrent/Class/MonadSTM/NormalForm/TVar.hs @@ -14,7 +14,7 @@ -- The exports of this module (should) mirror the exports of the -- "Control.Concurrent.Class.MonadSTM.Strict.TVar.Checked" module from the -- @strict-checked-vars@ package. -module Ouroboros.Consensus.Util.NormalForm.StrictTVar ( +module Control.Concurrent.Class.MonadSTM.NormalForm.TVar ( -- * StrictTVar newTVar , newTVarIO @@ -35,8 +35,7 @@ import qualified Control.Concurrent.Class.MonadSTM.Strict.TVar.Checked as Checke import Control.Monad.Class.MonadSTM as StrictSTM import GHC.Stack import NoThunks.Class (NoThunks (..)) -import Ouroboros.Consensus.Util.NormalForm.StrictMVar - (noThunksInvariant) +import NoThunks.Invariant (noThunksInvariant) {------------------------------------------------------------------------------- StrictTVar diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util/MonadSTM/StrictSVar.hs b/nf-vars/src/Control/Concurrent/Class/MonadSTM/Strict/SVar.hs similarity index 99% rename from ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util/MonadSTM/StrictSVar.hs rename to nf-vars/src/Control/Concurrent/Class/MonadSTM/Strict/SVar.hs index 7b3d0065ec..2f42a8e3aa 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util/MonadSTM/StrictSVar.hs +++ b/nf-vars/src/Control/Concurrent/Class/MonadSTM/Strict/SVar.hs @@ -6,7 +6,7 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} -module Ouroboros.Consensus.Util.MonadSTM.StrictSVar ( +module Control.Concurrent.Class.MonadSTM.Strict.SVar ( castStrictSVar , isEmptySVar , modifySVar diff --git a/nf-vars/src/NoThunks/Invariant.hs b/nf-vars/src/NoThunks/Invariant.hs new file mode 100644 index 0000000000..e21029adf5 --- /dev/null +++ b/nf-vars/src/NoThunks/Invariant.hs @@ -0,0 +1,6 @@ +module NoThunks.Invariant (noThunksInvariant) where + +import NoThunks.Class + +noThunksInvariant :: NoThunks a => a -> Maybe String +noThunksInvariant = fmap show . unsafeNoThunks diff --git a/ouroboros-consensus/test/consensus-test/Test/Consensus/Util/MonadSTM/NormalForm.hs b/nf-vars/test/Main.hs similarity index 88% rename from ouroboros-consensus/test/consensus-test/Test/Consensus/Util/MonadSTM/NormalForm.hs rename to nf-vars/test/Main.hs index a10757f08e..4110b340f2 100644 --- a/ouroboros-consensus/test/consensus-test/Test/Consensus/Util/MonadSTM/NormalForm.hs +++ b/nf-vars/test/Main.hs @@ -4,16 +4,20 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE TypeApplications #-} -module Test.Consensus.Util.MonadSTM.NormalForm (tests) where +module Main (main) where +import Control.Concurrent.Class.MonadSTM (MonadSTM) +import Control.Concurrent.Class.MonadSTM.NormalForm (newSVar, + updateSVar) import Control.Monad.IOSim import GHC.Generics import NoThunks.Class -import Ouroboros.Consensus.Util.MonadSTM.NormalForm (MonadSTM, - newSVar, updateSVar) import Test.Tasty import Test.Tasty.QuickCheck +main :: IO () +main = defaultMain tests + -- Note that all of the tests here are only significant with compiler -- optimizations turned off! These tests ensure that the invariants are -- maintained when calling `updateMVar` on consensus' `StrictMVar` values @@ -23,7 +27,7 @@ import Test.Tasty.QuickCheck -- optimizations, these tests will *always* pass at -O1 or higher (at least on -- GHC 8.10 and GHC 9.2). tests :: TestTree -tests = testGroup "Ouroboros.Consensus.Util.MonadSTM.NormalForm" +tests = testGroup "Control.Concurrent.Class.MonadSTM.NormalForm" [ testGroup "updateSVar" [ testGroup "updateSVar strictness" [ testProperty "IO @Integer @String" diff --git a/ouroboros-consensus-cardano/changelog.d/20240823_175829_alexander.esgen_weeder.md b/ouroboros-consensus-cardano/changelog.d/20240823_175829_alexander.esgen_weeder.md new file mode 100644 index 0000000000..faedb8f559 --- /dev/null +++ b/ouroboros-consensus-cardano/changelog.d/20240823_175829_alexander.esgen_weeder.md @@ -0,0 +1,3 @@ +### Breaking + +- Removed `CommonProtocolParams` instances. diff --git a/ouroboros-consensus-cardano/changelog.d/weeder.md b/ouroboros-consensus-cardano/changelog.d/weeder.md new file mode 100644 index 0000000000..747a3c3dc8 --- /dev/null +++ b/ouroboros-consensus-cardano/changelog.d/weeder.md @@ -0,0 +1,3 @@ +### Breaking + +- Removed multiple unused functions thanks to `weeder`. diff --git a/ouroboros-consensus-cardano/ouroboros-consensus-cardano.cabal b/ouroboros-consensus-cardano/ouroboros-consensus-cardano.cabal index 50529efab5..ba1558f1dc 100644 --- a/ouroboros-consensus-cardano/ouroboros-consensus-cardano.cabal +++ b/ouroboros-consensus-cardano/ouroboros-consensus-cardano.cabal @@ -556,6 +556,7 @@ library unstable-cardano-tools ouroboros-network-api, ouroboros-network-framework ^>=0.13.2, ouroboros-network-protocols, + resource-registry ^>=0.1, serialise ^>=0.2, singletons, sop-core, diff --git a/ouroboros-consensus-cardano/src/byron/Ouroboros/Consensus/Byron/Ledger/Block.hs b/ouroboros-consensus-cardano/src/byron/Ouroboros/Consensus/Byron/Ledger/Block.hs index 77276257d2..cbba974f02 100644 --- a/ouroboros-consensus-cardano/src/byron/Ouroboros/Consensus/Byron/Ledger/Block.hs +++ b/ouroboros-consensus-cardano/src/byron/Ouroboros/Consensus/Byron/Ledger/Block.hs @@ -22,7 +22,6 @@ module Ouroboros.Consensus.Byron.Ledger.Block ( , mkByronHeader , mkRegularByronHeader -- * Dealing with EBBs - , byronBlockIsEBB , byronHeaderIsEBB , knownEBBs -- * Low-level API @@ -230,9 +229,6 @@ byronHeaderIsEBB = go . byronHeaderRaw go (CC.ABOBBlockHdr _) = IsNotEBB go (CC.ABOBBoundaryHdr _) = IsEBB -byronBlockIsEBB :: ByronBlock -> IsEBB -byronBlockIsEBB = byronHeaderIsEBB . getHeader - knownEBBs :: Map (HeaderHash ByronBlock) (ChainHash ByronBlock) knownEBBs = Map.fromList $ map aux EBBs.knownEBBs where diff --git a/ouroboros-consensus-cardano/src/byron/Ouroboros/Consensus/Byron/Ledger/Ledger.hs b/ouroboros-consensus-cardano/src/byron/Ouroboros/Consensus/Byron/Ledger/Ledger.hs index ac5062ceed..11c8683c56 100644 --- a/ouroboros-consensus-cardano/src/byron/Ouroboros/Consensus/Byron/Ledger/Ledger.hs +++ b/ouroboros-consensus-cardano/src/byron/Ouroboros/Consensus/Byron/Ledger/Ledger.hs @@ -28,8 +28,6 @@ module Ouroboros.Consensus.Byron.Ledger.Ledger ( , decodeByronQuery , decodeByronResult , encodeByronAnnTip - , encodeByronExtLedgerState - , encodeByronHeaderState , encodeByronLedgerState , encodeByronQuery , encodeByronResult @@ -77,7 +75,6 @@ import Ouroboros.Consensus.HardFork.Abstract import qualified Ouroboros.Consensus.HardFork.History as HardFork import Ouroboros.Consensus.HeaderValidation import Ouroboros.Consensus.Ledger.Abstract -import Ouroboros.Consensus.Ledger.CommonProtocolParams import Ouroboros.Consensus.Ledger.Extended import Ouroboros.Consensus.Ledger.Query import Ouroboros.Consensus.Ledger.SupportsPeerSelection @@ -218,17 +215,6 @@ instance ShowProxy (BlockQuery ByronBlock) where instance LedgerSupportsPeerSelection ByronBlock where getPeers = const [] -instance CommonProtocolParams ByronBlock where - maxHeaderSize = fromIntegral . Update.ppMaxHeaderSize . getProtocolParameters - maxTxSize = fromIntegral . Update.ppMaxTxSize . getProtocolParameters - --- | Return the protocol parameters adopted by the given ledger. -getProtocolParameters :: LedgerState ByronBlock -> Update.ProtocolParameters -getProtocolParameters = - CC.adoptedProtocolParameters - . CC.cvsUpdateState - . byronLedgerState - instance LedgerSupportsProtocol ByronBlock where protocolLedgerView _cfg = toPBftLedgerView @@ -346,7 +332,12 @@ applyABlock :: CC.ValidationMode -> BlockNo -> Ticked (LedgerState (ByronBlock)) -> Except (LedgerError ByronBlock) (LedgerState ByronBlock) -applyABlock validationMode cfg blk blkHash blkNo TickedByronLedgerState{..} = do +applyABlock validationMode cfg blk blkHash blkNo tls = do + let TickedByronLedgerState { + untickedByronLedgerTransition + , tickedByronLedgerState + } = tls + st' <- CC.validateBlock cfg validationMode blk blkHash tickedByronLedgerState let updState :: UPI.State @@ -404,17 +395,6 @@ encodeByronAnnTip = encodeAnnTipIsEBB encodeByronHeaderHash decodeByronAnnTip :: Decoder s (AnnTip ByronBlock) decodeByronAnnTip = decodeAnnTipIsEBB decodeByronHeaderHash -encodeByronExtLedgerState :: ExtLedgerState ByronBlock -> Encoding -encodeByronExtLedgerState = encodeExtLedgerState - encodeByronLedgerState - encodeByronChainDepState - encodeByronAnnTip - -encodeByronHeaderState :: HeaderState ByronBlock -> Encoding -encodeByronHeaderState = encodeHeaderState - encodeByronChainDepState - encodeByronAnnTip - -- | Encode transition info -- -- We encode the absence of any info separately. This gives us a bit more diff --git a/ouroboros-consensus-cardano/src/byron/Ouroboros/Consensus/Byron/Ledger/PBFT.hs b/ouroboros-consensus-cardano/src/byron/Ouroboros/Consensus/Byron/Ledger/PBFT.hs index 7dfc87b60f..36deb3229d 100644 --- a/ouroboros-consensus-cardano/src/byron/Ouroboros/Consensus/Byron/Ledger/PBFT.hs +++ b/ouroboros-consensus-cardano/src/byron/Ouroboros/Consensus/Byron/Ledger/PBFT.hs @@ -9,7 +9,6 @@ module Ouroboros.Consensus.Byron.Ledger.PBFT ( decodeByronChainDepState , encodeByronChainDepState - , fromPBftLedgerView , mkByronContextDSIGN , toPBftLedgerView ) where @@ -74,9 +73,6 @@ instance BlockSupportsProtocol ByronBlock where toPBftLedgerView :: Delegation.Map -> PBftLedgerView PBftByronCrypto toPBftLedgerView = PBftLedgerView . Delegation.unMap -fromPBftLedgerView :: PBftLedgerView PBftByronCrypto -> Delegation.Map -fromPBftLedgerView = Delegation.Map . pbftDelegates - encodeByronChainDepState :: ChainDepState (BlockProtocol ByronBlock) -> Encoding diff --git a/ouroboros-consensus-cardano/src/ouroboros-consensus-cardano/Ouroboros/Consensus/Cardano.hs b/ouroboros-consensus-cardano/src/ouroboros-consensus-cardano/Ouroboros/Consensus/Cardano.hs index 8c0f78f6d4..2ed8f0b760 100644 --- a/ouroboros-consensus-cardano/src/ouroboros-consensus-cardano/Ouroboros/Consensus/Cardano.hs +++ b/ouroboros-consensus-cardano/src/ouroboros-consensus-cardano/Ouroboros/Consensus/Cardano.hs @@ -4,9 +4,7 @@ module Ouroboros.Consensus.Cardano ( -- * The block type of the Cardano block chain CardanoBlock -- * Supported protocols - , ProtocolByron , ProtocolCardano - , ProtocolShelley -- * Abstract over the various protocols , CardanoHardForkTriggers (..) , ProtocolParams (..) @@ -22,7 +20,6 @@ import Ouroboros.Consensus.Protocol.Praos (Praos) import Ouroboros.Consensus.Protocol.TPraos (TPraos) import Ouroboros.Consensus.Shelley.Ledger import Ouroboros.Consensus.Shelley.Node as X -import Ouroboros.Consensus.Shelley.ShelleyHFC {------------------------------------------------------------------------------- Supported protocols @@ -33,7 +30,6 @@ import Ouroboros.Consensus.Shelley.ShelleyHFC breaking any assumptions made in @cardano-node@. -------------------------------------------------------------------------------} -type ProtocolByron = HardForkProtocol '[ ByronBlock ] type ProtocolCardano = HardForkProtocol '[ ByronBlock , ShelleyBlock (TPraos StandardCrypto) StandardShelley , ShelleyBlock (TPraos StandardCrypto) StandardAllegra diff --git a/ouroboros-consensus-cardano/src/ouroboros-consensus-cardano/Ouroboros/Consensus/Cardano/Block.hs b/ouroboros-consensus-cardano/src/ouroboros-consensus-cardano/Ouroboros/Consensus/Cardano/Block.hs index 08e9bae310..7e886309a9 100644 --- a/ouroboros-consensus-cardano/src/ouroboros-consensus-cardano/Ouroboros/Consensus/Cardano/Block.hs +++ b/ouroboros-consensus-cardano/src/ouroboros-consensus-cardano/Ouroboros/Consensus/Cardano/Block.hs @@ -4,7 +4,6 @@ {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE StandaloneKindSignatures #-} {-# LANGUAGE TypeOperators #-} -{-# LANGUAGE ViewPatterns #-} module Ouroboros.Consensus.Cardano.Block ( -- * Eras @@ -28,14 +27,14 @@ module Ouroboros.Consensus.Cardano.Block ( , CardanoGenTx , CardanoGenTxId , GenTx (GenTxAllegra, GenTxAlonzo, GenTxByron, GenTxMary, GenTxShelley, GenTxBabbage, GenTxConway) - , HardForkApplyTxErr (ApplyTxErrAllegra, ApplyTxErrAlonzo, ApplyTxErrByron, ApplyTxErrMary, ApplyTxErrShelley, ApplyTxErrWrongEra, ApplyTxErrBabbage, ApplyTxErrConway) + , HardForkApplyTxErr (ApplyTxErrAllegra, ApplyTxErrAlonzo, ApplyTxErrByron, ApplyTxErrMary, ApplyTxErrShelley, ApplyTxErrBabbage, ApplyTxErrConway) , TxId (GenTxIdAllegra, GenTxIdAlonzo, GenTxIdByron, GenTxIdMary, GenTxIdShelley, GenTxIdBabbage, GenTxIdConway) -- * LedgerError , CardanoLedgerError - , HardForkLedgerError (LedgerErrorAllegra, LedgerErrorAlonzo, LedgerErrorByron, LedgerErrorMary, LedgerErrorShelley, LedgerErrorWrongEra, LedgerErrorBabbage, LedgerErrorConway) + , HardForkLedgerError (LedgerErrorAllegra, LedgerErrorAlonzo, LedgerErrorByron, LedgerErrorMary, LedgerErrorShelley, LedgerErrorBabbage, LedgerErrorConway) -- * OtherEnvelopeError , CardanoOtherHeaderEnvelopeError - , HardForkEnvelopeErr (OtherHeaderEnvelopeErrorAllegra, OtherHeaderEnvelopeErrorBabbage, OtherHeaderEnvelopeErrorConway, OtherHeaderEnvelopeErrorAlonzo, OtherHeaderEnvelopeErrorByron, OtherHeaderEnvelopeErrorMary, OtherHeaderEnvelopeErrorShelley, OtherHeaderEnvelopeErrorWrongEra) + , HardForkEnvelopeErr (OtherHeaderEnvelopeErrorAllegra, OtherHeaderEnvelopeErrorBabbage, OtherHeaderEnvelopeErrorConway, OtherHeaderEnvelopeErrorAlonzo, OtherHeaderEnvelopeErrorByron, OtherHeaderEnvelopeErrorMary, OtherHeaderEnvelopeErrorShelley) -- * TipInfo , CardanoTipInfo , OneEraTipInfo (TipInfoAllegra, TipInfoAlonzo, TipInfoByron, TipInfoBabbage, TipInfoConway, TipInfoMary, TipInfoShelley) @@ -43,7 +42,7 @@ module Ouroboros.Consensus.Cardano.Block ( , BlockQuery (QueryAnytimeAllegra, QueryAnytimeAlonzo, QueryAnytimeBabbage, QueryAnytimeConway, QueryAnytimeByron, QueryAnytimeMary, QueryAnytimeShelley, QueryHardFork, QueryIfCurrentAllegra, QueryIfCurrentAlonzo, QueryIfCurrentBabbage, QueryIfCurrentConway, QueryIfCurrentByron, QueryIfCurrentMary, QueryIfCurrentShelley) , CardanoQuery , CardanoQueryResult - , Either (QueryResultSuccess, QueryResultEraMismatch) + , Either (QueryResultSuccess) -- * CodecConfig , CardanoCodecConfig , CodecConfig (CardanoCodecConfig) @@ -456,10 +455,6 @@ pattern ApplyTxErrConway :: pattern ApplyTxErrConway err = HardForkApplyTxErrFromEra (OneEraApplyTxErr (TagConway (WrapApplyTxErr err))) -pattern ApplyTxErrWrongEra :: EraMismatch -> CardanoApplyTxErr c -pattern ApplyTxErrWrongEra eraMismatch <- - HardForkApplyTxErrWrongEra (mkEraMismatch -> eraMismatch) - {-# COMPLETE ApplyTxErrByron , ApplyTxErrShelley , ApplyTxErrAllegra @@ -467,7 +462,6 @@ pattern ApplyTxErrWrongEra eraMismatch <- , ApplyTxErrAlonzo , ApplyTxErrBabbage , ApplyTxErrConway - , ApplyTxErrWrongEra #-} {------------------------------------------------------------------------------- @@ -538,10 +532,6 @@ pattern LedgerErrorConway err = HardForkLedgerErrorFromEra (OneEraLedgerError (TagConway (WrapLedgerErr err))) -pattern LedgerErrorWrongEra :: EraMismatch -> CardanoLedgerError c -pattern LedgerErrorWrongEra eraMismatch <- - HardForkLedgerErrorWrongEra (mkEraMismatch -> eraMismatch) - {-# COMPLETE LedgerErrorByron , LedgerErrorShelley , LedgerErrorAllegra @@ -549,7 +539,6 @@ pattern LedgerErrorWrongEra eraMismatch <- , LedgerErrorAlonzo , LedgerErrorBabbage , LedgerErrorConway - , LedgerErrorWrongEra #-} {------------------------------------------------------------------------------- @@ -602,12 +591,6 @@ pattern OtherHeaderEnvelopeErrorConway pattern OtherHeaderEnvelopeErrorConway err = HardForkEnvelopeErrFromEra (OneEraEnvelopeErr (TagConway (WrapEnvelopeErr err))) -pattern OtherHeaderEnvelopeErrorWrongEra - :: EraMismatch - -> CardanoOtherHeaderEnvelopeError c -pattern OtherHeaderEnvelopeErrorWrongEra eraMismatch <- - HardForkEnvelopeErrWrongEra (mkEraMismatch -> eraMismatch) - {-# COMPLETE OtherHeaderEnvelopeErrorByron , OtherHeaderEnvelopeErrorShelley , OtherHeaderEnvelopeErrorAllegra @@ -615,7 +598,6 @@ pattern OtherHeaderEnvelopeErrorWrongEra eraMismatch <- , OtherHeaderEnvelopeErrorAlonzo , OtherHeaderEnvelopeErrorBabbage , OtherHeaderEnvelopeErrorConway - , OtherHeaderEnvelopeErrorWrongEra #-} {------------------------------------------------------------------------------- @@ -857,11 +839,7 @@ type CardanoQueryResult c = HardForkQueryResult (CardanoEras c) pattern QueryResultSuccess :: result -> CardanoQueryResult c result pattern QueryResultSuccess result = Right result --- | A query from a different era than the ledger's era was sent. -pattern QueryResultEraMismatch :: EraMismatch -> CardanoQueryResult c result -pattern QueryResultEraMismatch eraMismatch <- Left (mkEraMismatch -> eraMismatch) - -{-# COMPLETE QueryResultSuccess, QueryResultEraMismatch #-} +{-# COMPLETE QueryResultSuccess #-} {------------------------------------------------------------------------------- CodecConfig diff --git a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Ledger.hs b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Ledger.hs index 68a114333c..7884b2d9d8 100644 --- a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Ledger.hs +++ b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Ledger.hs @@ -51,7 +51,7 @@ import qualified Cardano.Ledger.BaseTypes as SL (epochInfoPure) import qualified Cardano.Ledger.BHeaderView as SL (BHeaderView) import Cardano.Ledger.Binary.Plain (FromCBOR (..), ToCBOR (..), enforceSize) -import Cardano.Ledger.Core (Era, ppMaxBHSizeL, ppMaxTxSizeL) +import Cardano.Ledger.Core (Era) import qualified Cardano.Ledger.Core as Core import qualified Cardano.Ledger.Shelley.API as SL import qualified Cardano.Ledger.Shelley.Governance as SL @@ -82,7 +82,6 @@ import qualified Ouroboros.Consensus.HardFork.History as HardFork import Ouroboros.Consensus.HardFork.History.Util import Ouroboros.Consensus.HeaderValidation import Ouroboros.Consensus.Ledger.Abstract -import Ouroboros.Consensus.Ledger.CommonProtocolParams import Ouroboros.Consensus.Ledger.Extended import Ouroboros.Consensus.Protocol.Ledger.Util (isNewEpoch) import Ouroboros.Consensus.Protocol.TPraos (MaxMajorProtVer (..)) @@ -466,11 +465,6 @@ instance HasHardForkHistory (ShelleyBlock proto era) where hardForkSummary = neverForksHardForkSummary $ shelleyEraParamsNeverHardForks . shelleyLedgerGenesis -instance ShelleyCompatible proto era - => CommonProtocolParams (ShelleyBlock proto era) where - maxHeaderSize = fromIntegral . view ppMaxBHSizeL . getPParams . shelleyLedgerState - maxTxSize = view ppMaxTxSizeL . getPParams . shelleyLedgerState - {------------------------------------------------------------------------------- ValidateEnvelope -------------------------------------------------------------------------------} diff --git a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/ShelleyHFC.hs b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/ShelleyHFC.hs index 1d6e1334f9..9c3ab51625 100644 --- a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/ShelleyHFC.hs +++ b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/ShelleyHFC.hs @@ -16,8 +16,7 @@ -- | This module is the Shelley Hard Fork Combinator module Ouroboros.Consensus.Shelley.ShelleyHFC ( - ProtocolShelley - , ShelleyBlockHFC + ShelleyBlockHFC , ShelleyPartialLedgerConfig (..) , crossEraForecastAcrossShelley , forecastAcrossShelley @@ -119,12 +118,6 @@ instance (ShelleyCompatible proto era, LedgerSupportsProtocol (ShelleyBlock prot instance (ShelleyCompatible proto era, LedgerSupportsProtocol (ShelleyBlock proto era)) => SerialiseConstraintsHFC (ShelleyBlock proto era) -{------------------------------------------------------------------------------- - Protocol type definition --------------------------------------------------------------------------------} - -type ProtocolShelley = HardForkProtocol '[ ShelleyBlock (TPraos StandardCrypto) StandardShelley ] - {------------------------------------------------------------------------------- SingleEraBlock Shelley -------------------------------------------------------------------------------} diff --git a/ouroboros-consensus-cardano/src/unstable-byron-testlib/Ouroboros/Consensus/ByronDual/Node.hs b/ouroboros-consensus-cardano/src/unstable-byron-testlib/Ouroboros/Consensus/ByronDual/Node.hs index 8016c9236f..d6454781a9 100644 --- a/ouroboros-consensus-cardano/src/unstable-byron-testlib/Ouroboros/Consensus/ByronDual/Node.hs +++ b/ouroboros-consensus-cardano/src/unstable-byron-testlib/Ouroboros/Consensus/ByronDual/Node.hs @@ -95,7 +95,6 @@ protocolInfoDualByron abstractGenesis@ByronSpecGenesis{..} params credss = } , topLevelConfigBlock = DualBlockConfig { dualBlockConfigMain = concreteConfig - , dualBlockConfigAux = ByronSpecBlockConfig } , topLevelConfigCodec = DualCodecConfig { dualCodecConfigMain = mkByronCodecConfig concreteGenesis @@ -103,7 +102,6 @@ protocolInfoDualByron abstractGenesis@ByronSpecGenesis{..} params credss = } , topLevelConfigStorage = DualStorageConfig { dualStorageConfigMain = ByronStorageConfig concreteConfig - , dualStorageConfigAux = ByronSpecStorageConfig } , topLevelConfigCheckpoints = emptyCheckpointsMap } diff --git a/ouroboros-consensus-cardano/src/unstable-byron-testlib/Test/Consensus/Byron/Examples.hs b/ouroboros-consensus-cardano/src/unstable-byron-testlib/Test/Consensus/Byron/Examples.hs index 2ad8101852..a642402e0a 100644 --- a/ouroboros-consensus-cardano/src/unstable-byron-testlib/Test/Consensus/Byron/Examples.hs +++ b/ouroboros-consensus-cardano/src/unstable-byron-testlib/Test/Consensus/Byron/Examples.hs @@ -9,8 +9,6 @@ module Test.Consensus.Byron.Examples ( , codecConfig , leaderCredentials , ledgerConfig - , secParam - , windowSize -- * Examples , exampleApplyTxErr , exampleChainDepState @@ -34,7 +32,6 @@ import Ouroboros.Consensus.Block import Ouroboros.Consensus.Byron.Crypto.DSIGN (SignKeyDSIGN (..)) import Ouroboros.Consensus.Byron.Ledger import Ouroboros.Consensus.Byron.Node (ByronLeaderCredentials (..)) -import Ouroboros.Consensus.Config import Ouroboros.Consensus.HeaderValidation import Ouroboros.Consensus.Ledger.Abstract import Ouroboros.Consensus.Ledger.Extended @@ -58,15 +55,6 @@ import Test.Util.Serialisation.SomeResult (SomeResult (..)) Setup -------------------------------------------------------------------------------} --- | Note that we must use the same value for the 'SecurityParam' as for the --- 'S.WindowSize', because 'decodeByronChainDepState' only takes the --- 'SecurityParam' and uses it as the basis for the 'S.WindowSize'. -secParam :: SecurityParam -secParam = SecurityParam 2 - -windowSize :: S.WindowSize -windowSize = S.WindowSize 2 - cfg :: BlockConfig ByronBlock cfg = ByronConfig { byronGenesisConfig = CC.dummyConfig diff --git a/ouroboros-consensus-cardano/src/unstable-byron-testlib/Test/Consensus/Byron/Generators.hs b/ouroboros-consensus-cardano/src/unstable-byron-testlib/Test/Consensus/Byron/Generators.hs index 5253eb811a..a14225fb98 100644 --- a/ouroboros-consensus-cardano/src/unstable-byron-testlib/Test/Consensus/Byron/Generators.hs +++ b/ouroboros-consensus-cardano/src/unstable-byron-testlib/Test/Consensus/Byron/Generators.hs @@ -6,7 +6,6 @@ module Test.Consensus.Byron.Generators ( RegularBlock (..) , epochSlots - , k , protocolMagicId ) where @@ -35,7 +34,6 @@ import qualified Data.Map.Strict as Map import Ouroboros.Consensus.Block import Ouroboros.Consensus.Byron.Ledger import Ouroboros.Consensus.Byron.Protocol -import Ouroboros.Consensus.Config.SecurityParam import Ouroboros.Consensus.HeaderValidation (AnnTip (..)) import Ouroboros.Consensus.Ledger.SupportsMempool (GenTxId) import Ouroboros.Consensus.Protocol.PBFT.State (PBftState) @@ -61,10 +59,6 @@ import Test.Util.Serialisation.SomeResult (SomeResult (..)) Generators -------------------------------------------------------------------------------} --- | Matches that from the 'CC.dummyConfig' -k :: SecurityParam -k = SecurityParam 10 - -- | Matches that from the 'CC.dummyConfig' epochSlots :: EpochSlots epochSlots = EpochSlots 100 diff --git a/ouroboros-consensus-cardano/src/unstable-byronspec/Ouroboros/Consensus/ByronSpec/Ledger/Accessors.hs b/ouroboros-consensus-cardano/src/unstable-byronspec/Ouroboros/Consensus/ByronSpec/Ledger/Accessors.hs index 45f51031dd..b0706b9c4b 100644 --- a/ouroboros-consensus-cardano/src/unstable-byronspec/Ouroboros/Consensus/ByronSpec/Ledger/Accessors.hs +++ b/ouroboros-consensus-cardano/src/unstable-byronspec/Ouroboros/Consensus/ByronSpec/Ledger/Accessors.hs @@ -14,7 +14,6 @@ module Ouroboros.Consensus.ByronSpec.Ledger.Accessors ( -- * ChainState modifiers , ModChainState , modChainStateDIState - , modChainStateSlot , modChainStateUPIState , modChainStateUtxoState -- * Auxiliary @@ -40,9 +39,6 @@ type ModChainState a = forall m. Applicative m => (a -> m a) getChainStateSlot :: GetChainState Spec.Slot getChainStateSlot (a, _, _, _, _, _) = a -modChainStateSlot :: ModChainState Spec.Slot -modChainStateSlot fn (a, b, c, d, e, f) = (, b, c, d, e, f) <$> fn a - getChainStateHash :: GetChainState Spec.Hash getChainStateHash (_, _, c, _, _, _) = c diff --git a/ouroboros-consensus-cardano/src/unstable-byronspec/Ouroboros/Consensus/ByronSpec/Ledger/Genesis.hs b/ouroboros-consensus-cardano/src/unstable-byronspec/Ouroboros/Consensus/ByronSpec/Ledger/Genesis.hs index e753048a8f..8938818726 100644 --- a/ouroboros-consensus-cardano/src/unstable-byronspec/Ouroboros/Consensus/ByronSpec/Ledger/Genesis.hs +++ b/ouroboros-consensus-cardano/src/unstable-byronspec/Ouroboros/Consensus/ByronSpec/Ledger/Genesis.hs @@ -9,7 +9,6 @@ -- > import qualified Ouroboros.Consensus.ByronSpec.Ledger.Genesis as Genesis module Ouroboros.Consensus.ByronSpec.Ledger.Genesis ( ByronSpecGenesis (..) - , modFeeParams , modPBftThreshold , modPParams , modUtxo @@ -56,11 +55,6 @@ modPBftThreshold :: (Double -> Double) -> ByronSpecGenesis -> ByronSpecGenesis modPBftThreshold = modPParams . modPParamsPBftThreshold --- | Modify the @a@ and @b@ fee parameters -modFeeParams :: ((Int, Int) -> (Int, Int)) - -> ByronSpecGenesis -> ByronSpecGenesis -modFeeParams = modPParams . modPParamsFeeParams - -- | Adjust all values in the initial UTxO equally modUtxoValues :: (Integer -> Integer) -> ByronSpecGenesis -> ByronSpecGenesis modUtxoValues = modUtxo . Spec.mapUTxOValues . coerce @@ -88,16 +82,6 @@ modPParamsPBftThreshold f pparams = pparams { where Spec.BkSgnCntT threshold = Spec._bkSgnCntT pparams -modPParamsFeeParams :: ((Int, Int) -> (Int, Int)) - -> Spec.PParams -> Spec.PParams -modPParamsFeeParams f pparams = pparams { - Spec._factorA = Spec.FactorA $ fst (f (a, b)) - , Spec._factorB = Spec.FactorB $ snd (f (a, b)) - } - where - Spec.FactorA a = Spec._factorA pparams - Spec.FactorB b = Spec._factorB pparams - {------------------------------------------------------------------------------- Conversions -------------------------------------------------------------------------------} diff --git a/ouroboros-consensus-cardano/src/unstable-byronspec/Ouroboros/Consensus/ByronSpec/Ledger/Ledger.hs b/ouroboros-consensus-cardano/src/unstable-byronspec/Ouroboros/Consensus/ByronSpec/Ledger/Ledger.hs index fff29b449b..1d5b13b88e 100644 --- a/ouroboros-consensus-cardano/src/unstable-byronspec/Ouroboros/Consensus/ByronSpec/Ledger/Ledger.hs +++ b/ouroboros-consensus-cardano/src/unstable-byronspec/Ouroboros/Consensus/ByronSpec/Ledger/Ledger.hs @@ -31,7 +31,6 @@ import Ouroboros.Consensus.ByronSpec.Ledger.Genesis (ByronSpecGenesis) import Ouroboros.Consensus.ByronSpec.Ledger.Orphans () import qualified Ouroboros.Consensus.ByronSpec.Ledger.Rules as Rules import Ouroboros.Consensus.Ledger.Abstract -import Ouroboros.Consensus.Ledger.CommonProtocolParams import Ouroboros.Consensus.Ticked import Ouroboros.Consensus.Util ((..:)) @@ -139,17 +138,3 @@ instance ApplyBlock (LedgerState ByronSpecBlock) ByronSpecBlock where dontExpectError mb = case runExcept mb of Left _ -> error "reapplyBlockLedgerResult: unexpected error" Right b -> b - -{------------------------------------------------------------------------------- - CommonProtocolParams --------------------------------------------------------------------------------} - -instance CommonProtocolParams ByronSpecBlock where - maxHeaderSize = fromIntegral . Spec._maxHdrSz . getPParams - maxTxSize = fromIntegral . Spec._maxTxSz . getPParams - -getPParams :: LedgerState ByronSpecBlock -> Spec.PParams -getPParams = - Spec.protocolParameters - . getChainStateUPIState - . byronSpecLedgerState diff --git a/ouroboros-consensus-cardano/src/unstable-cardano-testlib/Test/Consensus/Cardano/Examples.hs b/ouroboros-consensus-cardano/src/unstable-cardano-testlib/Test/Consensus/Cardano/Examples.hs index 162b05857c..5b3318e7f8 100644 --- a/ouroboros-consensus-cardano/src/unstable-cardano-testlib/Test/Consensus/Cardano/Examples.hs +++ b/ouroboros-consensus-cardano/src/unstable-cardano-testlib/Test/Consensus/Cardano/Examples.hs @@ -19,8 +19,6 @@ module Test.Consensus.Cardano.Examples ( , exampleEraMismatchByron , exampleEraMismatchShelley , exampleQueryAnytimeShelley - , exampleQueryEraMismatchByron - , exampleQueryEraMismatchShelley , exampleResultAnytimeShelley , exampleResultEraMismatchByron , exampleResultEraMismatchShelley @@ -322,14 +320,6 @@ exampleApplyTxErrWrongEraShelley :: ApplyTxErr (CardanoBlock Crypto) exampleApplyTxErrWrongEraShelley = HardForkApplyTxErrWrongEra exampleEraMismatchShelley -exampleQueryEraMismatchByron :: SomeSecond BlockQuery (CardanoBlock Crypto) -exampleQueryEraMismatchByron = - SomeSecond (QueryIfCurrentShelley Shelley.GetLedgerTip) - -exampleQueryEraMismatchShelley :: SomeSecond BlockQuery (CardanoBlock Crypto) -exampleQueryEraMismatchShelley = - SomeSecond (QueryIfCurrentByron Byron.GetUpdateInterfaceState) - exampleQueryAnytimeByron :: SomeSecond BlockQuery (CardanoBlock Crypto) exampleQueryAnytimeByron = SomeSecond (QueryAnytimeByron GetEraStart) diff --git a/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBAnalyser/Analysis.hs b/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBAnalyser/Analysis.hs index b961266be6..7adca731eb 100644 --- a/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBAnalyser/Analysis.hs +++ b/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBAnalyser/Analysis.hs @@ -36,6 +36,7 @@ import qualified Cardano.Tools.DBAnalyser.HasAnalysis as HasAnalysis import Codec.CBOR.Encoding (Encoding) import Control.Monad (unless, void, when) import Control.Monad.Except (runExcept) +import Control.ResourceRegistry import Control.Tracer (Tracer (..), nullTracer, traceWith) import Data.Int (Int64) import Data.List (intercalate) @@ -75,7 +76,6 @@ import Ouroboros.Consensus.Storage.Serialisation (SizeInBytes, encodeDisk) import Ouroboros.Consensus.Util ((..:)) import qualified Ouroboros.Consensus.Util.IOLike as IOLike -import Ouroboros.Consensus.Util.ResourceRegistry import System.FS.API (SomeHasFS (..)) import qualified System.IO as IO diff --git a/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBAnalyser/Run.hs b/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBAnalyser/Run.hs index ca0a5e3ed1..26312a5934 100644 --- a/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBAnalyser/Run.hs +++ b/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBAnalyser/Run.hs @@ -12,6 +12,7 @@ import Cardano.Tools.DBAnalyser.HasAnalysis import Cardano.Tools.DBAnalyser.Types import Codec.Serialise (Serialise (decode)) import Control.Monad.Except (runExceptT) +import Control.ResourceRegistry import Control.Tracer (Tracer (..), nullTracer) import Data.Singletons (Sing, SingI (..)) import qualified Debug.Trace as Debug @@ -32,7 +33,6 @@ import Ouroboros.Consensus.Storage.LedgerDB (DiskSnapshot (..), readSnapshot) import Ouroboros.Consensus.Util.IOLike import Ouroboros.Consensus.Util.Orphans () -import Ouroboros.Consensus.Util.ResourceRegistry import System.IO import Text.Printf (printf) diff --git a/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBImmutaliser/Run.hs b/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBImmutaliser/Run.hs index ccc95b702f..016dda6b90 100644 --- a/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBImmutaliser/Run.hs +++ b/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBImmutaliser/Run.hs @@ -19,6 +19,7 @@ module Cardano.Tools.DBImmutaliser.Run ( import qualified Cardano.Tools.DBAnalyser.Block.Cardano as Cardano import Cardano.Tools.DBAnalyser.HasAnalysis (mkProtocolInfo) +import Control.ResourceRegistry import Control.Tracer (Tracer, stdoutTracer, traceWith) import Data.Foldable (for_) import Data.Functor.Contravariant ((>$<)) @@ -43,7 +44,6 @@ import qualified Ouroboros.Consensus.Storage.VolatileDB.API as VolatileDB import qualified Ouroboros.Consensus.Storage.VolatileDB.Impl as VolatileDB import Ouroboros.Consensus.Util.Args import Ouroboros.Consensus.Util.IOLike -import Ouroboros.Consensus.Util.ResourceRegistry import Ouroboros.Network.Block (MaxSlotNo) import System.FS.API (SomeHasFS (..)) import System.FS.API.Types (MountPoint (..)) diff --git a/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBSynthesizer/Run.hs b/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBSynthesizer/Run.hs index 9aa866c0d0..c1fff3bd7d 100644 --- a/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBSynthesizer/Run.hs +++ b/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBSynthesizer/Run.hs @@ -15,6 +15,7 @@ import Cardano.Tools.DBSynthesizer.Types import Control.Monad.Trans.Except (ExceptT) import Control.Monad.Trans.Except.Extra (firstExceptT, handleIOExceptT, hoistEither, runExceptT) +import Control.ResourceRegistry import Control.Tracer (nullTracer) import Data.Aeson as Aeson (FromJSON, Result (..), Value, eitherDecodeFileStrict', eitherDecodeStrict', fromJSON) @@ -34,7 +35,6 @@ import qualified Ouroboros.Consensus.Storage.ChainDB as ChainDB (getTipPoint) import qualified Ouroboros.Consensus.Storage.ChainDB.Impl as ChainDB (withDB) import qualified Ouroboros.Consensus.Storage.ChainDB.Impl.Args as ChainDB import Ouroboros.Consensus.Util.IOLike (atomically) -import Ouroboros.Consensus.Util.ResourceRegistry import Ouroboros.Network.Block import Ouroboros.Network.Point (WithOrigin (..)) import System.Directory diff --git a/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBTruncater/Run.hs b/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBTruncater/Run.hs index 1cc583e14b..ad2f7ea410 100644 --- a/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBTruncater/Run.hs +++ b/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBTruncater/Run.hs @@ -11,6 +11,7 @@ import Cardano.Slotting.Slot (WithOrigin (..)) import Cardano.Tools.DBAnalyser.HasAnalysis import Cardano.Tools.DBTruncater.Types import Control.Monad +import Control.ResourceRegistry (runWithTempRegistry, withRegistry) import Control.Tracer import Data.Functor.Identity import Data.Traversable (for) @@ -24,8 +25,6 @@ import Ouroboros.Consensus.Storage.ImmutableDB (ImmutableDB, Iterator, import qualified Ouroboros.Consensus.Storage.ImmutableDB as ImmutableDB import Ouroboros.Consensus.Storage.ImmutableDB.Impl import Ouroboros.Consensus.Util.IOLike -import Ouroboros.Consensus.Util.ResourceRegistry (runWithTempRegistry, - withRegistry) import Prelude hiding (truncate) import System.IO diff --git a/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/ImmDBServer/Diffusion.hs b/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/ImmDBServer/Diffusion.hs index bca7081789..05f3c01208 100644 --- a/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/ImmDBServer/Diffusion.hs +++ b/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/ImmDBServer/Diffusion.hs @@ -6,6 +6,7 @@ module Cardano.Tools.ImmDBServer.Diffusion (run) where import Cardano.Tools.ImmDBServer.MiniProtocols (immDBServer) +import Control.ResourceRegistry import Control.Tracer import qualified Data.ByteString.Lazy as BL import Data.Functor.Contravariant ((>$<)) @@ -22,7 +23,6 @@ import Ouroboros.Consensus.Storage.ImmutableDB (ImmutableDbArgs (..)) import qualified Ouroboros.Consensus.Storage.ImmutableDB as ImmutableDB import Ouroboros.Consensus.Util import Ouroboros.Consensus.Util.IOLike -import Ouroboros.Consensus.Util.ResourceRegistry import Ouroboros.Network.ErrorPolicy (nullErrorPolicies) import Ouroboros.Network.IOManager (withIOManager) import Ouroboros.Network.Mux diff --git a/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/ImmDBServer/MiniProtocols.hs b/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/ImmDBServer/MiniProtocols.hs index b563c711e9..d1677297e3 100644 --- a/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/ImmDBServer/MiniProtocols.hs +++ b/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/ImmDBServer/MiniProtocols.hs @@ -17,6 +17,7 @@ module Cardano.Tools.ImmDBServer.MiniProtocols (immDBServer) where import qualified Codec.CBOR.Decoding as CBOR import qualified Codec.CBOR.Encoding as CBOR import Control.Monad (forever) +import Control.ResourceRegistry import Control.Tracer import Data.Bifunctor (bimap) import qualified Data.ByteString.Lazy as BL @@ -42,7 +43,6 @@ import Ouroboros.Consensus.Storage.ImmutableDB.API (ImmutableDB) import qualified Ouroboros.Consensus.Storage.ImmutableDB.API as ImmutableDB import Ouroboros.Consensus.Util import Ouroboros.Consensus.Util.IOLike -import Ouroboros.Consensus.Util.ResourceRegistry import Ouroboros.Network.Block (ChainUpdate (..), Tip (..)) import Ouroboros.Network.Driver (runPeer) import Ouroboros.Network.KeepAlive (keepAliveServer) diff --git a/ouroboros-consensus-cardano/test/byron-test/Test/ThreadNet/Byron.hs b/ouroboros-consensus-cardano/test/byron-test/Test/ThreadNet/Byron.hs index 7eba72667d..6fdc1a258a 100644 --- a/ouroboros-consensus-cardano/test/byron-test/Test/ThreadNet/Byron.hs +++ b/ouroboros-consensus-cardano/test/byron-test/Test/ThreadNet/Byron.hs @@ -14,7 +14,6 @@ module Test.ThreadNet.Byron ( , byronPBftParams , expectedCannotForge , genTestSetup - , noEBBs ) where import qualified Cardano.Chain.Block as Block @@ -1069,11 +1068,6 @@ data ProduceEBBs -- also produce an EBB at the start of each subsequent epoch. deriving (Eq, Show) --- | Exported alias for 'NoEBBs'. --- -noEBBs :: ProduceEBBs -noEBBs = NoEBBs - instance Arbitrary ProduceEBBs where arbitrary = elements [NoEBBs, ProduceEBBs] shrink NoEBBs = [] diff --git a/ouroboros-consensus-cardano/test/cardano-test/Test/Consensus/Cardano/DiffusionPipelining.hs b/ouroboros-consensus-cardano/test/cardano-test/Test/Consensus/Cardano/DiffusionPipelining.hs index 2c2a8d6bda..756f28d856 100644 --- a/ouroboros-consensus-cardano/test/cardano-test/Test/Consensus/Cardano/DiffusionPipelining.hs +++ b/ouroboros-consensus-cardano/test/cardano-test/Test/Consensus/Cardano/DiffusionPipelining.hs @@ -31,7 +31,7 @@ import Ouroboros.Consensus.Shelley.Node.DiffusionPipelining import Ouroboros.Consensus.TypeFamilyWrappers import Test.Cardano.Ledger.Binary.Arbitrary () import Test.Cardano.Ledger.Core.Arbitrary () -import Test.Ouroboros.Consensus.DiffusionPipelining +import Test.Consensus.DiffusionPipelining import Test.Tasty import Test.Tasty.QuickCheck diff --git a/ouroboros-consensus-diffusion/changelog.d/weeder.md b/ouroboros-consensus-diffusion/changelog.d/weeder.md new file mode 100644 index 0000000000..747a3c3dc8 --- /dev/null +++ b/ouroboros-consensus-diffusion/changelog.d/weeder.md @@ -0,0 +1,3 @@ +### Breaking + +- Removed multiple unused functions thanks to `weeder`. diff --git a/ouroboros-consensus-diffusion/ouroboros-consensus-diffusion.cabal b/ouroboros-consensus-diffusion/ouroboros-consensus-diffusion.cabal index ab9c51e1e8..276048a2f3 100644 --- a/ouroboros-consensus-diffusion/ouroboros-consensus-diffusion.cabal +++ b/ouroboros-consensus-diffusion/ouroboros-consensus-diffusion.cabal @@ -89,12 +89,14 @@ library hashable, io-classes ^>=1.5, mtl, + nf-vars ^>=0.1, ouroboros-consensus ^>=0.20, ouroboros-network ^>=0.16, ouroboros-network-api ^>=0.7.3, ouroboros-network-framework ^>=0.13.2, ouroboros-network-protocols ^>=0.9, random, + resource-registry ^>=0.1, safe-wild-cards ^>=1.0, serialise ^>=0.2, si-timers ^>=1.5, @@ -148,6 +150,7 @@ library unstable-diffusion-testlib ouroboros-network-protocols, quiet ^>=0.2, random, + resource-registry, si-timers, sop-core ^>=0.5, sop-extras ^>=0.2, @@ -300,6 +303,7 @@ test-suite consensus-test quickcheck-state-machine:no-vendored-treediff, quiet, random, + resource-registry, serialise, si-timers, sop-extras, diff --git a/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Network/NodeToClient.hs b/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Network/NodeToClient.hs index 73ddcab268..a9311a984b 100644 --- a/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Network/NodeToClient.hs +++ b/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Network/NodeToClient.hs @@ -11,19 +11,13 @@ module Ouroboros.Consensus.Network.NodeToClient ( Handlers (..) , mkHandlers -- * Codecs - , ClientCodecs , Codecs , Codecs' (..) , DefaultCodecs - , clientCodecs , defaultCodecs - , identityCodecs - -- * ClientCodecs -- * Tracers , Tracers , Tracers' (..) - , nullTracers - , showTracers -- * Applications , App , Apps (..) @@ -36,6 +30,7 @@ import Codec.CBOR.Decoding (Decoder) import Codec.CBOR.Encoding (Encoding) import Codec.CBOR.Read (DeserialiseFailure) import Codec.Serialise (Serialise) +import Control.ResourceRegistry import Control.Tracer import Data.ByteString.Lazy (ByteString) import Data.Void (Void) @@ -58,7 +53,6 @@ import qualified Ouroboros.Consensus.Storage.ChainDB.API as ChainDB import Ouroboros.Consensus.Util (ShowProxy) import Ouroboros.Consensus.Util.IOLike import Ouroboros.Consensus.Util.Orphans () -import Ouroboros.Consensus.Util.ResourceRegistry import qualified Ouroboros.Network.AnchoredFragment as AF import Ouroboros.Network.Block (Serialised, decodePoint, decodeTip, encodePoint, encodeTip) @@ -152,8 +146,6 @@ type Codecs blk e m bCS bTX bSQ bTM = Codecs' blk (Serialised blk) e m bCS bTX bSQ bTM type DefaultCodecs blk m = Codecs' blk (Serialised blk) DeserialiseFailure m ByteString ByteString ByteString ByteString -type ClientCodecs blk m = - Codecs' blk blk DeserialiseFailure m ByteString ByteString ByteString ByteString -- | Protocol codecs for the node-to-client protocols -- @@ -228,80 +220,6 @@ defaultCodecs ccfg version networkVersion = Codecs { dec :: SerialiseNodeToClient blk a => forall s. Decoder s a dec = decodeNodeToClient ccfg version --- | Protocol codecs for the node-to-client protocols which serialise --- / deserialise blocks in /chain-sync/ protocol. --- -clientCodecs :: forall m blk. - ( MonadST m - , SerialiseNodeToClientConstraints blk - , ShowQuery (BlockQuery blk) - , StandardHash blk - , Serialise (HeaderHash blk) - ) - => CodecConfig blk - -> BlockNodeToClientVersion blk - -> N.NodeToClientVersion - -> ClientCodecs blk m -clientCodecs ccfg version networkVersion = Codecs { - cChainSyncCodec = - codecChainSync - enc - dec - (encodePoint (encodeRawHash p)) - (decodePoint (decodeRawHash p)) - (encodeTip (encodeRawHash p)) - (decodeTip (decodeRawHash p)) - - , cTxSubmissionCodec = - codecLocalTxSubmission - enc - dec - enc - dec - - , cStateQueryCodec = - codecLocalStateQuery - networkVersion - (encodePoint (encodeRawHash p)) - (decodePoint (decodeRawHash p)) - (queryEncodeNodeToClient ccfg queryVersion version . SomeSecond) - ((\(SomeSecond qry) -> Some qry) <$> queryDecodeNodeToClient ccfg queryVersion version) - (encodeResult ccfg version) - (decodeResult ccfg version) - - , cTxMonitorCodec = - codecLocalTxMonitor - enc dec - enc dec - enc dec - } - where - queryVersion :: QueryVersion - queryVersion = nodeToClientVersionToQueryVersion networkVersion - - p :: Proxy blk - p = Proxy - - enc :: SerialiseNodeToClient blk a => a -> Encoding - enc = encodeNodeToClient ccfg version - - dec :: SerialiseNodeToClient blk a => forall s. Decoder s a - dec = decodeNodeToClient ccfg version - --- | Identity codecs used in tests. -identityCodecs :: (Monad m, BlockSupportsLedgerQuery blk) - => Codecs blk CodecFailure m - (AnyMessage (ChainSync (Serialised blk) (Point blk) (Tip blk))) - (AnyMessage (LocalTxSubmission (GenTx blk) (ApplyTxErr blk))) - (AnyMessage (LocalStateQuery blk (Point blk) (Query blk))) - (AnyMessage (LocalTxMonitor (GenTxId blk) (GenTx blk) SlotNo)) -identityCodecs = Codecs { - cChainSyncCodec = codecChainSyncId - , cTxSubmissionCodec = codecLocalTxSubmissionId - , cStateQueryCodec = codecLocalStateQueryId sameDepIndex - , cTxMonitorCodec = codecLocalTxMonitorId - } - {------------------------------------------------------------------------------- Tracers -------------------------------------------------------------------------------} @@ -330,30 +248,6 @@ instance (forall a. Semigroup (f a)) => Semigroup (Tracers' peer blk e f) where -> a f prj = prj l <> prj r --- | Use a 'nullTracer' for each protocol. -nullTracers :: Monad m => Tracers m peer blk e -nullTracers = Tracers { - tChainSyncTracer = nullTracer - , tTxSubmissionTracer = nullTracer - , tStateQueryTracer = nullTracer - , tTxMonitorTracer = nullTracer - } - -showTracers :: ( Show peer - , Show (GenTx blk) - , Show (GenTxId blk) - , Show (ApplyTxErr blk) - , ShowQuery (BlockQuery blk) - , HasHeader blk - ) - => Tracer m String -> Tracers m peer blk e -showTracers tr = Tracers { - tChainSyncTracer = showTracing tr - , tTxSubmissionTracer = showTracing tr - , tStateQueryTracer = showTracing tr - , tTxMonitorTracer = showTracing tr - } - {------------------------------------------------------------------------------- Applications -------------------------------------------------------------------------------} diff --git a/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Network/NodeToNode.hs b/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Network/NodeToNode.hs index abb195eb65..f99c79f559 100644 --- a/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Network/NodeToNode.hs +++ b/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Network/NodeToNode.hs @@ -44,6 +44,7 @@ import Codec.CBOR.Read (DeserialiseFailure) import qualified Control.Concurrent.Class.MonadSTM.Strict.TVar as TVar.Unchecked import Control.Monad.Class.MonadTime.SI (MonadTime) import Control.Monad.Class.MonadTimer.SI (MonadTimer) +import Control.ResourceRegistry import Control.Tracer import Data.ByteString.Lazy (ByteString) import qualified Data.ByteString.Lazy as BSL @@ -71,7 +72,6 @@ import Ouroboros.Consensus.Storage.Serialisation (SerialisedHeader) import Ouroboros.Consensus.Util (ShowProxy) import Ouroboros.Consensus.Util.IOLike import Ouroboros.Consensus.Util.Orphans () -import Ouroboros.Consensus.Util.ResourceRegistry import Ouroboros.Network.Block (Serialised (..), decodePoint, decodeTip, encodePoint, encodeTip) import Ouroboros.Network.BlockFetch diff --git a/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Node.hs b/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Node.hs index c77fdbac81..35e079f27f 100644 --- a/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Node.hs +++ b/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Node.hs @@ -63,6 +63,7 @@ import Control.DeepSeq (NFData) import Control.Monad (forM_, when) import Control.Monad.Class.MonadTime.SI (MonadTime) import Control.Monad.Class.MonadTimer.SI (MonadTimer) +import Control.ResourceRegistry import Control.Tracer (Tracer, contramap, traceWith) import Data.ByteString.Lazy (ByteString) import Data.Functor.Contravariant (Predicate (..)) @@ -107,7 +108,6 @@ import Ouroboros.Consensus.Storage.LedgerDB.DiskPolicy import Ouroboros.Consensus.Util.Args import Ouroboros.Consensus.Util.IOLike import Ouroboros.Consensus.Util.Orphans () -import Ouroboros.Consensus.Util.ResourceRegistry import Ouroboros.Consensus.Util.Time (secondsToNominalDiffTime) import Ouroboros.Network.BlockFetch (BlockFetchConfiguration (..)) import qualified Ouroboros.Network.Diffusion as Diffusion diff --git a/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Node/ErrorPolicy.hs b/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Node/ErrorPolicy.hs index be961f3e56..4d59c2c423 100644 --- a/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Node/ErrorPolicy.hs +++ b/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Node/ErrorPolicy.hs @@ -3,6 +3,8 @@ module Ouroboros.Consensus.Node.ErrorPolicy (consensusErrorPolicy) where import Control.Monad.Class.MonadAsync (ExceptionInLinkedThread (..)) +import Control.ResourceRegistry (RegistryClosedException, + ResourceRegistryThreadException, TempRegistryException) import Data.Proxy (Proxy) import Data.Time.Clock (DiffTime) import Data.Typeable (Typeable) @@ -20,9 +22,6 @@ import Ouroboros.Consensus.Storage.ImmutableDB.API (ImmutableDBError) import qualified Ouroboros.Consensus.Storage.ImmutableDB.API as ImmutableDB import Ouroboros.Consensus.Storage.VolatileDB.API (VolatileDBError) import qualified Ouroboros.Consensus.Storage.VolatileDB.API as VolatileDB -import Ouroboros.Consensus.Util.ResourceRegistry - (RegistryClosedException, ResourceRegistryThreadException, - TempRegistryException) import Ouroboros.Network.ErrorPolicy import System.FS.API.Types (FsError) diff --git a/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Node/GSM.hs b/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Node/GSM.hs index 8c420f370d..c938039919 100644 --- a/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Node/GSM.hs +++ b/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Node/GSM.hs @@ -29,6 +29,8 @@ module Ouroboros.Consensus.Node.GSM ( ) where import qualified Cardano.Slotting.Slot as Slot +import Control.Concurrent.Class.MonadSTM.NormalForm (StrictTVar) +import qualified Control.Concurrent.Class.MonadSTM.NormalForm as StrictSTM import qualified Control.Concurrent.Class.MonadSTM.TVar as LazySTM import Control.Monad (forever, join, unless) import Control.Monad.Class.MonadSTM (MonadSTM, STM, atomically, check, @@ -47,8 +49,6 @@ import qualified Ouroboros.Consensus.HardFork.History.Qry as Qry import qualified Ouroboros.Consensus.Ledger.Basics as L import Ouroboros.Consensus.Node.GsmState import Ouroboros.Consensus.Storage.ChainDB.API (ChainDB) -import Ouroboros.Consensus.Util.NormalForm.StrictTVar (StrictTVar) -import qualified Ouroboros.Consensus.Util.NormalForm.StrictTVar as StrictSTM import Ouroboros.Network.PeerSelection.LedgerPeers.Type (LedgerStateJudgement (..)) import System.FS.API (HasFS, createDirectoryIfMissing, doesFileExist, diff --git a/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Node/RethrowPolicy.hs b/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Node/RethrowPolicy.hs index 21a296cb2a..767833fb35 100644 --- a/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Node/RethrowPolicy.hs +++ b/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Node/RethrowPolicy.hs @@ -3,6 +3,8 @@ module Ouroboros.Consensus.Node.RethrowPolicy (consensusRethrowPolicy) where import Control.Monad.Class.MonadAsync (ExceptionInLinkedThread (..)) +import Control.ResourceRegistry (RegistryClosedException, + ResourceRegistryThreadException, TempRegistryException) import Data.Proxy (Proxy) import Data.Typeable (Typeable) import Ouroboros.Consensus.Block (StandardHash) @@ -19,9 +21,6 @@ import Ouroboros.Consensus.Storage.ImmutableDB.API (ImmutableDBError) import qualified Ouroboros.Consensus.Storage.ImmutableDB.API as ImmutableDB import Ouroboros.Consensus.Storage.VolatileDB.API (VolatileDBError) import qualified Ouroboros.Consensus.Storage.VolatileDB.API as VolatileDB -import Ouroboros.Consensus.Util.ResourceRegistry - (RegistryClosedException, ResourceRegistryThreadException, - TempRegistryException) import Ouroboros.Network.RethrowPolicy import System.FS.API.Types (FsError) diff --git a/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/NodeKernel.hs b/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/NodeKernel.hs index 1c6f0bdb0f..ed1514f04e 100644 --- a/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/NodeKernel.hs +++ b/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/NodeKernel.hs @@ -33,6 +33,7 @@ import Control.DeepSeq (force) import Control.Monad import qualified Control.Monad.Class.MonadTimer.SI as SI import Control.Monad.Except +import Control.ResourceRegistry import Control.Tracer import Data.Bifunctor (second) import Data.Data (Typeable) @@ -85,7 +86,6 @@ import Ouroboros.Consensus.Util.IOLike import Ouroboros.Consensus.Util.LeakyBucket (atomicallyWithMonotonicTime) import Ouroboros.Consensus.Util.Orphans () -import Ouroboros.Consensus.Util.ResourceRegistry import Ouroboros.Consensus.Util.STM import Ouroboros.Network.AnchoredFragment (AnchoredFragment, AnchoredSeq (..)) diff --git a/ouroboros-consensus-diffusion/src/unstable-diffusion-testlib/Test/ThreadNet/General.hs b/ouroboros-consensus-diffusion/src/unstable-diffusion-testlib/Test/ThreadNet/General.hs index dd3d43e07b..89a7da324f 100644 --- a/ouroboros-consensus-diffusion/src/unstable-diffusion-testlib/Test/ThreadNet/General.hs +++ b/ouroboros-consensus-diffusion/src/unstable-diffusion-testlib/Test/ThreadNet/General.hs @@ -20,8 +20,6 @@ module Test.ThreadNet.General ( , TestConfig (..) , TestConfigB (..) , TestConfigMB (..) - , truncateNodeJoinPlan - , truncateNodeRestarts , truncateNodeTopology -- * Expected CannotForge , noExpectedCannotForges @@ -100,25 +98,10 @@ data TestConfig = TestConfig } deriving (Show) -truncateNodeJoinPlan :: - NodeJoinPlan -> NumCoreNodes -> (NumSlots, NumSlots) -> NodeJoinPlan -truncateNodeJoinPlan - (NodeJoinPlan m) (NumCoreNodes n') (NumSlots t, NumSlots t') = - NodeJoinPlan $ - -- scale by t' / t - Map.map (\(SlotNo i) -> SlotNo $ (i * t') `div` t) $ - -- discard discarded nodes - Map.filterWithKey (\(CoreNodeId nid) _ -> nid < n') $ - m - truncateNodeTopology :: NodeTopology -> NumCoreNodes -> NodeTopology truncateNodeTopology (NodeTopology m) (NumCoreNodes n') = NodeTopology $ Map.filterWithKey (\(CoreNodeId i) _ -> i < n') m -truncateNodeRestarts :: NodeRestarts -> NumSlots -> NodeRestarts -truncateNodeRestarts (NodeRestarts m) (NumSlots t) = - NodeRestarts $ Map.filterWithKey (\(SlotNo s) _ -> s < t) m - instance Arbitrary TestConfig where arbitrary = do initSeed <- arbitrary diff --git a/ouroboros-consensus-diffusion/src/unstable-diffusion-testlib/Test/ThreadNet/Network.hs b/ouroboros-consensus-diffusion/src/unstable-diffusion-testlib/Test/ThreadNet/Network.hs index c6ce17dc07..283301eed8 100644 --- a/ouroboros-consensus-diffusion/src/unstable-diffusion-testlib/Test/ThreadNet/Network.hs +++ b/ouroboros-consensus-diffusion/src/unstable-diffusion-testlib/Test/ThreadNet/Network.hs @@ -43,6 +43,7 @@ import Control.Monad import Control.Monad.Class.MonadTime.SI (MonadTime) import Control.Monad.Class.MonadTimer.SI (MonadTimer) import qualified Control.Monad.Except as Exc +import Control.ResourceRegistry import Control.Tracer import qualified Data.ByteString.Lazy as Lazy import Data.Either (isRight) @@ -97,7 +98,6 @@ import Ouroboros.Consensus.Util.Enclose (pattern FallingEdge) import Ouroboros.Consensus.Util.IOLike import Ouroboros.Consensus.Util.Orphans () import Ouroboros.Consensus.Util.RedundantConstraints -import Ouroboros.Consensus.Util.ResourceRegistry import Ouroboros.Consensus.Util.STM import Ouroboros.Consensus.Util.Time import qualified Ouroboros.Network.AnchoredFragment as AF diff --git a/ouroboros-consensus-diffusion/src/unstable-diffusion-testlib/Test/ThreadNet/Util/NodeJoinPlan.hs b/ouroboros-consensus-diffusion/src/unstable-diffusion-testlib/Test/ThreadNet/Util/NodeJoinPlan.hs index e5b4669ff8..2746fef594 100644 --- a/ouroboros-consensus-diffusion/src/unstable-diffusion-testlib/Test/ThreadNet/Util/NodeJoinPlan.hs +++ b/ouroboros-consensus-diffusion/src/unstable-diffusion-testlib/Test/ThreadNet/Util/NodeJoinPlan.hs @@ -1,5 +1,4 @@ {-# LANGUAGE CPP #-} -{-# LANGUAGE LambdaCase #-} {-# LANGUAGE ScopedTypeVariables #-} #if __GLASGOW_HASKELL__ >= 908 @@ -12,7 +11,6 @@ module Test.ThreadNet.Util.NodeJoinPlan ( , coreNodeIdJoinSlot , genNodeJoinPlan , nodeIdJoinSlot - , shrinkNodeJoinPlan , trivialNodeJoinPlan ) where @@ -76,27 +74,6 @@ genNodeJoinPlan numCoreNodes@(NumCoreNodes n) numSlots@(NumSlots t) -- their Ids; this merely makes it easer to interpret the counterexamples pure $ NodeJoinPlan $ Map.fromList $ zip nids $ List.sort schedules --- | Shrink a node join plan --- --- INVARIANT no inter-join delay increases --- --- Specifically, we shrink by setting some of the delays to 0. --- -shrinkNodeJoinPlan :: NodeJoinPlan -> [NodeJoinPlan] -shrinkNodeJoinPlan (NodeJoinPlan m0) = - init $ -- the last one is the same as the input - map (NodeJoinPlan . snd) $ go diffs0 - where - slots = map snd (Map.toDescList m0) ++ [0] - diffs0 = zipWith (\j2 j1 -> j2 - j1) slots (tail slots) - - go = \case - [] -> [((CoreNodeId 0, 0), Map.empty)] - d:ds -> do - ((CoreNodeId i, mx), m) <- go ds - let f s = ((CoreNodeId (succ i), s), Map.insert (CoreNodeId i) s m) - [f mx] ++ [f (mx + d) | d > 0] - -- | Partial; @error@ for a node not in the plan -- coreNodeIdJoinSlot :: diff --git a/ouroboros-consensus-diffusion/src/unstable-diffusion-testlib/Test/ThreadNet/Util/NodeRestarts.hs b/ouroboros-consensus-diffusion/src/unstable-diffusion-testlib/Test/ThreadNet/Util/NodeRestarts.hs index 12c254aabe..966c1b247e 100644 --- a/ouroboros-consensus-diffusion/src/unstable-diffusion-testlib/Test/ThreadNet/Util/NodeRestarts.hs +++ b/ouroboros-consensus-diffusion/src/unstable-diffusion-testlib/Test/ThreadNet/Util/NodeRestarts.hs @@ -3,7 +3,6 @@ module Test.ThreadNet.Util.NodeRestarts ( , NodeRestarts (..) , genNodeRestarts , noRestarts - , shrinkNodeRestarts ) where import Data.Map.Strict (Map) @@ -87,8 +86,3 @@ genNodeRestarts (NodeJoinPlan m) (NumSlots t) joinSlot <= s && -- must not be leading (TODO relax this somehow?) not (isLeading nid s) - -shrinkNodeRestarts :: NodeRestarts -> [NodeRestarts] -shrinkNodeRestarts (NodeRestarts m) - | Map.null m = [] -- TODO better shrink - | otherwise = [noRestarts] diff --git a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/Genesis/Setup.hs b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/Genesis/Setup.hs index a1e661c264..95b2169865 100644 --- a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/Genesis/Setup.hs +++ b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/Genesis/Setup.hs @@ -13,7 +13,8 @@ module Test.Consensus.Genesis.Setup ( ) where import Control.Exception (throw) -import Control.Monad.Class.MonadAsync (AsyncCancelled(AsyncCancelled)) +import Control.Monad.Class.MonadAsync + (AsyncCancelled (AsyncCancelled)) import Control.Monad.IOSim (IOSim, runSimStrictShutdown) import Control.Tracer (debugTracer, traceWith) import Data.Maybe (mapMaybe) @@ -23,13 +24,14 @@ import Ouroboros.Consensus.Util.Condense import Ouroboros.Consensus.Util.IOLike (Exception, fromException) import Ouroboros.Network.Driver.Limits (ProtocolLimitFailure (ExceededTimeLimit)) -import Test.Consensus.Genesis.Setup.Classifiers - (Classifiers (..), ResultClassifiers (..), ScheduleClassifiers (..), - classifiers, resultClassifiers, scheduleClassifiers) +import Test.Consensus.Genesis.Setup.Classifiers (Classifiers (..), + ResultClassifiers (..), ScheduleClassifiers (..), + classifiers, resultClassifiers, scheduleClassifiers) import Test.Consensus.Genesis.Setup.GenChains import Test.Consensus.PeerSimulator.Run import Test.Consensus.PeerSimulator.StateView -import Test.Consensus.PeerSimulator.Trace (traceLinesWith, tracerTestBlock) +import Test.Consensus.PeerSimulator.Trace (traceLinesWith, + tracerTestBlock) import Test.Consensus.PointSchedule import Test.QuickCheck import Test.Util.Orphans.IOLike () @@ -45,7 +47,7 @@ import Text.Printf (printf) runSimStrictShutdownOrThrow :: forall a. (forall s. IOSim s a) -> a runSimStrictShutdownOrThrow action = case runSimStrictShutdown action of - Left e -> throw e + Left e -> throw e Right x -> x -- | Runs the given 'GenesisTest' and 'PointSchedule' and evaluates the given diff --git a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/Genesis/Setup/GenChains.hs b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/Genesis/Setup/GenChains.hs index 2cc40aafde..b5a04ca5c5 100644 --- a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/Genesis/Setup/GenChains.hs +++ b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/Genesis/Setup/GenChains.hs @@ -29,18 +29,17 @@ import Ouroboros.Network.Protocol.ChainSync.Codec (ChainSyncTimeout (..)) import Ouroboros.Network.Protocol.Limits (shortWait) import qualified Test.Consensus.BlockTree as BT -import Test.Consensus.PointSchedule -import qualified Test.Ouroboros.Consensus.ChainGenerator.Adversarial as A -import Test.Ouroboros.Consensus.ChainGenerator.Adversarial - (genPrefixBlockCount) -import Test.Ouroboros.Consensus.ChainGenerator.Counting - (Count (Count), getVector) -import qualified Test.Ouroboros.Consensus.ChainGenerator.Honest as H -import Test.Ouroboros.Consensus.ChainGenerator.Honest +import qualified Test.Consensus.ChainGenerator.Adversarial as A +import Test.Consensus.ChainGenerator.Adversarial (genPrefixBlockCount) +import Test.Consensus.ChainGenerator.Counting (Count (Count), + getVector) +import qualified Test.Consensus.ChainGenerator.Honest as H +import Test.Consensus.ChainGenerator.Honest (ChainSchema (ChainSchema), HonestRecipe (..)) -import Test.Ouroboros.Consensus.ChainGenerator.Params -import qualified Test.Ouroboros.Consensus.ChainGenerator.Slot as S -import Test.Ouroboros.Consensus.ChainGenerator.Slot (S) +import Test.Consensus.ChainGenerator.Params +import qualified Test.Consensus.ChainGenerator.Slot as S +import Test.Consensus.ChainGenerator.Slot (S) +import Test.Consensus.PointSchedule import qualified Test.QuickCheck as QC import Test.QuickCheck.Extras (unsafeMapSuchThatJust) import Test.QuickCheck.Random (QCGen) diff --git a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/Genesis/Tests/Uniform.hs b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/Genesis/Tests/Uniform.hs index 7ebdd0a84e..f7346a55ce 100644 --- a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/Genesis/Tests/Uniform.hs +++ b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/Genesis/Tests/Uniform.hs @@ -33,6 +33,7 @@ import Ouroboros.Network.Protocol.ChainSync.Codec (ChainSyncTimeout (..)) import Ouroboros.Network.Protocol.Limits (shortWait) import Test.Consensus.BlockTree (BlockTree (..), btbSuffix) +import Test.Consensus.ChainGenerator.Params (Delta (Delta)) import Test.Consensus.Genesis.Setup import Test.Consensus.Genesis.Setup.Classifiers import Test.Consensus.PeerSimulator.ChainSync (chainSyncNoTimeouts) @@ -45,7 +46,6 @@ import Test.Consensus.PointSchedule.Shrinking (shrinkByRemovingAdversaries, shrinkPeerSchedules) import Test.Consensus.PointSchedule.SinglePeer (SchedulePoint (ScheduleBlockPoint, ScheduleTipPoint)) -import Test.Ouroboros.Consensus.ChainGenerator.Params (Delta (Delta)) import qualified Test.QuickCheck as QC import Test.QuickCheck import Test.Tasty diff --git a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/HardFork/Combinator/A.hs b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/HardFork/Combinator/A.hs index a98dfefecc..4c47a6b37e 100644 --- a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/HardFork/Combinator/A.hs +++ b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/HardFork/Combinator/A.hs @@ -68,7 +68,6 @@ import Ouroboros.Consensus.HardFork.History (Bound (..), import qualified Ouroboros.Consensus.HardFork.History as History import Ouroboros.Consensus.HeaderValidation import Ouroboros.Consensus.Ledger.Abstract -import Ouroboros.Consensus.Ledger.CommonProtocolParams import Ouroboros.Consensus.Ledger.Inspect import Ouroboros.Consensus.Ledger.Query import Ouroboros.Consensus.Ledger.SupportsMempool @@ -235,10 +234,6 @@ instance ApplyBlock (LedgerState BlockA) BlockA where instance UpdateLedger BlockA -instance CommonProtocolParams BlockA where - maxHeaderSize _ = maxBound - maxTxSize _ = maxBound - instance BlockSupportsProtocol BlockA where validateView _ _ = () diff --git a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/HardFork/Combinator/B.hs b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/HardFork/Combinator/B.hs index e68570ddbe..6f34a43113 100644 --- a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/HardFork/Combinator/B.hs +++ b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/HardFork/Combinator/B.hs @@ -54,7 +54,6 @@ import Ouroboros.Consensus.HardFork.Combinator.Serialisation.Common import qualified Ouroboros.Consensus.HardFork.History as History import Ouroboros.Consensus.HeaderValidation import Ouroboros.Consensus.Ledger.Abstract -import Ouroboros.Consensus.Ledger.CommonProtocolParams import Ouroboros.Consensus.Ledger.Inspect import Ouroboros.Consensus.Ledger.Query import Ouroboros.Consensus.Ledger.SupportsMempool @@ -194,10 +193,6 @@ instance ApplyBlock (LedgerState BlockB) BlockB where instance UpdateLedger BlockB -instance CommonProtocolParams BlockB where - maxHeaderSize _ = maxBound - maxTxSize _ = maxBound - instance BlockSupportsProtocol BlockB where validateView _ _ = () diff --git a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PeerSimulator/BlockFetch.hs b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PeerSimulator/BlockFetch.hs index 536a49f2fc..63eae25ba7 100644 --- a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PeerSimulator/BlockFetch.hs +++ b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PeerSimulator/BlockFetch.hs @@ -21,6 +21,7 @@ import Control.Exception (SomeException) import Control.Monad (void) import Control.Monad.Class.MonadTime import Control.Monad.Class.MonadTimer.SI (MonadTimer) +import Control.ResourceRegistry import Control.Tracer (Tracer, nullTracer, traceWith) import Data.Functor.Contravariant ((>$<)) import Data.Map.Strict (Map) @@ -36,7 +37,6 @@ import Ouroboros.Consensus.Util (ShowProxy) import Ouroboros.Consensus.Util.IOLike (DiffTime, Exception (fromException), IOLike, STM, atomically, retry, try) -import Ouroboros.Consensus.Util.ResourceRegistry import Ouroboros.Network.AnchoredFragment (AnchoredFragment) import Ouroboros.Network.BlockFetch (BlockFetchConfiguration (..), FetchClientRegistry, FetchMode (..), blockFetchLogic, diff --git a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PeerSimulator/NodeLifecycle.hs b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PeerSimulator/NodeLifecycle.hs index 3d6ea7d04e..d8a833cb77 100644 --- a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PeerSimulator/NodeLifecycle.hs +++ b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PeerSimulator/NodeLifecycle.hs @@ -13,6 +13,7 @@ module Test.Consensus.PeerSimulator.NodeLifecycle ( , restoreNode ) where +import Control.ResourceRegistry import Control.Tracer (Tracer (..), traceWith) import Data.Functor (void) import Data.Set (Set) @@ -25,7 +26,6 @@ import qualified Ouroboros.Consensus.Storage.ChainDB.Impl as ChainDB import Ouroboros.Consensus.Storage.ChainDB.Impl.Args (cdbsLoE, updateTracer) import Ouroboros.Consensus.Util.IOLike -import Ouroboros.Consensus.Util.ResourceRegistry import Ouroboros.Network.AnchoredFragment (AnchoredFragment) import qualified Ouroboros.Network.AnchoredFragment as AF import qualified System.FS.Sim.MockFS as MockFS diff --git a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PeerSimulator/Run.hs b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PeerSimulator/Run.hs index 586f7776ca..4830010144 100644 --- a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PeerSimulator/Run.hs +++ b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PeerSimulator/Run.hs @@ -13,6 +13,7 @@ module Test.Consensus.PeerSimulator.Run ( import Control.Monad (foldM, forM, void) import Control.Monad.Class.MonadTime (MonadTime) import Control.Monad.Class.MonadTimer.SI (MonadTimer) +import Control.ResourceRegistry import Control.Tracer (Tracer (..), nullTracer, traceWith) import Data.Coerce (coerce) import Data.Foldable (for_) @@ -34,7 +35,6 @@ import Ouroboros.Consensus.Storage.ChainDB.API import qualified Ouroboros.Consensus.Storage.ChainDB.API as ChainDB import Ouroboros.Consensus.Util.Condense (Condense (..)) import Ouroboros.Consensus.Util.IOLike -import Ouroboros.Consensus.Util.ResourceRegistry import Ouroboros.Consensus.Util.STM (forkLinkedWatcher) import Ouroboros.Network.AnchoredFragment (AnchoredFragment) import qualified Ouroboros.Network.AnchoredFragment as AF diff --git a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PointSchedule.hs b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PointSchedule.hs index 52990a0f9a..aa1ad904ba 100644 --- a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PointSchedule.hs +++ b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PointSchedule.hs @@ -74,6 +74,7 @@ import qualified System.Random.Stateful as Random import System.Random.Stateful (STGenM, StatefulGen, runSTGen_) import Test.Consensus.BlockTree (BlockTree (..), BlockTreeBranch (..), allFragments, prettyBlockTree) +import Test.Consensus.ChainGenerator.Params (Delta (Delta)) import Test.Consensus.PeerSimulator.StateView (StateView) import Test.Consensus.PointSchedule.NodeState (NodeState (..), genesisNodeState) @@ -85,7 +86,6 @@ import Test.Consensus.PointSchedule.SinglePeer peerScheduleFromTipPoints, schedulePointToBlock) import Test.Consensus.PointSchedule.SinglePeer.Indices (uniformRMDiffTime) -import Test.Ouroboros.Consensus.ChainGenerator.Params (Delta (Delta)) import Test.QuickCheck (Gen, arbitrary) import Test.QuickCheck.Random (QCGen) import Test.Util.TersePrinting (terseFragment) diff --git a/ouroboros-consensus-diffusion/test/mock-test/Test/ThreadNet/LeaderSchedule.hs b/ouroboros-consensus-diffusion/test/mock-test/Test/ThreadNet/LeaderSchedule.hs index 36b6259e40..b74cf5402c 100644 --- a/ouroboros-consensus-diffusion/test/mock-test/Test/ThreadNet/LeaderSchedule.hs +++ b/ouroboros-consensus-diffusion/test/mock-test/Test/ThreadNet/LeaderSchedule.hs @@ -4,7 +4,6 @@ module Test.ThreadNet.LeaderSchedule (tests) where import Control.Monad (replicateM) -import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map import Ouroboros.Consensus.Block import Ouroboros.Consensus.BlockchainTime @@ -159,18 +158,3 @@ genLeaderSchedule k (NumSlots numSlots) numCoreNodes nodeJoinPlan = nid <- elements nids xs <- go (filter (/= nid) nids) (n - 1) return $ nid : xs - -_shrinkLeaderSchedule :: NumSlots -> LeaderSchedule -> [LeaderSchedule] -_shrinkLeaderSchedule (NumSlots numSlots) (LeaderSchedule m) = - [ LeaderSchedule m' - | slot <- [0 .. fromIntegral numSlots - 1] - , m' <- reduceSlot slot m - ] - where - reduceSlot :: SlotNo -> Map SlotNo [CoreNodeId] -> [Map SlotNo [CoreNodeId]] - reduceSlot s m' = [Map.insert s xs m' | xs <- reduceList $ m' Map.! s] - - reduceList :: [a] -> [[a]] - reduceList [] = [] - reduceList [_] = [] - reduceList (x : xs) = xs : map (x :) (reduceList xs) diff --git a/ouroboros-consensus-protocol/changelog.d/weeder.md b/ouroboros-consensus-protocol/changelog.d/weeder.md new file mode 100644 index 0000000000..747a3c3dc8 --- /dev/null +++ b/ouroboros-consensus-protocol/changelog.d/weeder.md @@ -0,0 +1,3 @@ +### Breaking + +- Removed multiple unused functions thanks to `weeder`. diff --git a/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/Ledger/HotKey.hs b/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/Ledger/HotKey.hs index 8cbce77600..da8806f946 100644 --- a/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/Ledger/HotKey.hs +++ b/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/Ledger/HotKey.hs @@ -12,7 +12,6 @@ module Ouroboros.Consensus.Protocol.Ledger.HotKey ( -- * KES Info KESEvolution , KESInfo (..) - , kesAbsolutePeriod -- * KES Status , KESStatus (..) , kesStatus @@ -55,13 +54,6 @@ data KESInfo = KESInfo { } deriving (Show, Generic, NoThunks) --- | Return the absolute KES period -kesAbsolutePeriod :: KESInfo -> Absolute.KESPeriod -kesAbsolutePeriod KESInfo { kesStartPeriod, kesEvolution } = - Absolute.KESPeriod $ start + kesEvolution - where - Absolute.KESPeriod start = kesStartPeriod - {------------------------------------------------------------------------------- KES Status -------------------------------------------------------------------------------} diff --git a/ouroboros-consensus-protocol/test/protocol-test/Test/Consensus/Protocol/Praos/SelectView.hs b/ouroboros-consensus-protocol/test/protocol-test/Test/Consensus/Protocol/Praos/SelectView.hs index 87bfb3b343..3aa7d66d99 100644 --- a/ouroboros-consensus-protocol/test/protocol-test/Test/Consensus/Protocol/Praos/SelectView.hs +++ b/ouroboros-consensus-protocol/test/protocol-test/Test/Consensus/Protocol/Praos/SelectView.hs @@ -20,7 +20,7 @@ import Data.Containers.ListUtils (nubOrdOn) import Ouroboros.Consensus.Block import Ouroboros.Consensus.Protocol.Praos.Common import Test.Cardano.Ledger.Binary.Arbitrary () -import Test.Ouroboros.Consensus.Protocol +import Test.Consensus.Protocol import Test.QuickCheck.Gen (Gen (..)) import Test.QuickCheck.Random (mkQCGen) import Test.Tasty diff --git a/ouroboros-consensus/CHANGELOG.md b/ouroboros-consensus/CHANGELOG.md index 26f0239538..cc44516319 100644 --- a/ouroboros-consensus/CHANGELOG.md +++ b/ouroboros-consensus/CHANGELOG.md @@ -264,7 +264,7 @@ ### Non-Breaking - Add `StrictMVar`s with default `NoThunks` invariants - `Ouroboros.Consensus.Util.NormalForm.StrictMVar`. + `Control.Concurrent.Class.MonadMVar.NormalForm`. ### Breaking diff --git a/ouroboros-consensus/bench/ChainSync-client-bench/Main.hs b/ouroboros-consensus/bench/ChainSync-client-bench/Main.hs index e1e69b3da1..55413ac381 100644 --- a/ouroboros-consensus/bench/ChainSync-client-bench/Main.hs +++ b/ouroboros-consensus/bench/ChainSync-client-bench/Main.hs @@ -6,6 +6,7 @@ module Main (main) where import Bench.Consensus.ChainSyncClient.Driver (mainWith) import Cardano.Crypto.DSIGN.Mock import Control.Monad (void) +import Control.ResourceRegistry import Control.Tracer (contramap, debugTracer, nullTracer) import Data.IORef (newIORef, readIORef, writeIORef) import qualified Data.List.NonEmpty as NE @@ -32,7 +33,6 @@ import Ouroboros.Consensus.NodeId import Ouroboros.Consensus.Protocol.BFT import qualified Ouroboros.Consensus.Storage.ChainDB.API as ChainDB import Ouroboros.Consensus.Util.IOLike -import Ouroboros.Consensus.Util.ResourceRegistry import Ouroboros.Consensus.Util.STM (Fingerprint (..), WithFingerprint (..)) import Ouroboros.Consensus.Util.Time (secondsToNominalDiffTime) diff --git a/ouroboros-consensus/bench/mempool-bench/Bench/Consensus/Mempool.hs b/ouroboros-consensus/bench/mempool-bench/Bench/Consensus/Mempool.hs index b430a1eb2d..145079f18e 100644 --- a/ouroboros-consensus/bench/mempool-bench/Bench/Consensus/Mempool.hs +++ b/ouroboros-consensus/bench/mempool-bench/Bench/Consensus/Mempool.hs @@ -11,8 +11,6 @@ module Bench.Consensus.Mempool ( MempoolCmd (..) -- ** Queries on commands , getCmdTx - , getCmdTxId - , getCmdsTxIds , getCmdsTxs -- * Commands execution , run @@ -51,15 +49,6 @@ getCmdTx (AddTx tx) = Just tx getCmdsTxs :: [MempoolCmd blk] -> [Ledger.GenTx blk] getCmdsTxs = mapMaybe getCmdTx -getCmdTxId :: - Ledger.HasTxId (Ledger.GenTx blk) - => MempoolCmd blk -> Maybe (Ledger.TxId (Ledger.GenTx blk)) -getCmdTxId = fmap Ledger.txId . getCmdTx - -getCmdsTxIds :: - Ledger.HasTxId (Ledger.GenTx blk) - => [MempoolCmd blk] -> [Ledger.TxId (Ledger.GenTx blk)] -getCmdsTxIds = mapMaybe getCmdTxId {------------------------------------------------------------------------------- Commands execution diff --git a/ouroboros-consensus/bench/mempool-bench/Bench/Consensus/Mempool/TestBlock.hs b/ouroboros-consensus/bench/mempool-bench/Bench/Consensus/Mempool/TestBlock.hs index 989ce7ff24..25435ed599 100644 --- a/ouroboros-consensus/bench/mempool-bench/Bench/Consensus/Mempool/TestBlock.hs +++ b/ouroboros-consensus/bench/mempool-bench/Bench/Consensus/Mempool/TestBlock.hs @@ -116,7 +116,7 @@ data instance Block.StorageConfig TestBlock = TestBlockStorageConfig Mempool support -------------------------------------------------------------------------------} -newtype instance Ledger.GenTx TestBlock = TestBlockGenTx { unGenTx :: Tx } +newtype instance Ledger.GenTx TestBlock = TestBlockGenTx Tx deriving stock (Generic) deriving newtype (Show, NoThunks, Eq, Ord, NFData) diff --git a/ouroboros-consensus/changelog.d/20240823_175823_alexander.esgen_weeder.md b/ouroboros-consensus/changelog.d/20240823_175823_alexander.esgen_weeder.md new file mode 100644 index 0000000000..574200bfd1 --- /dev/null +++ b/ouroboros-consensus/changelog.d/20240823_175823_alexander.esgen_weeder.md @@ -0,0 +1,3 @@ +### Breaking + +- Removed `CommonProtocolParams` and associated instances. diff --git a/ouroboros-consensus/changelog.d/weeder.md b/ouroboros-consensus/changelog.d/weeder.md new file mode 100644 index 0000000000..747a3c3dc8 --- /dev/null +++ b/ouroboros-consensus/changelog.d/weeder.md @@ -0,0 +1,3 @@ +### Breaking + +- Removed multiple unused functions thanks to `weeder`. diff --git a/ouroboros-consensus/ouroboros-consensus.cabal b/ouroboros-consensus/ouroboros-consensus.cabal index dd634766c9..1f8b64faee 100644 --- a/ouroboros-consensus/ouroboros-consensus.cabal +++ b/ouroboros-consensus/ouroboros-consensus.cabal @@ -103,7 +103,6 @@ library Ouroboros.Consensus.HardFork.Combinator.AcrossEras Ouroboros.Consensus.HardFork.Combinator.Basics Ouroboros.Consensus.HardFork.Combinator.Block - Ouroboros.Consensus.HardFork.Combinator.Compat Ouroboros.Consensus.HardFork.Combinator.Condense Ouroboros.Consensus.HardFork.Combinator.Degenerate Ouroboros.Consensus.HardFork.Combinator.Embed.Binary @@ -113,7 +112,6 @@ library Ouroboros.Consensus.HardFork.Combinator.Info Ouroboros.Consensus.HardFork.Combinator.InjectTxs Ouroboros.Consensus.HardFork.Combinator.Ledger - Ouroboros.Consensus.HardFork.Combinator.Ledger.CommonProtocolParams Ouroboros.Consensus.HardFork.Combinator.Ledger.PeerSelection Ouroboros.Consensus.HardFork.Combinator.Ledger.Query Ouroboros.Consensus.HardFork.Combinator.Lifting @@ -150,7 +148,6 @@ library Ouroboros.Consensus.HeaderValidation Ouroboros.Consensus.Ledger.Abstract Ouroboros.Consensus.Ledger.Basics - Ouroboros.Consensus.Ledger.CommonProtocolParams Ouroboros.Consensus.Ledger.Dual Ouroboros.Consensus.Ledger.Extended Ouroboros.Consensus.Ledger.Inspect @@ -256,17 +253,11 @@ library Ouroboros.Consensus.Util.EarlyExit Ouroboros.Consensus.Util.Enclose Ouroboros.Consensus.Util.FileLock - Ouroboros.Consensus.Util.HList Ouroboros.Consensus.Util.IOLike Ouroboros.Consensus.Util.LeakyBucket - Ouroboros.Consensus.Util.MonadSTM.NormalForm Ouroboros.Consensus.Util.MonadSTM.RAWLock - Ouroboros.Consensus.Util.MonadSTM.StrictSVar - Ouroboros.Consensus.Util.NormalForm.StrictMVar - Ouroboros.Consensus.Util.NormalForm.StrictTVar Ouroboros.Consensus.Util.Orphans Ouroboros.Consensus.Util.RedundantConstraints - Ouroboros.Consensus.Util.ResourceRegistry Ouroboros.Consensus.Util.STM Ouroboros.Consensus.Util.Time Ouroboros.Consensus.Util.Versioned @@ -292,6 +283,7 @@ library io-classes ^>=1.5, measures, mtl, + nf-vars ^>=0.1, nothunks ^>=0.1.5, ouroboros-network-api ^>=0.7.3, ouroboros-network-mock ^>=0.1, @@ -300,15 +292,14 @@ library psqueues ^>=0.2.3, quiet ^>=0.2, reflection, + resource-registry ^>=0.1, semialign >=1.1, serialise ^>=0.2, si-timers ^>=1.5, sop-core ^>=0.5, sop-extras ^>=0.2, streaming, - strict-checked-vars ^>=0.2, strict-sop-core ^>=0.1, - strict-stm ^>=1.5, text, these ^>=1.2, time, @@ -327,16 +318,16 @@ library unstable-consensus-testlib visibility: public hs-source-dirs: src/unstable-consensus-testlib exposed-modules: - Test.Ouroboros.Consensus.ChainGenerator.Adversarial - Test.Ouroboros.Consensus.ChainGenerator.BitVector - Test.Ouroboros.Consensus.ChainGenerator.Counting - Test.Ouroboros.Consensus.ChainGenerator.Honest - Test.Ouroboros.Consensus.ChainGenerator.Params - Test.Ouroboros.Consensus.ChainGenerator.RaceIterator - Test.Ouroboros.Consensus.ChainGenerator.Slot - Test.Ouroboros.Consensus.ChainGenerator.Some - Test.Ouroboros.Consensus.DiffusionPipelining - Test.Ouroboros.Consensus.Protocol + Test.Consensus.ChainGenerator.Adversarial + Test.Consensus.ChainGenerator.BitVector + Test.Consensus.ChainGenerator.Counting + Test.Consensus.ChainGenerator.Honest + Test.Consensus.ChainGenerator.Params + Test.Consensus.ChainGenerator.RaceIterator + Test.Consensus.ChainGenerator.Slot + Test.Consensus.ChainGenerator.Some + Test.Consensus.DiffusionPipelining + Test.Consensus.Protocol Test.QuickCheck.Extras Test.Util.BoolProps Test.Util.ChainDB @@ -356,7 +347,6 @@ library unstable-consensus-testlib Test.Util.Orphans.SignableRepresentation Test.Util.Orphans.ToExpr Test.Util.Paths - Test.Util.QSM Test.Util.QuickCheck Test.Util.Range Test.Util.RefEnv @@ -404,6 +394,7 @@ library unstable-consensus-testlib io-classes, io-sim, mtl, + nf-vars, nothunks, optparse-applicative, ouroboros-consensus, @@ -414,11 +405,11 @@ library unstable-consensus-testlib quickcheck-state-machine:no-vendored-treediff ^>=0.10, quiet, random, + resource-registry, serialise, si-timers, sop-core, sop-extras, - strict-checked-vars, strict-sop-core, tasty, tasty-golden, @@ -528,8 +519,6 @@ test-suite consensus-test Test.Consensus.MiniProtocol.BlockFetch.Client Test.Consensus.MiniProtocol.ChainSync.Client Test.Consensus.MiniProtocol.LocalStateQuery.Server - Test.Consensus.ResourceRegistry - Test.Consensus.Util.MonadSTM.NormalForm Test.Consensus.Util.MonadSTM.RAWLock Test.Consensus.Util.Versioned @@ -546,7 +535,6 @@ test-suite consensus-test contra-tracer, deepseq, fs-api ^>=0.2.0.1, - generics-sop, hashable, io-classes, io-sim, @@ -557,9 +545,9 @@ test-suite consensus-test ouroboros-network-api, ouroboros-network-mock, ouroboros-network-protocols:{ouroboros-network-protocols, testlib}, - quickcheck-state-machine:no-vendored-treediff, quiet, random, + resource-registry, serialise, si-timers, sop-core, @@ -569,7 +557,6 @@ test-suite consensus-test tasty-hunit, tasty-quickcheck, time, - tree-diff, typed-protocols ^>=0.1.1, typed-protocols-examples, unstable-consensus-testlib, @@ -582,12 +569,12 @@ test-suite infra-test main-is: Main.hs other-modules: Ouroboros.Consensus.Util.Tests - Test.Ouroboros.Consensus.ChainGenerator.Tests - Test.Ouroboros.Consensus.ChainGenerator.Tests.Adversarial - Test.Ouroboros.Consensus.ChainGenerator.Tests.BitVector - Test.Ouroboros.Consensus.ChainGenerator.Tests.Counting - Test.Ouroboros.Consensus.ChainGenerator.Tests.Honest - Test.Ouroboros.Consensus.Util.LeakyBucket.Tests + Test.Consensus.ChainGenerator.Tests + Test.Consensus.ChainGenerator.Tests.Adversarial + Test.Consensus.ChainGenerator.Tests.BitVector + Test.Consensus.ChainGenerator.Tests.Counting + Test.Consensus.ChainGenerator.Tests.Honest + Test.Consensus.Util.LeakyBucket.Tests Test.Util.ChainUpdates.Tests Test.Util.Schedule.Tests Test.Util.Split.Tests @@ -612,33 +599,33 @@ test-suite storage-test hs-source-dirs: test/storage-test main-is: Main.hs other-modules: - Test.Ouroboros.Storage - Test.Ouroboros.Storage.ChainDB - Test.Ouroboros.Storage.ChainDB.FollowerPromptness - Test.Ouroboros.Storage.ChainDB.GcSchedule - Test.Ouroboros.Storage.ChainDB.Iterator - Test.Ouroboros.Storage.ChainDB.Model - Test.Ouroboros.Storage.ChainDB.Model.Test - Test.Ouroboros.Storage.ChainDB.Paths - Test.Ouroboros.Storage.ChainDB.StateMachine - Test.Ouroboros.Storage.ChainDB.StateMachine.Utils.RunOnRepl - Test.Ouroboros.Storage.ChainDB.Unit - Test.Ouroboros.Storage.ImmutableDB - Test.Ouroboros.Storage.ImmutableDB.Mock - Test.Ouroboros.Storage.ImmutableDB.Model - Test.Ouroboros.Storage.ImmutableDB.Primary - Test.Ouroboros.Storage.ImmutableDB.StateMachine - Test.Ouroboros.Storage.LedgerDB - Test.Ouroboros.Storage.LedgerDB.DiskPolicy - Test.Ouroboros.Storage.LedgerDB.InMemory - Test.Ouroboros.Storage.LedgerDB.OnDisk - Test.Ouroboros.Storage.LedgerDB.OrphanArbitrary - Test.Ouroboros.Storage.Orphans - Test.Ouroboros.Storage.TestBlock - Test.Ouroboros.Storage.VolatileDB - Test.Ouroboros.Storage.VolatileDB.Mock - Test.Ouroboros.Storage.VolatileDB.Model - Test.Ouroboros.Storage.VolatileDB.StateMachine + Test.Consensus.Storage + Test.Consensus.Storage.ChainDB + Test.Consensus.Storage.ChainDB.FollowerPromptness + Test.Consensus.Storage.ChainDB.GcSchedule + Test.Consensus.Storage.ChainDB.Iterator + Test.Consensus.Storage.ChainDB.Model + Test.Consensus.Storage.ChainDB.Model.Test + Test.Consensus.Storage.ChainDB.Paths + Test.Consensus.Storage.ChainDB.StateMachine + Test.Consensus.Storage.ChainDB.StateMachine.Utils.RunOnRepl + Test.Consensus.Storage.ChainDB.Unit + Test.Consensus.Storage.ImmutableDB + Test.Consensus.Storage.ImmutableDB.Mock + Test.Consensus.Storage.ImmutableDB.Model + Test.Consensus.Storage.ImmutableDB.Primary + Test.Consensus.Storage.ImmutableDB.StateMachine + Test.Consensus.Storage.LedgerDB + Test.Consensus.Storage.LedgerDB.DiskPolicy + Test.Consensus.Storage.LedgerDB.InMemory + Test.Consensus.Storage.LedgerDB.OnDisk + Test.Consensus.Storage.LedgerDB.OrphanArbitrary + Test.Consensus.Storage.Orphans + Test.Consensus.Storage.TestBlock + Test.Consensus.Storage.VolatileDB + Test.Consensus.Storage.VolatileDB.Mock + Test.Consensus.Storage.VolatileDB.Model + Test.Consensus.Storage.VolatileDB.StateMachine build-depends: QuickCheck, @@ -662,9 +649,8 @@ test-suite storage-test ouroboros-consensus, ouroboros-network-api, ouroboros-network-mock, - pretty-show, quickcheck-state-machine:no-vendored-treediff ^>=0.10, - random, + resource-registry, serialise, tasty, tasty-hunit, @@ -722,6 +708,7 @@ benchmark ChainSync-client-bench ouroboros-consensus, ouroboros-network-api, ouroboros-network-protocols, + resource-registry, time, typed-protocols-examples, unstable-consensus-testlib, @@ -733,7 +720,6 @@ test-suite doctest type: exitcode-stdio-1.0 hs-source-dirs: test default-language: Haskell2010 - ghc-options: -Wno-unused-packages build-depends: base, latex-svg-image, diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Block/NestedContent.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Block/NestedContent.hs index 52a24d8508..04dee907af 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Block/NestedContent.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Block/NestedContent.hs @@ -15,13 +15,11 @@ module Ouroboros.Consensus.Block.NestedContent ( -- * Block contents HasNestedContent (..) , NestedCtxt_ - , curriedNest -- * Flip type arguments , NestedCtxt (..) , castNestedCtxt , mapNestedCtxt -- * Existentials - , castSomeNestedCtxt , mapSomeNestedCtxt -- * Convenience re-exports , module Ouroboros.Consensus.Util.DepPair @@ -92,9 +90,6 @@ class ( forall a. Show (NestedCtxt_ blk f a) => DepPair (NestedCtxt f blk) -> f blk nest (DepPair x y) = fromTrivialDependency x y -curriedNest :: HasNestedContent f blk => NestedCtxt f blk a -> a -> f blk -curriedNest ctxt a = nest (DepPair ctxt a) - -- | Context identifying what kind of block we have -- -- In almost all places we will use 'NestedCtxt' rather than 'NestedCtxt_'. @@ -162,11 +157,6 @@ instance SameDepIndex (NestedCtxt_ blk f) => Eq (SomeSecond (NestedCtxt f) blk) where SomeSecond ctxt == SomeSecond ctxt' = isJust (sameDepIndex ctxt ctxt') -castSomeNestedCtxt :: (forall a. NestedCtxt_ blk f a -> NestedCtxt_ blk' f a) - -> SomeSecond (NestedCtxt f) blk - -> SomeSecond (NestedCtxt f) blk' -castSomeNestedCtxt coerce (SomeSecond ctxt) = SomeSecond (castNestedCtxt coerce ctxt) - mapSomeNestedCtxt :: (forall a. NestedCtxt_ blk f a -> NestedCtxt_ blk' f' a) -> SomeSecond (NestedCtxt f) blk -> SomeSecond (NestedCtxt f') blk' diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/BlockchainTime/WallClock/HardFork.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/BlockchainTime/WallClock/HardFork.hs index fa8d5cbb31..dfe8f45a05 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/BlockchainTime/WallClock/HardFork.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/BlockchainTime/WallClock/HardFork.hs @@ -8,6 +8,7 @@ module Ouroboros.Consensus.BlockchainTime.WallClock.HardFork ( ) where import Control.Monad +import Control.ResourceRegistry import Control.Tracer import Data.Time (NominalDiffTime) import Data.Void @@ -19,7 +20,6 @@ import Ouroboros.Consensus.HardFork.Abstract import qualified Ouroboros.Consensus.HardFork.History as HF import Ouroboros.Consensus.Ledger.Abstract import Ouroboros.Consensus.Util.IOLike -import Ouroboros.Consensus.Util.ResourceRegistry import Ouroboros.Consensus.Util.Time -- | A backoff delay diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/BlockchainTime/WallClock/Simple.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/BlockchainTime/WallClock/Simple.hs index 941d32dd05..237f36f672 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/BlockchainTime/WallClock/Simple.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/BlockchainTime/WallClock/Simple.hs @@ -10,6 +10,7 @@ module Ouroboros.Consensus.BlockchainTime.WallClock.Simple ( ) where import Control.Monad +import Control.ResourceRegistry import Data.Bifunctor import Data.Fixed (divMod') import Data.Time (NominalDiffTime) @@ -19,7 +20,6 @@ import Ouroboros.Consensus.BlockchainTime.API import Ouroboros.Consensus.BlockchainTime.WallClock.Types import Ouroboros.Consensus.BlockchainTime.WallClock.Util import Ouroboros.Consensus.Util.IOLike -import Ouroboros.Consensus.Util.ResourceRegistry import Ouroboros.Consensus.Util.Time -- | Real blockchain time diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Config.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Config.hs index 28fe85ccd5..24a525be61 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Config.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Config.hs @@ -1,15 +1,12 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} module Ouroboros.Consensus.Config ( -- * The top-level node configuration TopLevelConfig (..) - , castTopLevelConfig , mkTopLevelConfig -- ** Checkpoints map , CheckpointsMap (..) @@ -106,25 +103,6 @@ configSecurityParam :: ConsensusProtocol (BlockProtocol blk) => TopLevelConfig blk -> SecurityParam configSecurityParam = protocolSecurityParam . configConsensus -castTopLevelConfig :: - ( Coercible (ConsensusConfig (BlockProtocol blk)) - (ConsensusConfig (BlockProtocol blk')) - , LedgerConfig blk ~ LedgerConfig blk' - , Coercible (BlockConfig blk) (BlockConfig blk') - , Coercible (CodecConfig blk) (CodecConfig blk') - , Coercible (StorageConfig blk) (StorageConfig blk') - , Coercible (HeaderHash blk) (HeaderHash blk') - ) - => TopLevelConfig blk -> TopLevelConfig blk' -castTopLevelConfig TopLevelConfig{..} = TopLevelConfig{ - topLevelConfigProtocol = coerce topLevelConfigProtocol - , topLevelConfigLedger = topLevelConfigLedger - , topLevelConfigBlock = coerce topLevelConfigBlock - , topLevelConfigCodec = coerce topLevelConfigCodec - , topLevelConfigStorage = coerce topLevelConfigStorage - , topLevelConfigCheckpoints = coerce topLevelConfigCheckpoints - } - castCheckpointsMap :: Coercible (HeaderHash blk) (HeaderHash blk') => CheckpointsMap blk -> CheckpointsMap blk' diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Fragment/Validated.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Fragment/Validated.hs index 56c97b996e..c800f01178 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Fragment/Validated.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Fragment/Validated.hs @@ -13,7 +13,6 @@ module Ouroboros.Consensus.Fragment.Validated ( ValidatedFragment (ValidatedFragment) , validatedFragment , validatedLedger - , validatedTip ) where import GHC.Stack @@ -46,9 +45,6 @@ pattern ValidatedFragment f l <- UnsafeValidatedFragment f l where ValidatedFragment f l = new f l -validatedTip :: HasHeader b => ValidatedFragment b l -> Point b -validatedTip = AF.headPoint . validatedFragment - invariant :: forall l b. (GetTip l, HasHeader b, HeaderHash b ~ HeaderHash l) diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator.hs index 843b294ffa..5a1ad8d4e3 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator.hs @@ -27,7 +27,6 @@ import Ouroboros.Consensus.HardFork.Combinator.InjectTxs as X cannotInjectValidatedTx, pattern InjectTx, pattern InjectValidatedTx) import Ouroboros.Consensus.HardFork.Combinator.Ledger as X -import Ouroboros.Consensus.HardFork.Combinator.Ledger.CommonProtocolParams as X () import Ouroboros.Consensus.HardFork.Combinator.Ledger.PeerSelection as X () import Ouroboros.Consensus.HardFork.Combinator.Ledger.Query as X import Ouroboros.Consensus.HardFork.Combinator.Mempool as X diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Abstract/SingleEraBlock.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Abstract/SingleEraBlock.hs index 1fe146150a..0fcba1bb2a 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Abstract/SingleEraBlock.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Abstract/SingleEraBlock.hs @@ -1,5 +1,4 @@ {-# LANGUAGE DataKinds #-} -{-# LANGUAGE EmptyCase #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} @@ -13,11 +12,9 @@ module Ouroboros.Consensus.HardFork.Combinator.Abstract.SingleEraBlock ( , singleEraTransition' -- * Era index , EraIndex (..) - , eraIndexEmpty , eraIndexFromIndex , eraIndexFromNS , eraIndexSucc - , eraIndexToInt , eraIndexZero ) where @@ -30,7 +27,6 @@ import Data.SOP.Index import Data.SOP.Match import Data.SOP.Strict import qualified Data.Text as Text -import Data.Void import NoThunks.Class (NoThunks) import Ouroboros.Consensus.Block import Ouroboros.Consensus.Config.SupportsNode @@ -38,7 +34,6 @@ import Ouroboros.Consensus.HardFork.Combinator.Info import Ouroboros.Consensus.HardFork.Combinator.PartialConfig import Ouroboros.Consensus.HardFork.History (Bound, EraParams) import Ouroboros.Consensus.Ledger.Abstract -import Ouroboros.Consensus.Ledger.CommonProtocolParams import Ouroboros.Consensus.Ledger.Inspect import Ouroboros.Consensus.Ledger.Query import Ouroboros.Consensus.Ledger.SupportsMempool @@ -62,7 +57,6 @@ class ( LedgerSupportsProtocol blk , HasPartialLedgerConfig blk , ConvertRawHash blk , ReconstructNestedCtxt Header blk - , CommonProtocolParams blk , LedgerSupportsPeerSelection blk , ConfigSupportsNode blk , NodeInitStorage blk @@ -151,9 +145,6 @@ instance SListI xs => Serialise (EraIndex xs) where Nothing -> fail $ "EraIndex: invalid index " <> show idx Just eraIndex -> return (EraIndex eraIndex) -eraIndexEmpty :: EraIndex '[] -> Void -eraIndexEmpty (EraIndex ns) = case ns of {} - eraIndexFromNS :: SListI xs => NS f xs -> EraIndex xs eraIndexFromNS = EraIndex . hmap (const (K ())) @@ -165,6 +156,3 @@ eraIndexZero = EraIndex (Z (K ())) eraIndexSucc :: EraIndex xs -> EraIndex (x ': xs) eraIndexSucc (EraIndex ix) = EraIndex (S ix) - -eraIndexToInt :: EraIndex xs -> Int -eraIndexToInt = index_NS . getEraIndex diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/AcrossEras.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/AcrossEras.hs index 0fa2e469a6..7de35d02d5 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/AcrossEras.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/AcrossEras.hs @@ -57,7 +57,6 @@ module Ouroboros.Consensus.HardFork.Combinator.AcrossEras ( , MismatchEraInfo (..) , mismatchFutureEra , mismatchOneEra - , mkEraMismatch -- * Utility , getSameValue , oneEraBlockHeader @@ -217,32 +216,6 @@ data EraMismatch = EraMismatch { } deriving (Eq, Show, Generic) --- | When a transaction or block from a certain era was applied to a ledger --- from another era, we get a 'MismatchEraInfo'. --- --- Given such a 'MismatchEraInfo', return the name of the era of the --- transaction/block and the name of the era of the ledger. -mkEraMismatch :: SListI xs => MismatchEraInfo xs -> EraMismatch -mkEraMismatch (MismatchEraInfo mismatch) = - go mismatch - where - go :: SListI xs => Mismatch SingleEraInfo LedgerEraInfo xs -> EraMismatch - go (Match.ML otherEra ledgerEra) = EraMismatch { - ledgerEraName = hcollapse $ hmap (K . ledgerName) ledgerEra - , otherEraName = otherName otherEra - } - go (Match.MR otherEra ledgerEra) = EraMismatch { - ledgerEraName = ledgerName ledgerEra - , otherEraName = hcollapse $ hmap (K . otherName) otherEra - } - go (Match.MS m) = go m - - ledgerName :: LedgerEraInfo blk -> Text - ledgerName = singleEraName . getLedgerEraInfo - - otherName :: SingleEraInfo blk -> Text - otherName = singleEraName - {------------------------------------------------------------------------------- Utility -------------------------------------------------------------------------------} diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Compat.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Compat.hs deleted file mode 100644 index 0c7739d39c..0000000000 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Compat.hs +++ /dev/null @@ -1,122 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeOperators #-} - -module Ouroboros.Consensus.HardFork.Combinator.Compat ( - HardForkCompatQuery (..) - -- * Convenience constructors - , compatGetEraStart - , compatGetInterpreter - , compatIfCurrent - -- * Wrappers - , forwardCompatQuery - , singleEraCompatQuery - ) where - -import Data.Kind (Type) -import Data.SOP.BasicFunctors -import Data.SOP.NonEmpty -import Data.SOP.Strict -import Ouroboros.Consensus.Block -import Ouroboros.Consensus.BlockchainTime -import Ouroboros.Consensus.HardFork.Abstract -import Ouroboros.Consensus.HardFork.Combinator.Abstract.SingleEraBlock -import Ouroboros.Consensus.HardFork.Combinator.Basics -import Ouroboros.Consensus.HardFork.Combinator.Ledger.Query -import qualified Ouroboros.Consensus.HardFork.History.Qry as Qry -import Ouroboros.Consensus.HardFork.History.Summary (Bound, Summary, - initBound, neverForksSummary) - -{------------------------------------------------------------------------------- - Query language --------------------------------------------------------------------------------} - --- | Version of @Query (HardForkBlock xs)@ without the restriction to have --- at least two eras -data HardForkCompatQuery blk :: Type -> Type where - CompatIfCurrent :: - BlockQuery blk result - -> HardForkCompatQuery blk result - - CompatAnytime :: - QueryAnytime result - -> EraIndex (HardForkIndices blk) - -> HardForkCompatQuery blk result - - CompatHardFork :: - QueryHardFork (HardForkIndices blk) result - -> HardForkCompatQuery blk result - -{------------------------------------------------------------------------------- - Convenience constructors for 'HardForkCompatQuery' --------------------------------------------------------------------------------} - --- | Submit query to underlying ledger -compatIfCurrent :: - BlockQuery blk result - -> HardForkCompatQuery blk result -compatIfCurrent = CompatIfCurrent - --- | Get the start of the specified era, if known -compatGetEraStart :: - EraIndex (HardForkIndices blk) - -> HardForkCompatQuery blk (Maybe Bound) -compatGetEraStart = CompatAnytime GetEraStart - --- | Get an interpreter for history queries --- --- I.e., this can be used for slot/epoch/time conversions. -compatGetInterpreter :: - HardForkCompatQuery blk (Qry.Interpreter (HardForkIndices blk)) -compatGetInterpreter = CompatHardFork GetInterpreter - -{------------------------------------------------------------------------------- - Wrappers --------------------------------------------------------------------------------} - --- | Wrapper used when connecting to a server that's running the HFC with --- at least two eras -forwardCompatQuery :: - forall m x xs. IsNonEmpty xs - => (forall result. BlockQuery (HardForkBlock (x ': xs)) result -> m result) - -- ^ Submit a query through the LocalStateQuery protocol. - -> (forall result. HardForkCompatQuery (HardForkBlock (x ': xs)) result -> m result) -forwardCompatQuery f = go - where - go :: HardForkCompatQuery (HardForkBlock (x ': xs)) result -> m result - go (CompatIfCurrent qry) = f qry - go (CompatAnytime qry ix) = f (QueryAnytime qry ix) - go (CompatHardFork qry) = f (QueryHardFork qry) - --- | Wrapper used when connecting to a server that's not using the HFC, or --- is using the HFC but with a single era only. -singleEraCompatQuery :: - forall m blk era. (Monad m, HardForkIndices blk ~ '[era]) - => EpochSize - -> SlotLength - -> GenesisWindow - -> (forall result. BlockQuery blk result -> m result) - -- ^ Submit a query through the LocalStateQuery protocol. - -> (forall result. HardForkCompatQuery blk result -> m result) -singleEraCompatQuery epochSize slotLen genesisWindow f = go - where - go :: HardForkCompatQuery blk result -> m result - go (CompatIfCurrent qry) = f qry - go (CompatAnytime qry ix) = const (goAnytime qry) (trivialIndex ix) - go (CompatHardFork qry) = goHardFork qry - - goAnytime :: QueryAnytime result -> m result - goAnytime GetEraStart = return $ Just initBound - - goHardFork :: QueryHardFork '[era] result -> m result - goHardFork GetInterpreter = return $ Qry.mkInterpreter summary - goHardFork GetCurrentEra = return $ eraIndexZero - - summary :: Summary '[era] - summary = neverForksSummary epochSize slotLen genesisWindow - - trivialIndex :: EraIndex '[era] -> () - trivialIndex (EraIndex (Z (K ()))) = () diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Degenerate.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Degenerate.hs index 7b56630683..113aba1c85 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Degenerate.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Degenerate.hs @@ -5,7 +5,6 @@ {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE ViewPatterns #-} @@ -14,10 +13,8 @@ module Ouroboros.Consensus.HardFork.Combinator.Degenerate ( -- * Pattern synonyms BlockConfig (DegenBlockConfig) - , BlockQuery (DegenQuery) , CodecConfig (DegenCodecConfig) , ConsensusConfig (DegenConsensusConfig) - , Either (DegenQueryResult) , GenTx (DegenGenTx) , HardForkApplyTxErr (DegenApplyTxErr) , HardForkBlock (DegenBlock) @@ -39,8 +36,6 @@ import Ouroboros.Consensus.HardFork.Combinator.AcrossEras import Ouroboros.Consensus.HardFork.Combinator.Basics import Ouroboros.Consensus.HardFork.Combinator.Embed.Unary import Ouroboros.Consensus.HardFork.Combinator.Ledger -import Ouroboros.Consensus.HardFork.Combinator.Ledger.CommonProtocolParams () -import Ouroboros.Consensus.HardFork.Combinator.Ledger.Query import Ouroboros.Consensus.HardFork.Combinator.Mempool import Ouroboros.Consensus.HardFork.Combinator.Node () import Ouroboros.Consensus.HardFork.Combinator.PartialConfig @@ -66,8 +61,6 @@ import Ouroboros.Consensus.TypeFamilyWrappers {-# COMPLETE DegenLedgerError #-} {-# COMPLETE DegenLedgerState #-} {-# COMPLETE DegenOtherHeaderEnvelopeError #-} -{-# COMPLETE DegenQuery #-} -{-# COMPLETE DegenQueryResult #-} {-# COMPLETE DegenTipInfo #-} pattern DegenBlock :: @@ -134,22 +127,6 @@ pattern DegenTipInfo x <- (project' (Proxy @(WrapTipInfo b)) -> x) where DegenTipInfo x = inject' (Proxy @(WrapTipInfo b)) x -pattern DegenQuery :: - () - => HardForkQueryResult '[b] result ~ a - => BlockQuery b result - -> BlockQuery (HardForkBlock '[b]) a -pattern DegenQuery x <- (projQuery' -> ProjHardForkQuery x) - where - DegenQuery x = injQuery x - -pattern DegenQueryResult :: - result - -> HardForkQueryResult '[b] result -pattern DegenQueryResult x <- (projQueryResult -> x) - where - DegenQueryResult x = injQueryResult x - pattern DegenCodecConfig :: NoHardForks b => CodecConfig b diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Embed/Unary.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Embed/Unary.hs index 612723d97d..c6c23456d3 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Embed/Unary.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Embed/Unary.hs @@ -1,6 +1,5 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE DerivingVia #-} -{-# LANGUAGE EmptyCase #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} @@ -19,14 +18,8 @@ module Ouroboros.Consensus.HardFork.Combinator.Embed.Unary ( , inject' , project' -- * Dependent types - , ProjHardForkQuery (..) , injNestedCtxt - , injQuery - , injQueryResult , projNestedCtxt - , projQuery - , projQuery' - , projQueryResult -- * Convenience exports , I (..) , Proxy (..) @@ -35,13 +28,11 @@ module Ouroboros.Consensus.HardFork.Combinator.Embed.Unary ( import Cardano.Slotting.EpochInfo import Data.Bifunctor (first) import Data.Coerce -import Data.Kind (Type) import Data.Proxy import Data.SOP.BasicFunctors import qualified Data.SOP.OptNP as OptNP import Data.SOP.Strict import qualified Data.SOP.Telescope as Telescope -import Data.Type.Equality import Data.Void import Ouroboros.Consensus.Block import Ouroboros.Consensus.Config @@ -51,7 +42,6 @@ import Ouroboros.Consensus.HardFork.Combinator.Basics import Ouroboros.Consensus.HardFork.Combinator.Block import Ouroboros.Consensus.HardFork.Combinator.Forging import Ouroboros.Consensus.HardFork.Combinator.Ledger -import Ouroboros.Consensus.HardFork.Combinator.Ledger.Query import Ouroboros.Consensus.HardFork.Combinator.Mempool import Ouroboros.Consensus.HardFork.Combinator.PartialConfig import Ouroboros.Consensus.HardFork.Combinator.Protocol @@ -608,49 +598,6 @@ instance Isomorphic SerialisedHeader where TODO: Class? -------------------------------------------------------------------------------} --- | Project 'BlockQuery' --- --- Not an instance of 'Isomorphic' because the types change. -projQuery :: BlockQuery (HardForkBlock '[b]) result - -> (forall result'. - (result :~: HardForkQueryResult '[b] result') - -> BlockQuery b result' - -> a) - -> a -projQuery qry k = - getHardForkQuery - qry - (\Refl -> k Refl . aux) - (\Refl prfNonEmpty _ _ -> case prfNonEmpty of {}) - (\Refl prfNonEmpty _ -> case prfNonEmpty of {}) - where - aux :: QueryIfCurrent '[b] result -> BlockQuery b result - aux (QZ q) = q - aux (QS q) = case q of {} - -projQuery' :: BlockQuery (HardForkBlock '[b]) result - -> ProjHardForkQuery b result -projQuery' qry = projQuery qry $ \Refl -> ProjHardForkQuery - -data ProjHardForkQuery b :: Type -> Type where - ProjHardForkQuery :: - BlockQuery b result' - -> ProjHardForkQuery b (HardForkQueryResult '[b] result') - --- | Inject 'BlockQuery' --- --- Not an instance of 'Isomorphic' because the types change. -injQuery :: BlockQuery b result - -> BlockQuery (HardForkBlock '[b]) (HardForkQueryResult '[b] result) -injQuery = QueryIfCurrent . QZ - -projQueryResult :: HardForkQueryResult '[b] result -> result -projQueryResult (Left err) = absurd $ mismatchOneEra err -projQueryResult (Right result) = result - -injQueryResult :: result -> HardForkQueryResult '[b] result -injQueryResult = Right - projNestedCtxt :: NestedCtxt f (HardForkBlock '[blk]) a -> NestedCtxt f blk a projNestedCtxt = NestedCtxt . aux . flipNestedCtxt where diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/InjectTxs.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/InjectTxs.hs index a0bba7394f..dc16f7d55f 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/InjectTxs.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/InjectTxs.hs @@ -15,12 +15,10 @@ module Ouroboros.Consensus.HardFork.Combinator.InjectTxs ( -- * Unvalidated transactions , InjectTx , cannotInjectTx - , matchTx , pattern InjectTx -- * Validated transactions , InjectValidatedTx , cannotInjectValidatedTx - , matchValidatedTx , matchValidatedTxsNS , pattern InjectValidatedTx ) where @@ -153,16 +151,6 @@ pattern InjectTx f = InjectPolyTx f cannotInjectTx :: InjectTx blk blk' cannotInjectTx = cannotInjectPolyTx --- | 'matchPolyTx' at type 'InjectTx' -matchTx :: - SListI xs - => InPairs InjectTx xs - -> NS GenTx xs - -> HardForkState f xs - -> Either (Mismatch GenTx (Current f) xs) - (HardForkState (Product GenTx f) xs) -matchTx = matchPolyTx - ----- type InjectValidatedTx = InjectPolyTx WrapValidatedGenTx @@ -177,16 +165,6 @@ pattern InjectValidatedTx f = InjectPolyTx f cannotInjectValidatedTx :: InjectValidatedTx blk blk' cannotInjectValidatedTx = cannotInjectPolyTx --- | 'matchPolyTx' at type 'InjectValidatedTx' -matchValidatedTx :: - SListI xs - => InPairs InjectValidatedTx xs - -> NS WrapValidatedGenTx xs - -> HardForkState f xs - -> Either (Mismatch WrapValidatedGenTx (Current f) xs) - (HardForkState (Product WrapValidatedGenTx f) xs) -matchValidatedTx = matchPolyTx - -- | 'matchPolyTxsNS' at type 'InjectValidatedTx' matchValidatedTxsNS :: forall f xs. SListI xs diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Ledger.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Ledger.hs index 49d54683e5..17f31df696 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Ledger.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Ledger.hs @@ -174,7 +174,7 @@ instance CanHardFork xs applyBlockLedgerResult cfg (HardForkBlock (OneEraBlock block)) - (TickedHardForkLedgerState transition st) = + thfls = case State.match block st of Left mismatch -> -- Block from the wrong era (note that 'applyChainTick' will already @@ -187,6 +187,11 @@ instance CanHardFork xs $ hsequence' $ hcizipWith proxySingle apply cfgs matched where + TickedHardForkLedgerState { + tickedHardForkLedgerStateTransition = transition + , tickedHardForkLedgerStatePerEra = st + } = thfls + cfgs = distribLedgerConfig ei cfg ei = State.epochInfoPrecomputedTransitionInfo (hardForkLedgerConfigShape cfg) diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Ledger/CommonProtocolParams.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Ledger/CommonProtocolParams.hs deleted file mode 100644 index 0d47fd2e21..0000000000 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Ledger/CommonProtocolParams.hs +++ /dev/null @@ -1,27 +0,0 @@ -{-# LANGUAGE RankNTypes #-} - -{-# OPTIONS_GHC -Wno-orphans #-} - -module Ouroboros.Consensus.HardFork.Combinator.Ledger.CommonProtocolParams () where - -import Data.SOP.BasicFunctors -import Data.SOP.Strict -import Ouroboros.Consensus.HardFork.Combinator.Abstract -import Ouroboros.Consensus.HardFork.Combinator.Basics -import Ouroboros.Consensus.HardFork.Combinator.Ledger () -import qualified Ouroboros.Consensus.HardFork.Combinator.State as State -import Ouroboros.Consensus.Ledger.CommonProtocolParams - -instance CanHardFork xs => CommonProtocolParams (HardForkBlock xs) where - maxHeaderSize = askCurrentLedger maxHeaderSize - maxTxSize = askCurrentLedger maxTxSize - -askCurrentLedger :: - CanHardFork xs - => (forall blk. CommonProtocolParams blk => LedgerState blk -> a) - -> LedgerState (HardForkBlock xs) -> a -askCurrentLedger f = - hcollapse - . hcmap proxySingle (K . f) - . State.tip - . hardForkLedgerStatePerEra diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Ledger/Query.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Ledger/Query.hs index 43f3614877..f2ee7ffbba 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Ledger/Query.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Ledger/Query.hs @@ -27,7 +27,6 @@ module Ouroboros.Consensus.HardFork.Combinator.Ledger.Query ( , decodeQueryHardForkResult , encodeQueryAnytimeResult , encodeQueryHardForkResult - , getHardForkQuery , hardForkQueryInfo ) where @@ -185,28 +184,6 @@ instance All SingleEraBlock xs => SameDepIndex (BlockQuery (HardForkBlock xs)) w deriving instance All SingleEraBlock xs => Show (BlockQuery (HardForkBlock xs) result) -getHardForkQuery :: BlockQuery (HardForkBlock xs) result - -> (forall result'. - result :~: HardForkQueryResult xs result' - -> QueryIfCurrent xs result' - -> r) - -> (forall x' xs'. - xs :~: x' ': xs' - -> ProofNonEmpty xs' - -> QueryAnytime result - -> EraIndex xs - -> r) - -> (forall x' xs'. - xs :~: x' ': xs' - -> ProofNonEmpty xs' - -> QueryHardFork xs result - -> r) - -> r -getHardForkQuery q k1 k2 k3 = case q of - QueryIfCurrent qry -> k1 Refl qry - QueryAnytime qry era -> k2 Refl (isNonEmpty Proxy) qry era - QueryHardFork qry -> k3 Refl (isNonEmpty Proxy) qry - {------------------------------------------------------------------------------- Current era queries -------------------------------------------------------------------------------} diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Node.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Node.hs index a1cf173384..67166e0c7b 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Node.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Node.hs @@ -17,7 +17,6 @@ import Ouroboros.Consensus.HardFork.Combinator.Abstract import Ouroboros.Consensus.HardFork.Combinator.AcrossEras import Ouroboros.Consensus.HardFork.Combinator.Basics import Ouroboros.Consensus.HardFork.Combinator.Forging () -import Ouroboros.Consensus.HardFork.Combinator.Ledger.CommonProtocolParams () import Ouroboros.Consensus.HardFork.Combinator.Ledger.PeerSelection () import Ouroboros.Consensus.HardFork.Combinator.Node.DiffusionPipelining () import Ouroboros.Consensus.HardFork.Combinator.Node.InitStorage () diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Protocol.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Protocol.hs index 1ee6b53cc7..556ce193fc 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Protocol.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Protocol.hs @@ -5,6 +5,7 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} @@ -174,7 +175,7 @@ tick :: CanHardFork xs -> SlotNo -> HardForkChainDepState xs -> Ticked (HardForkChainDepState xs) -tick cfg@HardForkConsensusConfig{..} +tick cfg (HardForkLedgerView transition ledgerView) slot chainDepState = TickedHardForkChainDepState { @@ -187,6 +188,10 @@ tick cfg@HardForkConsensusConfig{..} chainDepState } where + HardForkConsensusConfig{ + hardForkConsensusConfigShape + , hardForkConsensusConfigPerEra + } = cfg cfgs = getPerEraConsensusConfig hardForkConsensusConfigPerEra ei = State.epochInfoPrecomputedTransitionInfo hardForkConsensusConfigShape @@ -232,7 +237,7 @@ check :: forall xs. (CanHardFork xs, HasCallStack) check HardForkConsensusConfig{..} (SomeErasCanBeLeader canBeLeader) slot - (TickedHardForkChainDepState chainDepState ei) = + thfcds = undistrib $ hczipWith3 proxySingle @@ -241,6 +246,11 @@ check HardForkConsensusConfig{..} (OptNP.toNP canBeLeader) (State.tip chainDepState) where + TickedHardForkChainDepState { + tickedHardForkChainDepStatePerEra = chainDepState + , tickedHardForkChainDepStateEpochInfo = ei + } = thfcds + cfgs = getPerEraConsensusConfig hardForkConsensusConfigPerEra checkOne :: diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Serialisation/Common.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Serialisation/Common.hs index 155a11d322..102a140715 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Serialisation/Common.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Serialisation/Common.hs @@ -23,9 +23,6 @@ module Ouroboros.Consensus.HardFork.Combinator.Serialisation.Common ( , futureEraException , pSHFC -- * Distinguish first era from the rest - , FirstEra - , LaterEra - , isFirstEra , notFirstEra -- * Versioning , EraNodeToClientVersion (..) @@ -74,7 +71,6 @@ import Control.Exception (Exception, throw) import qualified Data.ByteString.Lazy as Lazy import Data.ByteString.Short (ShortByteString) import qualified Data.ByteString.Short as Short -import Data.Kind (Type) import Data.SOP.BasicFunctors import Data.SOP.Constraint import Data.SOP.Index @@ -103,21 +99,6 @@ import Ouroboros.Network.Block (Serialised) Distinguish between the first era and all others -------------------------------------------------------------------------------} -type family FirstEra (xs :: [Type]) where - FirstEra (x ': xs) = x - -type family LaterEra (xs :: [Type]) where - LaterEra (x ': xs) = xs - -isFirstEra :: forall f xs. All SingleEraBlock xs - => NS f xs - -> Either (NS SingleEraInfo (LaterEra xs)) (f (FirstEra xs)) -isFirstEra (Z x) = Right x -isFirstEra (S x) = Left (hcmap proxySingle aux x) - where - aux :: forall blk. SingleEraBlock blk => f blk -> SingleEraInfo blk - aux _ = singleEraInfo (Proxy @blk) - -- | Used to construct 'FutureEraException' notFirstEra :: All SingleEraBlock xs => NS f xs -- ^ 'NS' intended to be from a future era diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/State.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/State.hs index da727d33f1..e77b57327a 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/State.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/State.hs @@ -17,8 +17,6 @@ module Ouroboros.Consensus.HardFork.Combinator.State ( module X -- * Support for defining instances , getTip - -- * Serialisation support - , recover -- * EpochInfo , epochInfoLedger , epochInfoPrecomputedTransitionInfo @@ -29,7 +27,6 @@ module Ouroboros.Consensus.HardFork.Combinator.State ( ) where import Control.Monad (guard) -import Data.Functor.Product import Data.Proxy import Data.SOP.BasicFunctors import Data.SOP.Constraint @@ -37,7 +34,7 @@ import Data.SOP.Counting (getExactly) import Data.SOP.InPairs (InPairs, Requiring (..)) import qualified Data.SOP.InPairs as InPairs import Data.SOP.Strict -import Data.SOP.Telescope (Extend (..), ScanNext (..), Telescope) +import Data.SOP.Telescope (Extend (..)) import qualified Data.SOP.Telescope as Telescope import Ouroboros.Consensus.Block import Ouroboros.Consensus.HardFork.Combinator.Abstract @@ -71,35 +68,6 @@ getTip getLedgerTip = injPoint (BlockPoint s h) = BlockPoint s $ OneEraHash $ toShortRawHash (Proxy @blk) h -{------------------------------------------------------------------------------- - Recovery --------------------------------------------------------------------------------} - --- | Recover 'HardForkState' from partial information --- --- The primary goal of this is to make sure that for the /current/ state we --- really only need to store the underlying @f@. It is not strictly essential --- that this is possible but it helps with the unary hardfork case, and it may --- in general help with binary compatibility. -recover :: forall f xs. CanHardFork xs - => Telescope (K Past) f xs -> HardForkState f xs -recover = - case isNonEmpty (Proxy @xs) of - ProofNonEmpty {} -> - HardForkState - . Telescope.bihmap - (\(Pair _ past) -> past) - recoverCurrent - . Telescope.scanl - (InPairs.hpure $ ScanNext $ const $ K . pastEnd . unK) - (K History.initBound) - where - recoverCurrent :: Product (K History.Bound) f blk -> Current f blk - recoverCurrent (Pair (K prevEnd) st) = Current { - currentStart = prevEnd - , currentState = st - } - {------------------------------------------------------------------------------- Reconstruct EpochInfo -------------------------------------------------------------------------------} diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/State/Infra.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/State/Infra.hs index cb5aba8150..f2e3b9114a 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/State/Infra.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/State/Infra.hs @@ -14,7 +14,6 @@ module Ouroboros.Consensus.HardFork.Combinator.State.Infra ( -- * Lifting 'Telescope' operations , fromTZ , match - , sequence , tip -- * Situated , Situated (..) @@ -74,15 +73,6 @@ match ns (HardForkState t) = distrib (Pair x (Current start y)) = Current start (Pair x y) -sequence :: forall f m xs. (SListI xs, Functor m) - => HardForkState (m :.: f) xs -> m (HardForkState f xs) -sequence = \(HardForkState st) -> HardForkState <$> - Telescope.sequence (hmap distrib st) - where - distrib :: Current (m :.: f) blk -> (m :.: Current f) blk - distrib (Current start st) = Comp $ - Current start <$> unComp st - fromTZ :: HardForkState f '[blk] -> f blk fromTZ = currentState . Telescope.fromTZ . getHardForkState diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/History/Qry.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/History/Qry.hs index d368d8d600..8e93ac5a0e 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/History/Qry.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/History/Qry.hs @@ -19,13 +19,11 @@ module Ouroboros.Consensus.HardFork.History.Qry ( , qryFromExpr , runQuery , runQueryPure - , runQueryThrow -- ** opaque , Qry -- * Interpreter , interpretQuery , mkInterpreter - , unsafeExtendSafeZone -- ** opaque , Interpreter -- * Specific queries @@ -406,9 +404,6 @@ runQuery qry (Summary summary) = go summary Nothing -> Left $ PastHorizon callStack (Some e) (toList summary) -runQueryThrow :: (HasCallStack, MonadThrow m) => Qry a -> Summary xs -> m a -runQueryThrow q = either throwIO return . runQuery q - runQueryPure :: HasCallStack => Qry a -> Summary xs -> a runQueryPure q = either throw id . runQuery q @@ -438,25 +433,6 @@ interpretQuery :: -> Either PastHorizonException a interpretQuery (Interpreter summary) qry = runQuery qry summary --- | UNSAFE: extend the safe zone of the current era of the given 'Interpreter' --- to be /unbounded/, ignoring any future hard forks. --- --- This only has effect when the 'Interpreter' was obtained in an era that was --- /not the final one/ (in the final era, this is a no-op). The 'Interpreter' --- will be made to believe that the current era is the final era, making its --- horizon unbounded, and thus never returning a 'PastHorizonException'. --- --- Use of this function is /strongly discouraged/, as it will ignore any future --- hard forks, and the results produced by the 'Interpreter' can thus be --- incorrect. -unsafeExtendSafeZone :: Interpreter xs -> Interpreter xs -unsafeExtendSafeZone (Interpreter (Summary eraSummaries)) = - Interpreter (Summary (go eraSummaries)) - where - go :: NonEmpty xs' EraSummary -> NonEmpty xs' EraSummary - go (NonEmptyCons e es) = NonEmptyCons e (go es) - go (NonEmptyOne e) = NonEmptyOne e { eraEnd = EraUnbounded } - {------------------------------------------------------------------------------- Specific queries diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/History/Summary.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/History/Summary.hs index 1a1c29d1dc..11317322fd 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/History/Summary.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/History/Summary.hs @@ -28,7 +28,6 @@ module Ouroboros.Consensus.HardFork.History.Summary ( , Summary (..) -- ** Construction , neverForksSummary - , summaryWithExactly -- *** Summarize , Shape (..) , Transitions (..) @@ -36,7 +35,6 @@ module Ouroboros.Consensus.HardFork.History.Summary ( , invariantSummary , singletonShape , summarize - , transitionsUnknown -- ** Query , summaryBounds , summaryInit @@ -229,12 +227,6 @@ summaryBounds (Summary summary) = summaryInit :: Summary xs -> (Maybe (Summary xs), EraSummary) summaryInit (Summary summary) = first (fmap Summary) $ nonEmptyInit summary --- | Construct 'Summary' with an exact number of 'EraSummary' --- --- Primarily useful for tests. -summaryWithExactly :: Exactly (x ': xs) EraSummary -> Summary (x ': xs) -summaryWithExactly = Summary . exactlyWeakenNonEmpty - {------------------------------------------------------------------------------- Shape and Transitions @@ -276,10 +268,6 @@ data Transitions :: [Type] -> Type where deriving instance Show (Transitions xs) --- | No known transitions yet -transitionsUnknown :: Transitions (x ': xs) -transitionsUnknown = Transitions AtMostNil - {------------------------------------------------------------------------------- Constructing the summary diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HeaderStateHistory.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HeaderStateHistory.hs index e64916d573..5406ae5da7 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HeaderStateHistory.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HeaderStateHistory.hs @@ -4,7 +4,6 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -- | HeaderState history -- @@ -14,7 +13,6 @@ -- > import qualified Ouroboros.Consensus.HeaderStateHistory as HeaderStateHistory module Ouroboros.Consensus.HeaderStateHistory ( HeaderStateHistory (..) - , cast , current , rewind , trim @@ -25,7 +23,6 @@ module Ouroboros.Consensus.HeaderStateHistory ( ) where import Control.Monad.Except (Except) -import Data.Coerce (Coercible) import qualified Data.List.NonEmpty as NE import GHC.Generics (Generic) import NoThunks.Class (NoThunks) @@ -75,15 +72,6 @@ trim :: Int -> HeaderStateHistory blk -> HeaderStateHistory blk trim n (HeaderStateHistory history) = HeaderStateHistory (AS.anchorNewest (fromIntegral n) history) -cast :: - ( Coercible (ChainDepState (BlockProtocol blk )) - (ChainDepState (BlockProtocol blk')) - , TipInfo blk ~ TipInfo blk' - ) - => HeaderStateHistory blk -> HeaderStateHistory blk' -cast (HeaderStateHistory history) = - HeaderStateHistory $ AS.bimap castHeaderState castHeaderState history - -- | \( O\(n\) \). Rewind the header state history -- -- NOTE: we don't distinguish headers of regular blocks from headers of EBBs. diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HeaderValidation.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HeaderValidation.hs index aff3baf99e..c9d1e8c6c2 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HeaderValidation.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HeaderValidation.hs @@ -5,7 +5,6 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-} @@ -28,10 +27,8 @@ module Ouroboros.Consensus.HeaderValidation ( , annTipRealPoint , castAnnTip , getAnnTip - , mapAnnTip -- * Header state , HeaderState (..) - , castHeaderState , genesisHeaderState , headerStateBlockNo , headerStatePoint @@ -64,7 +61,6 @@ import Codec.Serialise (decode, encode) import Control.Monad (unless, when) import Control.Monad.Except (Except, runExcept, throwError, withExcept) -import Data.Coerce import Data.Kind (Type) import qualified Data.Map.Strict as Map import Data.Proxy @@ -114,9 +110,6 @@ annTipRealPoint annTip@AnnTip{..} = RealPoint annTipSlotNo (annTipHash annTip) castAnnTip :: TipInfo blk ~ TipInfo blk' => AnnTip blk -> AnnTip blk' castAnnTip AnnTip{..} = AnnTip{..} -mapAnnTip :: (TipInfo blk -> TipInfo blk') -> AnnTip blk -> AnnTip blk' -mapAnnTip f AnnTip { annTipInfo, .. } = AnnTip { annTipInfo = f annTipInfo, .. } - class ( StandardHash blk , Show (TipInfo blk) , Eq (TipInfo blk) @@ -165,17 +158,6 @@ instance Anchorable (WithOrigin SlotNo) (HeaderState blk) (HeaderState blk) wher asAnchor = id getAnchorMeasure _ = fmap annTipSlotNo . headerStateTip -castHeaderState :: - ( Coercible (ChainDepState (BlockProtocol blk )) - (ChainDepState (BlockProtocol blk')) - , TipInfo blk ~ TipInfo blk' - ) - => HeaderState blk -> HeaderState blk' -castHeaderState HeaderState {..} = HeaderState { - headerStateTip = castAnnTip <$> headerStateTip - , headerStateChainDep = coerce headerStateChainDep - } - deriving instance (BlockSupportsProtocol blk, HasAnnTip blk) => Eq (HeaderState blk) deriving instance (BlockSupportsProtocol blk, HasAnnTip blk) diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Ledger/Abstract.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Ledger/Abstract.hs index d53355d83b..41f9aa528d 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Ledger/Abstract.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Ledger/Abstract.hs @@ -20,7 +20,6 @@ module Ouroboros.Consensus.Ledger.Abstract ( , UpdateLedger -- * Derived , applyLedgerBlock - , foldLedger , reapplyLedgerBlock , refoldLedger , tickThenApply @@ -41,7 +40,7 @@ import GHC.Stack (HasCallStack) import Ouroboros.Consensus.Block.Abstract import Ouroboros.Consensus.Ledger.Basics import Ouroboros.Consensus.Ticked -import Ouroboros.Consensus.Util (repeatedly, repeatedlyM, (..:)) +import Ouroboros.Consensus.Util (repeatedly, (..:)) -- | " Validated " transaction or block -- @@ -175,11 +174,6 @@ tickThenReapply :: -> l tickThenReapply = lrResult ..: tickThenReapplyLedgerResult -foldLedger :: - ApplyBlock l blk - => LedgerCfg l -> [blk] -> l -> Except (LedgerErr l) l -foldLedger = repeatedlyM . tickThenApply - refoldLedger :: ApplyBlock l blk => LedgerCfg l -> [blk] -> l -> l diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Ledger/CommonProtocolParams.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Ledger/CommonProtocolParams.hs deleted file mode 100644 index 4e0c2e6518..0000000000 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Ledger/CommonProtocolParams.hs +++ /dev/null @@ -1,15 +0,0 @@ -module Ouroboros.Consensus.Ledger.CommonProtocolParams (CommonProtocolParams (..)) where - -import Data.Word (Word32) -import Ouroboros.Consensus.Ledger.Abstract - --- | Ask the ledger for common protocol parameters. -class UpdateLedger blk => CommonProtocolParams blk where - - -- | The maximum header size in bytes according to the currently adopted - -- protocol parameters of the ledger state. - maxHeaderSize :: LedgerState blk -> Word32 - - -- | The maximum transaction size in bytes according to the currently - -- adopted protocol parameters of the ledger state. - maxTxSize :: LedgerState blk -> Word32 diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Ledger/Dual.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Ledger/Dual.hs index bfcbd06154..5a7752fa8e 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Ledger/Dual.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Ledger/Dual.hs @@ -46,13 +46,11 @@ module Ouroboros.Consensus.Ledger.Dual ( , decodeDualGenTx , decodeDualGenTxErr , decodeDualGenTxId - , decodeDualHeader , decodeDualLedgerState , encodeDualBlock , encodeDualGenTx , encodeDualGenTxErr , encodeDualGenTxId - , encodeDualHeader , encodeDualLedgerState ) where @@ -75,7 +73,6 @@ import Ouroboros.Consensus.Config.SupportsNode import Ouroboros.Consensus.HardFork.Abstract import Ouroboros.Consensus.HeaderValidation import Ouroboros.Consensus.Ledger.Abstract -import Ouroboros.Consensus.Ledger.CommonProtocolParams import Ouroboros.Consensus.Ledger.Extended import Ouroboros.Consensus.Ledger.Inspect import Ouroboros.Consensus.Ledger.Query @@ -157,9 +154,8 @@ instance (Typeable m, Typeable a) Config -------------------------------------------------------------------------------} -data instance BlockConfig (DualBlock m a) = DualBlockConfig { +newtype instance BlockConfig (DualBlock m a) = DualBlockConfig { dualBlockConfigMain :: BlockConfig m - , dualBlockConfigAux :: BlockConfig a } deriving NoThunks via AllowThunk (BlockConfig (DualBlock m a)) @@ -201,9 +197,8 @@ instance ( NoThunks (CodecConfig m) StorageConfig -------------------------------------------------------------------------------} -data instance StorageConfig (DualBlock m a) = DualStorageConfig { - dualStorageConfigMain :: !(StorageConfig m) - , dualStorageConfigAux :: !(StorageConfig a) +newtype instance StorageConfig (DualBlock m a) = DualStorageConfig { + dualStorageConfigMain :: StorageConfig m } deriving (Generic) @@ -225,7 +220,6 @@ class ( , LedgerSupportsProtocol m , HasHardForkHistory m , LedgerSupportsMempool m - , CommonProtocolParams m , HasTxId (GenTx m) , Show (ApplyTxErr m) @@ -380,7 +374,7 @@ instance Bridge m a => ApplyBlock (LedgerState (DualBlock m a)) (DualBlock m a) applyBlockLedgerResult cfg block@DualBlock{..} - TickedDualLedgerState{..} = do + tdls = do (ledgerResult, aux') <- agreeOnError DualLedgerError ( applyBlockLedgerResult @@ -400,10 +394,17 @@ instance Bridge m a => ApplyBlock (LedgerState (DualBlock m a)) (DualBlock m a) block tickedDualLedgerStateBridge } + where + TickedDualLedgerState { + tickedDualLedgerStateMain + , tickedDualLedgerStateAux + , tickedDualLedgerStateAuxOrig + , tickedDualLedgerStateBridge + } = tdls reapplyBlockLedgerResult cfg block@DualBlock{..} - TickedDualLedgerState{..} = + tdls = castLedgerResult ledgerResult <&> \main' -> DualLedgerState { dualLedgerStateMain = main' , dualLedgerStateAux = reapplyMaybeBlock @@ -421,6 +422,13 @@ instance Bridge m a => ApplyBlock (LedgerState (DualBlock m a)) (DualBlock m a) dualBlockMain tickedDualLedgerStateMain + TickedDualLedgerState { + tickedDualLedgerStateMain + , tickedDualLedgerStateAux + , tickedDualLedgerStateAuxOrig + , tickedDualLedgerStateBridge + } = tdls + data instance LedgerState (DualBlock m a) = DualLedgerState { dualLedgerStateMain :: LedgerState m , dualLedgerStateAux :: LedgerState a @@ -511,11 +519,6 @@ instance SameDepIndex (BlockQuery (DualBlock m a)) where instance ShowQuery (BlockQuery (DualBlock m a)) where showResult = \case {} --- | Forward to the main ledger -instance Bridge m a => CommonProtocolParams (DualBlock m a) where - maxHeaderSize = maxHeaderSize . dualLedgerStateMain - maxTxSize = maxTxSize . dualLedgerStateMain - {------------------------------------------------------------------------------- Mempool support -------------------------------------------------------------------------------} @@ -833,28 +836,17 @@ decodeDualBlock decodeMain = do -> (Lazy.ByteString -> DualBlock m a) dualBlock conc abst bridge bs = DualBlock (conc bs) abst bridge -encodeDualHeader :: (Header m -> Encoding) - -> Header (DualBlock m a) -> Encoding -encodeDualHeader encodeMain DualHeader{..} = encodeMain dualHeaderMain - -decodeDualHeader :: Decoder s (Lazy.ByteString -> Header m) - -> Decoder s (Lazy.ByteString -> Header (DualBlock m a)) -decodeDualHeader decodeMain = - dualHeader <$> decodeMain - where - dualHeader :: (Lazy.ByteString -> Header m) - -> (Lazy.ByteString -> Header (DualBlock m a)) - dualHeader conc bs = DualHeader (conc bs) - encodeDualGenTx :: (Bridge m a, Serialise (GenTx a)) => (GenTx m -> Encoding) -> GenTx (DualBlock m a) -> Encoding -encodeDualGenTx encodeMain DualGenTx{..} = mconcat [ +encodeDualGenTx encodeMain dgtx = mconcat [ encodeListLen 3 , encodeMain dualGenTxMain , encode dualGenTxAux , encode dualGenTxBridge ] + where + DualGenTx{dualGenTxMain, dualGenTxAux, dualGenTxBridge} = dgtx decodeDualGenTx :: (Bridge m a, Serialise (GenTx a)) => Decoder s (GenTx m) @@ -895,12 +887,18 @@ decodeDualGenTxErr decodeMain = do encodeDualLedgerState :: (Bridge m a, Serialise (LedgerState a)) => (LedgerState m -> Encoding) -> LedgerState (DualBlock m a) -> Encoding -encodeDualLedgerState encodeMain DualLedgerState{..} = mconcat [ +encodeDualLedgerState encodeMain dls = mconcat [ encodeListLen 3 , encodeMain dualLedgerStateMain , encode dualLedgerStateAux , encode dualLedgerStateBridge ] + where + DualLedgerState{ + dualLedgerStateMain + , dualLedgerStateAux + , dualLedgerStateBridge + } = dls decodeDualLedgerState :: (Bridge m a, Serialise (LedgerState a)) => Decoder s (LedgerState m) diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Ledger/Extended.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Ledger/Extended.hs index dd3e8b4599..b9afb00eed 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Ledger/Extended.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Ledger/Extended.hs @@ -9,7 +9,6 @@ {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} module Ouroboros.Consensus.Ledger.Extended ( @@ -22,8 +21,6 @@ module Ouroboros.Consensus.Ledger.Extended ( , decodeExtLedgerState , encodeDiskExtLedgerState , encodeExtLedgerState - -- * Casts - , castExtLedgerState -- * Type family instances , Ticked (..) ) where @@ -31,7 +28,6 @@ module Ouroboros.Consensus.Ledger.Extended ( import Codec.CBOR.Decoding (Decoder, decodeListLenOf) import Codec.CBOR.Encoding (Encoding, encodeListLen) import Control.Monad.Except -import Data.Coerce import Data.Functor ((<&>)) import Data.Proxy import Data.Typeable @@ -236,20 +232,3 @@ decodeDiskExtLedgerState cfg = (decodeDisk cfg) (decodeDisk cfg) (decodeDisk cfg) - -{------------------------------------------------------------------------------- - Casts --------------------------------------------------------------------------------} - -castExtLedgerState :: - ( Coercible (LedgerState blk) - (LedgerState blk') - , Coercible (ChainDepState (BlockProtocol blk)) - (ChainDepState (BlockProtocol blk')) - , TipInfo blk ~ TipInfo blk' - ) - => ExtLedgerState blk -> ExtLedgerState blk' -castExtLedgerState ExtLedgerState{..} = ExtLedgerState { - ledgerState = coerce ledgerState - , headerState = castHeaderState headerState - } diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Mempool.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Mempool.hs index 849e38cce4..d25f76d3c0 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Mempool.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Mempool.hs @@ -7,8 +7,6 @@ module Ouroboros.Consensus.Mempool ( , MempoolAddTxResult (..) , addLocalTxs , addTxs - , isMempoolTxAdded - , isMempoolTxRejected , mempoolTxAddedToMaybe -- ** Ledger state to forge on top of , ForgeLedgerState (..) @@ -40,8 +38,7 @@ module Ouroboros.Consensus.Mempool ( import Ouroboros.Consensus.Mempool.API (ForgeLedgerState (..), Mempool (..), MempoolAddTxResult (..), MempoolSnapshot (..), TicketNo, TxSizeInBytes, addLocalTxs, - addTxs, isMempoolTxAdded, isMempoolTxRejected, - mempoolTxAddedToMaybe, zeroTicketNo) + addTxs, mempoolTxAddedToMaybe, zeroTicketNo) import Ouroboros.Consensus.Mempool.Capacity (ByteSize (..), MempoolCapacityBytes (..), MempoolCapacityBytesOverride (..), MempoolSize (..), diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Mempool/API.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Mempool/API.hs index 4414869937..effa0d2278 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Mempool/API.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Mempool/API.hs @@ -17,8 +17,6 @@ module Ouroboros.Consensus.Mempool.API ( , MempoolAddTxResult (..) , addLocalTxs , addTxs - , isMempoolTxAdded - , isMempoolTxRejected , mempoolTxAddedToMaybe -- * Ledger state to forge on top of , ForgeLedgerState (..) @@ -231,14 +229,6 @@ mempoolTxAddedToMaybe :: MempoolAddTxResult blk -> Maybe (Validated (GenTx blk)) mempoolTxAddedToMaybe (MempoolTxAdded vtx) = Just vtx mempoolTxAddedToMaybe _ = Nothing -isMempoolTxAdded :: MempoolAddTxResult blk -> Bool -isMempoolTxAdded MempoolTxAdded{} = True -isMempoolTxAdded _ = False - -isMempoolTxRejected :: MempoolAddTxResult blk -> Bool -isMempoolTxRejected MempoolTxRejected{} = True -isMempoolTxRejected _ = False - -- | A wrapper around 'addTx' that adds a sequence of transactions on behalf of -- a remote peer. -- diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Mempool/Init.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Mempool/Init.hs index f2aa648eb8..e558d7b788 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Mempool/Init.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Mempool/Init.hs @@ -8,6 +8,7 @@ module Ouroboros.Consensus.Mempool.Init ( ) where import Control.Monad (void) +import Control.ResourceRegistry import Control.Tracer import Ouroboros.Consensus.Block import Ouroboros.Consensus.HeaderValidation @@ -19,7 +20,6 @@ import Ouroboros.Consensus.Mempool.Impl.Common import Ouroboros.Consensus.Mempool.Query import Ouroboros.Consensus.Mempool.Update import Ouroboros.Consensus.Util.IOLike -import Ouroboros.Consensus.Util.ResourceRegistry import Ouroboros.Consensus.Util.STM (Watcher (..), forkLinkedWatcher) {------------------------------------------------------------------------------- diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/BlockFetch/Server.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/BlockFetch/Server.hs index f0d8f17e42..7af215bb8b 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/BlockFetch/Server.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/BlockFetch/Server.hs @@ -18,6 +18,7 @@ module Ouroboros.Consensus.MiniProtocol.BlockFetch.Server ( , blockFetchServer' ) where +import Control.ResourceRegistry (ResourceRegistry) import Control.Tracer (Tracer, traceWith) import Data.Typeable (Typeable) import Ouroboros.Consensus.Block @@ -26,7 +27,6 @@ import Ouroboros.Consensus.Storage.ChainDB (ChainDB, Iterator, getSerialisedBlockWithPoint) import qualified Ouroboros.Consensus.Storage.ChainDB as ChainDB import Ouroboros.Consensus.Util.IOLike -import Ouroboros.Consensus.Util.ResourceRegistry (ResourceRegistry) import Ouroboros.Network.Block (Serialised (..)) import Ouroboros.Network.NodeToNode.Version (NodeToNodeVersion) import Ouroboros.Network.Protocol.BlockFetch.Server diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ChainSync/Server.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ChainSync/Server.hs index 5d9804f733..9f867c913a 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ChainSync/Server.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ChainSync/Server.hs @@ -17,6 +17,7 @@ module Ouroboros.Consensus.MiniProtocol.ChainSync.Server ( , chainSyncServerForFollower ) where +import Control.ResourceRegistry (ResourceRegistry) import Control.Tracer import Ouroboros.Consensus.Block import Ouroboros.Consensus.Storage.ChainDB.API (ChainDB, Follower, @@ -27,7 +28,6 @@ import Ouroboros.Consensus.Storage.Serialisation import Ouroboros.Consensus.Util.Enclose (Enclosing, Enclosing' (..), pattern FallingEdge) import Ouroboros.Consensus.Util.IOLike -import Ouroboros.Consensus.Util.ResourceRegistry (ResourceRegistry) import Ouroboros.Network.Block (ChainUpdate (..), Serialised, Tip (..)) import Ouroboros.Network.Protocol.ChainSync.Server diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Node/Run.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Node/Run.hs index 1fe2ae42ee..0617a636fe 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Node/Run.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Node/Run.hs @@ -21,7 +21,6 @@ import Data.Typeable (Typeable) import Ouroboros.Consensus.Block import Ouroboros.Consensus.Config.SupportsNode import Ouroboros.Consensus.HardFork.Abstract -import Ouroboros.Consensus.Ledger.CommonProtocolParams import Ouroboros.Consensus.Ledger.Inspect import Ouroboros.Consensus.Ledger.Query import Ouroboros.Consensus.Ledger.SupportsMempool @@ -84,7 +83,6 @@ class ( LedgerSupportsProtocol blk , SupportedNetworkProtocolVersion blk , ConfigSupportsNode blk , ConvertRawHash blk - , CommonProtocolParams blk , HasBinaryBlockInfo blk , SerialiseDiskConstraints blk , SerialiseNodeToNodeConstraints blk diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Protocol/PBFT/State.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Protocol/PBFT/State.hs index 3cfdd4836d..3c3dc3d229 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Protocol/PBFT/State.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Protocol/PBFT/State.hs @@ -23,12 +23,10 @@ module Ouroboros.Consensus.Protocol.PBFT.State ( , append , empty -- * Queries - , countSignatures , countSignedBy , lastSignedSlot -- * Conversion , fromList - , toList -- * Serialization , decodePBftState , encodePBftState @@ -164,12 +162,6 @@ deriving instance PBftCrypto c => NoThunks (PBftSigner c) Queries -------------------------------------------------------------------------------} --- | Number of signatures in the window --- --- This will be equal to the specified window size, unless near genesis -countSignatures :: PBftState c -> Word64 -countSignatures PBftState{..} = size inWindow - -- | The number of blocks signed by the specified genesis key -- -- This only considers the signatures within the window, not in the pre-window; @@ -249,9 +241,6 @@ decrementKey = Map.alter dec Conversion -------------------------------------------------------------------------------} -toList :: PBftState c -> [PBftSigner c] -toList = Foldable.toList . inWindow - -- | Note: we are not checking the invariants because we don't want to require -- the 'WindowSize' to be in the context, see #2383. When assertions are -- enabled, we would notice the invariant violation as soon as we 'append'. diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/API.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/API.hs index 441c598c6a..65536a9461 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/API.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/API.hs @@ -36,7 +36,6 @@ module Ouroboros.Consensus.Storage.ChainDB.API ( -- * BlockComponent , BlockComponent (..) -- * Support for tests - , fromChain , toChain -- * Iterator API , Iterator (..) @@ -47,14 +46,12 @@ module Ouroboros.Consensus.Storage.ChainDB.API ( , emptyIterator , streamAll , streamFrom - , traverseIterator , validBounds -- * Invalid block reason , InvalidBlockReason (..) -- * Followers , ChainType (..) , Follower (..) - , traverseFollower -- * Recovery , ChainDbFailure (..) , IsEBB (..) @@ -66,6 +63,7 @@ module Ouroboros.Consensus.Storage.ChainDB.API ( ) where import Control.Monad (void) +import Control.ResourceRegistry import Data.Typeable (Typeable) import GHC.Generics (Generic) import Ouroboros.Consensus.Block @@ -76,7 +74,6 @@ import Ouroboros.Consensus.Ledger.Extended import Ouroboros.Consensus.Ledger.SupportsProtocol import Ouroboros.Consensus.Storage.ChainDB.API.Types.InvalidBlockPunishment (InvalidBlockPunishment) -import qualified Ouroboros.Consensus.Storage.ChainDB.API.Types.InvalidBlockPunishment as InvalidBlockPunishment import Ouroboros.Consensus.Storage.Common import Ouroboros.Consensus.Storage.LedgerDB (LedgerDB') import qualified Ouroboros.Consensus.Storage.LedgerDB as LedgerDB @@ -84,7 +81,6 @@ import Ouroboros.Consensus.Storage.Serialisation import Ouroboros.Consensus.Util ((..:)) import Ouroboros.Consensus.Util.CallStack import Ouroboros.Consensus.Util.IOLike -import Ouroboros.Consensus.Util.ResourceRegistry import Ouroboros.Consensus.Util.STM (WithFingerprint) import Ouroboros.Network.AnchoredFragment (AnchoredFragment) import qualified Ouroboros.Network.AnchoredFragment as AF @@ -520,16 +516,6 @@ toChain chainDB = withRegistry $ \registry -> IteratorBlockGCed _ -> error "block on the current chain was garbage-collected" -fromChain :: - forall m blk. IOLike m - => m (ChainDB m blk) - -> Chain blk - -> m (ChainDB m blk) -fromChain openDB chain = do - chainDB <- openDB - mapM_ (addBlock_ chainDB InvalidBlockPunishment.noPunishment) $ Chain.toOldestFirst chain - return chainDB - {------------------------------------------------------------------------------- Iterator API -------------------------------------------------------------------------------} @@ -551,17 +537,6 @@ emptyIterator = Iterator { , iteratorClose = return () } --- | Variant of 'traverse' instantiated to @'Iterator' m blk@ that executes --- the monadic function when calling 'iteratorNext'. -traverseIterator :: - Monad m - => (b -> m b') - -> Iterator m blk b - -> Iterator m blk b' -traverseIterator f it = it { - iteratorNext = iteratorNext it >>= traverse f - } - data IteratorResult blk b = IteratorExhausted | IteratorResult b @@ -763,21 +738,6 @@ data Follower m blk a = Follower { } deriving (Functor) --- | Variant of 'traverse' instantiated to @'Follower' m blk@ that executes the --- monadic function when calling 'followerInstruction' and --- 'followerInstructionBlocking'. -traverseFollower :: - Monad m - => (b -> m b') - -> Follower m blk b - -> Follower m blk b' -traverseFollower f flr = Follower - { followerInstruction = followerInstruction flr >>= traverse (traverse f) - , followerInstructionBlocking = followerInstructionBlocking flr >>= traverse f - , followerForward = followerForward flr - , followerClose = followerClose flr - } - {------------------------------------------------------------------------------- Recovery -------------------------------------------------------------------------------} diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl.hs index 03f9a1ef58..2e0b65028c 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl.hs @@ -37,6 +37,8 @@ module Ouroboros.Consensus.Storage.ChainDB.Impl ( import Control.Monad (when) import Control.Monad.Trans.Class (lift) +import Control.ResourceRegistry (WithTempRegistry, allocate, + runInnerWithTempRegistry, runWithTempRegistry) import Control.Tracer import Data.Functor (void, (<&>)) import Data.Functor.Identity (Identity) @@ -64,8 +66,6 @@ import qualified Ouroboros.Consensus.Storage.ImmutableDB as ImmutableDB import qualified Ouroboros.Consensus.Storage.VolatileDB as VolatileDB import Ouroboros.Consensus.Util (newFuse, whenJust, withFuse) import Ouroboros.Consensus.Util.IOLike -import Ouroboros.Consensus.Util.ResourceRegistry (WithTempRegistry, - allocate, runInnerWithTempRegistry, runWithTempRegistry) import Ouroboros.Consensus.Util.STM (Fingerprint (..), WithFingerprint (..)) import qualified Ouroboros.Network.AnchoredFragment as AF diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Args.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Args.hs index ebb6a04b7f..80221a4c46 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Args.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Args.hs @@ -17,6 +17,7 @@ module Ouroboros.Consensus.Storage.ChainDB.Impl.Args ( , updateTracer ) where +import Control.ResourceRegistry (ResourceRegistry) import Control.Tracer (Tracer, nullTracer) import Data.Functor.Contravariant ((>$<)) import Data.Kind @@ -37,7 +38,6 @@ import Ouroboros.Consensus.Storage.LedgerDB.DiskPolicy import qualified Ouroboros.Consensus.Storage.VolatileDB as VolatileDB import Ouroboros.Consensus.Util.Args import Ouroboros.Consensus.Util.IOLike -import Ouroboros.Consensus.Util.ResourceRegistry (ResourceRegistry) import System.FS.API {------------------------------------------------------------------------------- @@ -95,7 +95,7 @@ data ChainDbSpecificArgs f m blk = ChainDbSpecificArgs { -- * 'cdbsCheckInFuture' -- -- We a 'cdbsGcDelay' of 60 seconds and a 'cdbsGcInterval' of 10 seconds, this --- means (see the properties in "Test.Ouroboros.Storage.ChainDB.GcSchedule"): +-- means (see the properties in "Test.Consensus.Storage.ChainDB.GcSchedule"): -- -- * The length of the 'GcSchedule' queue is @<= ⌈gcDelay / gcInterval⌉ + 1@, -- i.e., @<= 7@. diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Background.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Background.hs index 9a6fdcb374..eaad3dc22f 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Background.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Background.hs @@ -39,6 +39,7 @@ module Ouroboros.Consensus.Storage.ChainDB.Impl.Background ( import Control.Exception (assert) import Control.Monad (forM_, forever, void) import Control.Monad.Trans.Class (lift) +import Control.ResourceRegistry import Control.Tracer import Data.Foldable (toList) import qualified Data.Map.Strict as Map @@ -71,7 +72,6 @@ import Ouroboros.Consensus.Util import Ouroboros.Consensus.Util.Condense import Ouroboros.Consensus.Util.Enclose (Enclosing' (..)) import Ouroboros.Consensus.Util.IOLike -import Ouroboros.Consensus.Util.ResourceRegistry import Ouroboros.Network.AnchoredFragment (AnchoredSeq (..)) import qualified Ouroboros.Network.AnchoredFragment as AF diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Follower.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Follower.hs index aa428072f6..7b2edc0188 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Follower.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Follower.hs @@ -17,6 +17,7 @@ module Ouroboros.Consensus.Storage.ChainDB.Impl.Follower ( import Codec.CBOR.Write (toLazyByteString) import Control.Exception (assert) import Control.Monad (join) +import Control.ResourceRegistry (ResourceRegistry) import Control.Tracer (contramap, traceWith) import qualified Data.ByteString.Lazy as Lazy import Data.Functor ((<&>)) @@ -35,7 +36,6 @@ import qualified Ouroboros.Consensus.Storage.ImmutableDB as ImmutableDB import Ouroboros.Consensus.Storage.Serialisation import Ouroboros.Consensus.Util.CallStack import Ouroboros.Consensus.Util.IOLike -import Ouroboros.Consensus.Util.ResourceRegistry (ResourceRegistry) import Ouroboros.Consensus.Util.STM (blockUntilJust) import Ouroboros.Network.AnchoredFragment (AnchoredFragment) import qualified Ouroboros.Network.AnchoredFragment as AF diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Iterator.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Iterator.hs index a7eeab2c53..68b34633ab 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Iterator.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Iterator.hs @@ -21,6 +21,7 @@ import Control.Monad (unless, when) import Control.Monad.Except (ExceptT (..), catchError, runExceptT, throwError, withExceptT) import Control.Monad.Trans.Class (lift) +import Control.ResourceRegistry (ResourceRegistry) import Control.Tracer import Data.Functor (($>)) import Data.List.NonEmpty (NonEmpty) @@ -44,7 +45,6 @@ import qualified Ouroboros.Consensus.Storage.ImmutableDB as ImmutableDB import Ouroboros.Consensus.Storage.VolatileDB (VolatileDB) import qualified Ouroboros.Consensus.Storage.VolatileDB as VolatileDB import Ouroboros.Consensus.Util.IOLike -import Ouroboros.Consensus.Util.ResourceRegistry (ResourceRegistry) -- | Stream blocks -- diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Types.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Types.hs index feb94c2dbf..ed1bfc073d 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Types.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Types.hs @@ -24,7 +24,6 @@ module Ouroboros.Consensus.Storage.ChainDB.Impl.Types ( , getEnv1 , getEnv2 , getEnvSTM - , getEnvSTM1 -- * Exposed internals for testing purposes , Internal (..) -- * Iterator-related @@ -63,6 +62,7 @@ module Ouroboros.Consensus.Storage.ChainDB.Impl.Types ( , TraceValidationEvent (..) ) where +import Control.ResourceRegistry import Control.Tracer import Data.Foldable (traverse_) import Data.Map.Strict (Map) @@ -103,7 +103,6 @@ import Ouroboros.Consensus.Util (Fuse) import Ouroboros.Consensus.Util.CallStack import Ouroboros.Consensus.Util.Enclose (Enclosing, Enclosing' (..)) import Ouroboros.Consensus.Util.IOLike -import Ouroboros.Consensus.Util.ResourceRegistry import Ouroboros.Consensus.Util.STM (WithFingerprint) import Ouroboros.Network.AnchoredFragment (AnchoredFragment) import Ouroboros.Network.Block (MaxSlotNo) @@ -153,16 +152,6 @@ getEnvSTM (CDBHandle varState) f = readTVar varState >>= \case ChainDbOpen env -> f env ChainDbClosed -> throwSTM $ ClosedDBError @blk prettyCallStack --- | Variant of 'getEnv1' that works in 'STM'. -getEnvSTM1 :: - forall m blk a r. (IOLike m, HasCallStack, HasHeader blk) - => ChainDbHandle m blk - -> (ChainDbEnv m blk -> a -> STM m r) - -> a -> STM m r -getEnvSTM1 (CDBHandle varState) f a = readTVar varState >>= \case - ChainDbOpen env -> f env a - ChainDbClosed -> throwSTM $ ClosedDBError @blk prettyCallStack - data ChainDbState m blk = ChainDbOpen !(ChainDbEnv m blk) | ChainDbClosed @@ -442,7 +431,7 @@ type FutureBlocks m blk = Map (HeaderHash blk) (Header blk, InvalidBlockPunishme -- | FIFO queue used to add blocks asynchronously to the ChainDB. Blocks are -- read from this queue by a background thread, which processes the blocks -- synchronously. -newtype ChainSelQueue m blk = ChainSelQueue (TBQueue m (ChainSelMessage m blk)) +newtype ChainSelQueue m blk = ChainSelQueue (StrictTBQueue m (ChainSelMessage m blk)) deriving NoThunks via OnlyCheckWhnfNamed "ChainSelQueue" (ChainSelQueue m blk) -- | Entry in the 'ChainSelQueue' queue: a block together with the 'TMVar's used diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/Common.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/Common.hs index c0e302cb79..1953f67829 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/Common.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/Common.hs @@ -7,12 +7,9 @@ {-# LANGUAGE TypeFamilies #-} module Ouroboros.Consensus.Storage.Common ( - -- * Indexing - tipIsGenesis -- * PrefixLen - , PrefixLen (..) + PrefixLen (..) , addPrefixLen - , takePrefix -- * BinaryBlockInfo , BinaryBlockInfo (..) , extractHeader @@ -28,22 +25,12 @@ module Ouroboros.Consensus.Storage.Common ( import Data.ByteString.Lazy (ByteString) import qualified Data.ByteString.Lazy as BL -import Data.ByteString.Short (ShortByteString) -import qualified Data.ByteString.Short as Short import Data.Word import GHC.Generics (Generic) import NoThunks.Class (NoThunks) import Ouroboros.Consensus.Block import Ouroboros.Network.SizeInBytes (SizeInBytes) -{------------------------------------------------------------------------------- - Indexing --------------------------------------------------------------------------------} - -tipIsGenesis :: WithOrigin r -> Bool -tipIsGenesis Origin = True -tipIsGenesis (NotOrigin _) = False - {------------------------------------------------------------------------------- PrefixLen -------------------------------------------------------------------------------} @@ -61,10 +48,6 @@ newtype PrefixLen = PrefixLen { addPrefixLen :: Word8 -> PrefixLen -> PrefixLen addPrefixLen m (PrefixLen n) = PrefixLen (m + n) -takePrefix :: PrefixLen -> BL.ByteString -> ShortByteString -takePrefix (PrefixLen n) = - Short.toShort . BL.toStrict . BL.take (fromIntegral n) - {------------------------------------------------------------------------------- BinaryBlockInfo -------------------------------------------------------------------------------} diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ImmutableDB/API.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ImmutableDB/API.hs index 56b69fd60d..e4aa6592f1 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ImmutableDB/API.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ImmutableDB/API.hs @@ -17,7 +17,6 @@ module Ouroboros.Consensus.Storage.ImmutableDB.API ( , Iterator (..) , IteratorResult (..) , iteratorToList - , traverseIterator -- * Types , CompareTip (..) , Tip (..) @@ -55,6 +54,7 @@ module Ouroboros.Consensus.Storage.ImmutableDB.API ( import qualified Codec.CBOR.Read as CBOR import Control.Monad.Except (ExceptT (..), runExceptT, throwError) import Control.Monad.Trans.Class (lift) +import Control.ResourceRegistry (ResourceRegistry) import qualified Data.ByteString.Lazy as Lazy import Data.Either (isRight) import Data.Function (on) @@ -66,7 +66,6 @@ import Ouroboros.Consensus.Block import Ouroboros.Consensus.Storage.Common import Ouroboros.Consensus.Util.CallStack import Ouroboros.Consensus.Util.IOLike -import Ouroboros.Consensus.Util.ResourceRegistry (ResourceRegistry) import qualified Ouroboros.Network.AnchoredFragment as AF import System.FS.API.Types (FsError, FsPath) import System.FS.CRC (CRC) @@ -196,19 +195,6 @@ data Iterator m blk b = Iterator { deriving (Functor) deriving NoThunks via OnlyCheckWhnfNamed "Iterator" (Iterator m blk b) --- | Variant of 'traverse' instantiated to @'Iterator' m blk m@ that executes --- the monadic function when calling 'iteratorNext'. -traverseIterator :: - Monad m - => (b -> m b') - -> Iterator m blk b - -> Iterator m blk b' -traverseIterator f itr = Iterator{ - iteratorNext = iteratorNext itr >>= traverse f - , iteratorHasNext = iteratorHasNext itr - , iteratorClose = iteratorClose itr - } - -- | The result of stepping an 'Iterator'. data IteratorResult b = IteratorExhausted diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ImmutableDB/Impl.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ImmutableDB/Impl.hs index 44941178cb..c32e15ad8a 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ImmutableDB/Impl.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ImmutableDB/Impl.hs @@ -105,6 +105,7 @@ import qualified Codec.CBOR.Write as CBOR import Control.Monad (replicateM_, unless, when) import Control.Monad.Except (runExceptT) import Control.Monad.State.Strict (get, modify, put) +import Control.ResourceRegistry import Control.Tracer (Tracer, nullTracer, traceWith) import qualified Data.ByteString.Lazy as Lazy import GHC.Stack (HasCallStack) @@ -129,7 +130,6 @@ import Ouroboros.Consensus.Util (SomePair (..)) import Ouroboros.Consensus.Util.Args import Ouroboros.Consensus.Util.EarlyExit import Ouroboros.Consensus.Util.IOLike -import Ouroboros.Consensus.Util.ResourceRegistry import System.FS.API.Lazy hiding (allowExisting) import System.FS.CRC diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ImmutableDB/Impl/Index.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ImmutableDB/Impl/Index.hs index e37ce40d93..4d68416ff5 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ImmutableDB/Impl/Index.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ImmutableDB/Impl/Index.hs @@ -8,16 +8,14 @@ module Ouroboros.Consensus.Storage.ImmutableDB.Impl.Index ( Index (..) , readEntry , readOffset - -- * File-backed index - , fileBackedIndex -- * Cached index , CacheConfig (..) , cachedIndex ) where +import Control.ResourceRegistry import Control.Tracer (Tracer) import Data.Functor.Identity (Identity (..)) -import Data.Proxy (Proxy (..)) import Data.Typeable (Typeable) import Data.Word (Word64) import GHC.Stack (HasCallStack) @@ -29,14 +27,12 @@ import Ouroboros.Consensus.Storage.ImmutableDB.Impl.Index.Cache import qualified Ouroboros.Consensus.Storage.ImmutableDB.Impl.Index.Cache as Cache import Ouroboros.Consensus.Storage.ImmutableDB.Impl.Index.Primary (SecondaryOffset) -import qualified Ouroboros.Consensus.Storage.ImmutableDB.Impl.Index.Primary as Primary import Ouroboros.Consensus.Storage.ImmutableDB.Impl.Index.Secondary (BlockSize) import qualified Ouroboros.Consensus.Storage.ImmutableDB.Impl.Index.Secondary as Secondary import Ouroboros.Consensus.Storage.ImmutableDB.Impl.Types (TraceCacheEvent, WithBlockSize (..)) import Ouroboros.Consensus.Util.IOLike -import Ouroboros.Consensus.Util.ResourceRegistry import System.FS.API (HasFS) import System.FS.API.Types (AllowExisting, Handle) @@ -138,33 +134,6 @@ readEntry :: readEntry index chunk isEBB slotOffset = runIdentity <$> readEntries index chunk (Identity (isEBB, slotOffset)) -{------------------------------------------------------------------------------ - File-backed index -------------------------------------------------------------------------------} - -fileBackedIndex :: - forall m blk h. - (ConvertRawHash blk, MonadCatch m, StandardHash blk, Typeable blk) - => HasFS m h - -> ChunkInfo - -> Index m blk h -fileBackedIndex hasFS chunkInfo = Index - { readOffsets = Primary.readOffsets p hasFS - , readFirstFilledSlot = Primary.readFirstFilledSlot p hasFS chunkInfo - , openPrimaryIndex = Primary.open hasFS - , appendOffsets = Primary.appendOffsets hasFS - , readEntries = Secondary.readEntries hasFS - , readAllEntries = Secondary.readAllEntries hasFS - , appendEntry = \_chunk h (WithBlockSize _ entry) -> - Secondary.appendEntry hasFS h entry - -- Nothing to do - , close = return () - , restart = \_newCurChunk -> return () - } - where - p :: Proxy blk - p = Proxy - {------------------------------------------------------------------------------ Cached index ------------------------------------------------------------------------------} diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ImmutableDB/Impl/Index/Cache.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ImmutableDB/Impl/Index/Cache.hs index a65ae5e61b..9c27e6c4b2 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ImmutableDB/Impl/Index/Cache.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ImmutableDB/Impl/Index/Cache.hs @@ -38,6 +38,7 @@ import Cardano.Prelude (forceElemsToWHNF) import Control.Exception (assert) import Control.Monad (forM, forM_, forever, unless, void, when) import Control.Monad.Except (throwError) +import Control.ResourceRegistry import Control.Tracer (Tracer, traceWith) import Data.Foldable (toList) import Data.Functor ((<&>)) @@ -73,7 +74,6 @@ import Ouroboros.Consensus.Storage.ImmutableDB.Impl.Util import Ouroboros.Consensus.Util (takeUntil, whenJust) import Ouroboros.Consensus.Util.CallStack import Ouroboros.Consensus.Util.IOLike -import Ouroboros.Consensus.Util.ResourceRegistry import System.FS.API (HasFS (..), withFile) import System.FS.API.Types (AllowExisting (..), Handle, OpenMode (ReadMode)) diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ImmutableDB/Impl/Index/Primary.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ImmutableDB/Impl/Index/Primary.hs index ed21fb96d2..c24d4c1c1d 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ImmutableDB/Impl/Index/Primary.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ImmutableDB/Impl/Index/Primary.hs @@ -25,14 +25,11 @@ module Ouroboros.Consensus.Storage.ImmutableDB.Impl.Index.Primary ( , getLastSlot , isFilledSlot , lastFilledSlot - , lastOffset , load , nextFilledSlot , offsetOfSlot , open , readFirstFilledSlot - , readOffset - , readOffsets , secondaryOffsetSize , sizeOfSlot , slots @@ -52,7 +49,6 @@ import qualified Data.Binary.Get as Get import qualified Data.Binary.Put as Put import qualified Data.ByteString as Strict import qualified Data.ByteString.Lazy as Lazy -import Data.Functor.Identity (Identity (..)) import Data.Proxy (Proxy (..)) import Data.Typeable (Typeable) import Data.Vector.Unboxed (Vector) @@ -160,63 +156,6 @@ currentVersionNumber = 1 slots :: PrimaryIndex -> Word64 slots (MkPrimaryIndex _ offsets) = fromIntegral $ V.length offsets - 1 --- | Read the 'SecondaryOffset' corresponding to the given relative slot in --- the primary index. Return 'Nothing' when the slot is empty. -readOffset :: - forall blk m h. - (HasCallStack, MonadThrow m, StandardHash blk, Typeable blk) - => Proxy blk - -> HasFS m h - -> ChunkNo - -> RelativeSlot - -> m (Maybe SecondaryOffset) -readOffset pb hasFS chunk slot = runIdentity <$> - readOffsets pb hasFS chunk (Identity slot) - --- | Same as 'readOffset', but for multiple offsets. --- --- NOTE: only use this for a few offsets, as we will seek (@pread@) for each --- offset. Use 'load' if you want to read the whole primary index. -readOffsets :: - forall blk m h t. - ( HasCallStack - , MonadThrow m - , Traversable t - , StandardHash blk - , Typeable blk - ) - => Proxy blk - -> HasFS m h - -> ChunkNo - -> t RelativeSlot - -> m (t (Maybe SecondaryOffset)) - -- ^ The offset in the secondary index file corresponding to the given - -- slot. 'Nothing' when the slot is empty. -readOffsets pb hasFS@HasFS { hGetSize } chunk toRead = - withFile hasFS primaryIndexFile ReadMode $ \pHnd -> do - size <- hGetSize pHnd - forM toRead $ \relSlot -> do - let slot = assertRelativeSlotInChunk chunk relSlot - let offset = AbsOffset $ - fromIntegral (sizeOf currentVersionNumber) + - slot * secondaryOffsetSize - if unAbsOffset offset + nbBytes > size then - -- Don't try reading if the file doesn't contain enough bytes - return Nothing - else do - (secondaryOffset, nextSecondaryOffset) <- - runGet pb primaryIndexFile get =<< - hGetExactlyAt hasFS pHnd nbBytes offset - return $ if nextSecondaryOffset - secondaryOffset > 0 - then Just secondaryOffset - else Nothing - where - primaryIndexFile = fsPathPrimaryIndexFile chunk - nbBytes = secondaryOffsetSize * 2 - - get :: Get (SecondaryOffset, SecondaryOffset) - get = (,) <$> getSecondaryOffset <*> getSecondaryOffset - -- | Return the first filled slot in the primary index file, or 'Nothing' in -- case there are no filled slots. -- @@ -429,12 +368,6 @@ appendOffsets :: appendOffsets hasFS pHnd offsets = void $ hPut hasFS pHnd $ Put.execPut $ foldMap putSecondaryOffset offsets --- | Return the last 'SecondaryOffset' in the primary index file. -lastOffset :: PrimaryIndex -> SecondaryOffset -lastOffset (MkPrimaryIndex _ offsets) - | V.null offsets = 0 - | otherwise = offsets ! (V.length offsets - 1) - -- | Return the last slot of the primary index (empty or not). -- -- Returns 'Nothing' if the index is empty. diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ImmutableDB/Impl/Iterator.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ImmutableDB/Impl/Iterator.hs index dedd389bb5..522c622092 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ImmutableDB/Impl/Iterator.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ImmutableDB/Impl/Iterator.hs @@ -1,12 +1,14 @@ -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE QuantifiedConstraints #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE UndecidableInstances #-} module Ouroboros.Consensus.Storage.ImmutableDB.Impl.Iterator ( CurrentChunkInfo (..) @@ -20,6 +22,8 @@ import qualified Codec.CBOR.Read as CBOR import Control.Monad (unless, void, when) import Control.Monad.Except (ExceptT, runExceptT, throwError) import Control.Monad.Trans.Class (lift) +import Control.ResourceRegistry (ResourceKey, ResourceRegistry, + allocate, release, unsafeRelease) import qualified Data.ByteString.Lazy as Lazy import qualified Data.ByteString.Short as Short import Data.Foldable (find) @@ -45,8 +49,6 @@ import Ouroboros.Consensus.Storage.ImmutableDB.Impl.Types import Ouroboros.Consensus.Storage.ImmutableDB.Impl.Util import Ouroboros.Consensus.Storage.Serialisation import Ouroboros.Consensus.Util.IOLike -import Ouroboros.Consensus.Util.ResourceRegistry (ResourceKey, - ResourceRegistry, allocate, release, unsafeRelease) import Ouroboros.Network.SizeInBytes import System.FS.API.Lazy import System.FS.CRC @@ -75,7 +77,9 @@ data IteratorHandle m blk h = IteratorHandle { data IteratorStateOrExhausted m hash h = IteratorStateOpen !(IteratorState m hash h) | IteratorStateExhausted - deriving (Generic, NoThunks) + deriving (Generic) + +deriving instance (StandardHash blk, forall a. NoThunks a => NoThunks (StrictTVar m a)) => NoThunks (IteratorStateOrExhausted m blk h) data IteratorState m blk h = IteratorState { itsChunk :: !ChunkNo @@ -98,7 +102,7 @@ data IteratorState m blk h = IteratorState { } deriving (Generic) -deriving instance (StandardHash blk, IOLike m) => NoThunks (IteratorState m blk h) +deriving instance (StandardHash blk, forall a. NoThunks a => NoThunks (StrictTVar m a)) => NoThunks (IteratorState m blk h) -- | Auxiliary data type that combines the 'currentChunk' and -- 'currentChunkOffset' fields from 'OpenState'. This is used to avoid passing diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ImmutableDB/Impl/State.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ImmutableDB/Impl/State.hs index 3c5a4b36f3..7b8e8689d2 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ImmutableDB/Impl/State.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ImmutableDB/Impl/State.hs @@ -27,6 +27,7 @@ module Ouroboros.Consensus.Storage.ImmutableDB.Impl.State ( import Control.Monad (unless) import Control.Monad.State.Strict (StateT, lift) +import Control.ResourceRegistry import Control.Tracer (Tracer) import Data.Typeable (Typeable) import GHC.Generics (Generic) @@ -44,7 +45,6 @@ import Ouroboros.Consensus.Storage.ImmutableDB.Impl.Types import Ouroboros.Consensus.Storage.ImmutableDB.Impl.Util import Ouroboros.Consensus.Util (SomePair (..)) import Ouroboros.Consensus.Util.IOLike -import Ouroboros.Consensus.Util.ResourceRegistry import System.FS.API {------------------------------------------------------------------------------ diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ImmutableDB/Impl/Validation.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ImmutableDB/Impl/Validation.hs index a19d76507d..1eaf29cbd5 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ImmutableDB/Impl/Validation.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ImmutableDB/Impl/Validation.hs @@ -20,6 +20,7 @@ import Control.Exception (assert) import Control.Monad (forM_, unless, when) import Control.Monad.Except (ExceptT, runExceptT, throwError) import Control.Monad.Trans.Class (lift) +import Control.ResourceRegistry import Control.Tracer (Tracer, contramap, traceWith) import qualified Data.ByteString.Lazy as Lazy import Data.Functor (($>)) @@ -47,7 +48,6 @@ import Ouroboros.Consensus.Storage.Serialisation (DecodeDisk (..), HasBinaryBlockInfo (..)) import Ouroboros.Consensus.Util (lastMaybe, whenJust) import Ouroboros.Consensus.Util.IOLike -import Ouroboros.Consensus.Util.ResourceRegistry import Streaming (Of (..)) import qualified Streaming.Prelude as S import System.FS.API diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ImmutableDB/Stream.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ImmutableDB/Stream.hs index f290033acb..8aa3ebaa87 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ImmutableDB/Stream.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ImmutableDB/Stream.hs @@ -12,13 +12,13 @@ module Ouroboros.Consensus.Storage.ImmutableDB.Stream ( ) where import Control.Monad.Except +import Control.ResourceRegistry import GHC.Stack import Ouroboros.Consensus.Block import Ouroboros.Consensus.Storage.Common import Ouroboros.Consensus.Storage.ImmutableDB hiding (streamAll) import qualified Ouroboros.Consensus.Storage.ImmutableDB.API as ImmutableDB import Ouroboros.Consensus.Util.IOLike -import Ouroboros.Consensus.Util.ResourceRegistry {------------------------------------------------------------------------------- Abstraction over the streaming API provided by the Chain DB diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB.hs index 7e970703d9..c21a33fddf 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB.hs @@ -120,7 +120,6 @@ module Ouroboros.Consensus.Storage.LedgerDB ( , ledgerDbPush , ledgerDbSwitch -- ** Pure API - , ledgerDbPush' , ledgerDbPushMany' , ledgerDbSwitch' -- ** Trace @@ -183,5 +182,5 @@ import Ouroboros.Consensus.Storage.LedgerDB.Update ThrowsLedgerError (..), UpdateLedgerDbTraceEvent (..), defaultResolveBlocks, defaultResolveWithErrors, defaultThrowLedgerErrors, ledgerDbBimap, ledgerDbPrune, - ledgerDbPush, ledgerDbPush', ledgerDbPushMany', - ledgerDbSwitch, ledgerDbSwitch', ledgerDbWithAnchor) + ledgerDbPush, ledgerDbPushMany', ledgerDbSwitch, + ledgerDbSwitch', ledgerDbWithAnchor) diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/Update.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/Update.hs index ac9b856532..810c23b1d2 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/Update.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/Update.hs @@ -38,7 +38,6 @@ module Ouroboros.Consensus.Storage.LedgerDB.Update ( , ledgerDbPush , ledgerDbSwitch -- * Pure API - , ledgerDbPush' , ledgerDbPushMany' , ledgerDbSwitch' -- * Trace @@ -367,10 +366,6 @@ data UpdateLedgerDbTraceEvent blk = pureBlock :: blk -> Ap m l blk () pureBlock = ReapplyVal -ledgerDbPush' :: ApplyBlock l blk - => LedgerDbCfg l -> blk -> LedgerDB l -> LedgerDB l -ledgerDbPush' cfg b = runIdentity . ledgerDbPush cfg (pureBlock b) - ledgerDbPushMany' :: ApplyBlock l blk => LedgerDbCfg l -> [blk] -> LedgerDB l -> LedgerDB l ledgerDbPushMany' cfg bs = @@ -383,4 +378,3 @@ ledgerDbSwitch' cfg n bs db = case runIdentity $ ledgerDbSwitch cfg n (const $ pure ()) (map pureBlock bs) db of Left ExceededRollback{} -> Nothing Right db' -> Just db' - diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/Serialisation.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/Serialisation.hs index 5b311758f2..344f8b1c11 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/Serialisation.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/Serialisation.hs @@ -44,7 +44,6 @@ module Ouroboros.Consensus.Storage.Serialisation ( , PrefixLen (..) , ReconstructNestedCtxt (..) , addPrefixLen - , takePrefix -- * Binary block info , BinaryBlockInfo (..) , HasBinaryBlockInfo (..) @@ -66,7 +65,7 @@ import Data.SOP.BasicFunctors import Ouroboros.Consensus.Block import Ouroboros.Consensus.Protocol.Abstract import Ouroboros.Consensus.Storage.Common (BinaryBlockInfo (..), - PrefixLen (..), addPrefixLen, takePrefix) + PrefixLen (..), addPrefixLen) import Ouroboros.Consensus.TypeFamilyWrappers import Ouroboros.Consensus.Util (ShowProxy (..)) import Ouroboros.Consensus.Util.RedundantConstraints diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/VolatileDB/API.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/VolatileDB/API.hs index a0d7a7e98b..d4de75ec67 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/VolatileDB/API.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/VolatileDB/API.hs @@ -22,7 +22,6 @@ module Ouroboros.Consensus.Storage.VolatileDB.API ( -- * Derived functionality , getIsMember , getKnownBlockComponent - , getPredecessor , withDB ) where @@ -240,12 +239,6 @@ getIsMember :: -> STM m (HeaderHash blk -> Bool) getIsMember = fmap (isJust .) . getBlockInfo -getPredecessor :: - Functor (STM m) - => VolatileDB m blk - -> STM m (HeaderHash blk -> Maybe (ChainHash blk)) -getPredecessor = fmap (fmap biPrevHash .) . getBlockInfo - getKnownBlockComponent :: (MonadThrow m, HasHeader blk) => VolatileDB m blk diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/VolatileDB/Impl.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/VolatileDB/Impl.hs index df92030f12..2aa28840f4 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/VolatileDB/Impl.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/VolatileDB/Impl.hs @@ -119,6 +119,7 @@ import qualified Codec.CBOR.Write as CBOR import Control.Monad (unless, when) import Control.Monad.State.Strict (get, gets, lift, modify, put, state) +import Control.ResourceRegistry import Control.Tracer (Tracer, nullTracer, traceWith) import qualified Data.ByteString.Lazy as Lazy import Data.List as List (foldl') @@ -142,7 +143,6 @@ import Ouroboros.Consensus.Storage.VolatileDB.Impl.Util import Ouroboros.Consensus.Util.Args import Ouroboros.Consensus.Util.IOLike import qualified Ouroboros.Consensus.Util.MonadSTM.RAWLock as RAWLock -import Ouroboros.Consensus.Util.ResourceRegistry import Ouroboros.Network.Block (MaxSlotNo (..)) import System.FS.API.Lazy diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/VolatileDB/Impl/State.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/VolatileDB/Impl/State.hs index 1bf8df3945..642e0433ba 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/VolatileDB/Impl/State.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/VolatileDB/Impl/State.hs @@ -21,7 +21,6 @@ module Ouroboros.Consensus.Storage.VolatileDB.Impl.State ( , ReverseIndex , SuccessorsIndex , VolatileDBEnv (..) - , dbIsOpen -- * State helpers , ModifyOpenState , appendOpenState @@ -33,6 +32,8 @@ module Ouroboros.Consensus.Storage.VolatileDB.Impl.State ( import Control.Monad import Control.Monad.State.Strict hiding (withState) +import Control.ResourceRegistry (WithTempRegistry, allocateTemp, + modifyWithTempRegistry) import Control.Tracer (Tracer, traceWith) import qualified Data.ByteString.Lazy as Lazy import Data.List as List (foldl') @@ -56,8 +57,6 @@ import Ouroboros.Consensus.Util (whenJust, (.:)) import Ouroboros.Consensus.Util.IOLike import Ouroboros.Consensus.Util.MonadSTM.RAWLock (RAWLock) import qualified Ouroboros.Consensus.Util.MonadSTM.RAWLock as RAWLock -import Ouroboros.Consensus.Util.ResourceRegistry (WithTempRegistry, - allocateTemp, modifyWithTempRegistry) import Ouroboros.Network.Block (MaxSlotNo (..)) import System.FS.API @@ -79,10 +78,6 @@ data InternalState blk h = | DbOpen !(OpenState blk h) deriving (Generic, NoThunks) -dbIsOpen :: InternalState blk h -> Bool -dbIsOpen (DbOpen _) = True -dbIsOpen DbClosed = False - -- | Internal state when the database is open. data OpenState blk h = OpenState { currentWriteHandle :: !(Handle h) diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/VolatileDB/Impl/Util.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/VolatileDB/Impl/Util.hs index 54530d02f4..32c38933a5 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/VolatileDB/Impl/Util.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/VolatileDB/Impl/Util.hs @@ -6,7 +6,6 @@ module Ouroboros.Consensus.Storage.VolatileDB.Impl.Util ( -- * FileId utilities filePath - , findLastFd , parseAllFds , parseFd -- * Exception handling @@ -63,10 +62,6 @@ parseAllFds = first (sortOn fst) . foldr judge ([], []) Nothing -> (parsed, fsPath : notParsed) Just fileId -> ((fileId, fsPath) : parsed, notParsed) --- | This also returns any 'FsPath' which failed to parse. -findLastFd :: [FsPath] -> (Maybe FileId, [FsPath]) -findLastFd = first (fmap fst . lastMaybe) . parseAllFds - filePath :: FileId -> FsPath filePath fd = mkFsPath ["blocks-" ++ show fd ++ ".dat"] diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util.hs index d897509e06..b4a4f16d42 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util.hs @@ -17,12 +17,10 @@ -- | Miscellaneous utilities module Ouroboros.Consensus.Util ( -- * Type-level utility - Empty - , ShowProxy (..) + ShowProxy (..) , Some (..) , SomePair (..) , SomeSecond (..) - , mustBeRight -- * Folding variations , foldlM' , nTimes @@ -31,11 +29,8 @@ module Ouroboros.Consensus.Util ( , repeatedlyM -- * Lists , allEqual - , chunks , dropLast , firstJust - , markLast - , pickOne , split , splits , takeLast @@ -46,17 +41,9 @@ module Ouroboros.Consensus.Util ( , safeMaximumBy , safeMaximumOn -- * Hashes - , hashFromBytesE , hashFromBytesShortE - -- * Bytestrings - , byteStringChunks - , lazyByteStringChunks -- * Monadic utilities , whenJust - -- * Test code - , checkThat - -- * Sets - , allDisjoint -- * Composition , (......:) , (.....:) @@ -79,13 +66,10 @@ module Ouroboros.Consensus.Util ( , withFuse ) where -import Cardano.Crypto.Hash (Hash, HashAlgorithm, hashFromBytes, - hashFromBytesShort) +import Cardano.Crypto.Hash (Hash, HashAlgorithm, hashFromBytesShort) import Control.Monad (unless) import Control.Monad.Class.MonadThrow import Control.Monad.Trans.Class -import qualified Data.ByteString as Strict -import qualified Data.ByteString.Lazy as Lazy import Data.ByteString.Short (ShortByteString) import Data.Foldable (asum, toList) import Data.Function (on) @@ -95,10 +79,7 @@ import Data.Kind (Type) import Data.List as List (foldl', maximumBy) import Data.List.NonEmpty (NonEmpty (..), (<|)) import Data.Maybe (fromMaybe) -import Data.Set (Set) -import qualified Data.Set as Set import Data.Text (Text) -import Data.Void import Data.Word (Word64) import GHC.Generics (Generic) import GHC.Stack @@ -110,9 +91,6 @@ import Ouroboros.Network.Util.ShowProxy (ShowProxy (..)) Type-level utility -------------------------------------------------------------------------------} -class Empty a -instance Empty a - -- | Pair of functors instantiated to the /same/ existential data SomePair (f :: k -> Type) (g :: k -> Type) where SomePair :: f a -> g a -> SomePair f g @@ -125,10 +103,6 @@ type SomeSecond :: (k1 -> k2 -> Type) -> k1 -> Type data SomeSecond f a where SomeSecond :: !(f a b) -> SomeSecond f a -mustBeRight :: Either Void a -> a -mustBeRight (Left v) = absurd v -mustBeRight (Right a) = a - {------------------------------------------------------------------------------- Folding variations -------------------------------------------------------------------------------} @@ -163,30 +137,6 @@ nTimesM f = go Lists -------------------------------------------------------------------------------} -chunks :: Int -> [a] -> [[a]] -chunks _ [] = [] -chunks n xs = let (chunk, xs') = splitAt n xs - in chunk : chunks n xs' - --- | All possible ways to pick on element from a list, preserving order --- --- > pickOne [1,2,3] = [ ([], 1, [2, 3]) --- > , ([1], 2, [3]) --- > , ([1,2], 3, []) --- > ] -pickOne :: [a] -> [([a], a, [a])] -pickOne [] = [] -pickOne (x:xs) = ([], x, xs) - : map (\(as, b, cs) -> (x:as, b, cs)) (pickOne xs) - --- | Mark the last element of the list as 'Right' -markLast :: [a] -> [Either a a] -markLast = go - where - go [] = [] - go [x] = [Right x] - go (x:xs) = Left x : go xs - -- | Take the last @n@ elements takeLast :: Word64 -> [a] -> [a] takeLast n = reverse . take (fromIntegral n) . reverse @@ -274,18 +224,6 @@ safeMaximumOn f = safeMaximumBy (compare `on` f) Hashes -------------------------------------------------------------------------------} --- | Calls 'hashFromBytes' and throws an error if the input is of the wrong --- length. -hashFromBytesE :: - forall h a. (HashAlgorithm h, HasCallStack) - => Strict.ByteString - -> Hash h a -hashFromBytesE bs = fromMaybe (error msg) $ hashFromBytes bs - where - msg = - "hashFromBytes called with ByteString of the wrong length: " <> - show bs - -- | Calls 'hashFromBytesShort' and throws an error if the input is of the -- wrong length. hashFromBytesShortE :: @@ -297,18 +235,6 @@ hashFromBytesShortE bs = fromMaybe (error msg) $ hashFromBytesShort bs msg = "hashFromBytesShort called with ShortByteString of the wrong length: " <> show bs -{------------------------------------------------------------------------------- - Bytestrings --------------------------------------------------------------------------------} - -byteStringChunks :: Int -> Strict.ByteString -> [Strict.ByteString] -byteStringChunks n = map Strict.pack . chunks n . Strict.unpack - -lazyByteStringChunks :: Int -> Lazy.ByteString -> [Lazy.ByteString] -lazyByteStringChunks n bs - | Lazy.null bs = [] - | otherwise = let (chunk, bs') = Lazy.splitAt (fromIntegral n) bs - in chunk : lazyByteStringChunks n bs' {------------------------------------------------------------------------------- Monadic utilities @@ -318,35 +244,6 @@ whenJust :: Applicative f => Maybe a -> (a -> f ()) -> f () whenJust (Just x) f = f x whenJust Nothing _ = pure () -{------------------------------------------------------------------------------- - Test code --------------------------------------------------------------------------------} - --- | Assertion --- --- Variation on 'assert' for use in testing code. -checkThat :: (Show a, Monad m) - => String - -> (a -> Bool) - -> a - -> m () -checkThat label prd a - | prd a = return () - | otherwise = error $ label ++ " failed on " ++ show a ++ "\n" - ++ prettyCallStack callStack - -{------------------------------------------------------------------------------- - Sets --------------------------------------------------------------------------------} - --- | Check that a bunch of sets are all mutually disjoint -allDisjoint :: forall a. Ord a => [Set a] -> Bool -allDisjoint = go Set.empty - where - go :: Set a -> [Set a] -> Bool - go _ [] = True - go acc (xs:xss) = Set.disjoint acc xs && go (Set.union acc xs) xss - {------------------------------------------------------------------------------- Composition -------------------------------------------------------------------------------} diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util/AnchoredFragment.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util/AnchoredFragment.hs index a08d3bdc5c..006db1ae91 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util/AnchoredFragment.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util/AnchoredFragment.hs @@ -6,7 +6,6 @@ -- > import qualified Ouroboros.Consensus.Util.AnchoredFragment as AF module Ouroboros.Consensus.Util.AnchoredFragment ( compareAnchoredFragments - , compareHeadBlockNo , cross , forksAtMostKBlocks , preferAnchoredCandidate @@ -15,7 +14,6 @@ module Ouroboros.Consensus.Util.AnchoredFragment ( import Control.Monad.Except (throwError) import Data.Foldable (toList) -import Data.Function (on) import qualified Data.List as L import Data.Maybe (isJust) import Data.Word (Word64) @@ -31,29 +29,6 @@ import qualified Ouroboros.Network.AnchoredFragment as AF Utility functions on anchored fragments -------------------------------------------------------------------------------} --- | Compare the 'headBlockNo', which is a measure of the length of the chain, --- of two anchored fragments. --- --- A fragment with a head is always \"greater\" than one without. When both --- fragments have no head (i.e. are empty), they are 'EQ'. --- --- Note that an EBB can share its @BlockNo@ with another regular block. If --- such an EBB is the head of one fragment and the regular block with the same --- @BlockNo@ is the head of the other fragment, then this function will say --- they are 'EQ', while in fact one fragment should be preferred over the --- other. --- --- This is not a big deal as we won't be seeing new EBBs, so they will not be --- the head of a fragment very often anyway, only when catching up. As soon as --- a new block/header is added to the fragment, the right decision will be --- made again ('GT' or 'LT'). -compareHeadBlockNo :: - HasHeader b - => AnchoredFragment b - -> AnchoredFragment b - -> Ordering -compareHeadBlockNo = compare `on` AF.headBlockNo - forksAtMostKBlocks :: HasHeader b => Word64 -- ^ How many blocks can it fork? diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util/CBOR.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util/CBOR.hs index 5ab51c9c53..9ca9857b9d 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util/CBOR.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util/CBOR.hs @@ -4,27 +4,16 @@ {-# LANGUAGE ScopedTypeVariables #-} module Ouroboros.Consensus.Util.CBOR ( - -- * Incremental parsing in I/O - IDecodeIO (..) - , deserialiseIncrementalIO - , fromIDecode - -- * Higher-level incremental interface - , Decoder (..) - , initDecoderIO -- * Decode as FlatTerm - , decodeAsFlatTerm + decodeAsFlatTerm -- * HasFS interaction , ReadIncrementalErr (..) , readIncremental , withStreamIncrementalOffsets -- * Encoding/decoding containers - , decodeList , decodeMaybe - , decodeSeq , decodeWithOrigin - , encodeList , encodeMaybe - , encodeSeq , encodeWithOrigin ) where @@ -35,8 +24,6 @@ import qualified Codec.CBOR.Decoding as CBOR.D import qualified Codec.CBOR.Encoding as CBOR.E import qualified Codec.CBOR.FlatTerm as CBOR.F import qualified Codec.CBOR.Read as CBOR.R -import Control.Exception (assert) -import Control.Monad import Control.Monad.Except import Control.Monad.ST import qualified Control.Monad.ST.Lazy as ST.Lazy @@ -44,10 +31,6 @@ import Data.ByteString (ByteString) import qualified Data.ByteString as BS import Data.ByteString.Builder.Extra (defaultChunkSize) import qualified Data.ByteString.Lazy as LBS -import Data.Foldable (toList) -import Data.IORef -import Data.Sequence.Strict (StrictSeq) -import qualified Data.Sequence.Strict as Seq import Data.Word (Word64) import GHC.Stack (HasCallStack) import Ouroboros.Consensus.Util.IOLike as U @@ -56,65 +39,6 @@ import qualified Streaming.Prelude as S import Streaming.Prelude (Of (..), Stream) import System.FS.API -{------------------------------------------------------------------------------- - Incremental parsing in I/O --------------------------------------------------------------------------------} - -data IDecodeIO a = - Partial (Maybe ByteString -> IO (IDecodeIO a)) - | Done !ByteString !CBOR.R.ByteOffset a - | Fail !ByteString !CBOR.R.ByteOffset CBOR.R.DeserialiseFailure - -fromIDecode :: CBOR.R.IDecode RealWorld a -> IDecodeIO a -fromIDecode (CBOR.R.Partial k) = Partial $ fmap fromIDecode . U.stToIO . k -fromIDecode (CBOR.R.Done bs off x) = Done bs off x -fromIDecode (CBOR.R.Fail bs off e) = Fail bs off e - -deserialiseIncrementalIO :: (forall s. CBOR.D.Decoder s a) -> IO (IDecodeIO a) -deserialiseIncrementalIO = fmap fromIDecode - . U.stToIO - . CBOR.R.deserialiseIncremental - -{------------------------------------------------------------------------------- - Higher-level incremental interface --------------------------------------------------------------------------------} - -data Decoder m = Decoder { - -- | Decode next failure - -- - -- May throw 'CBOR.DeserialiseFailure' - decodeNext :: forall a. (forall s. CBOR.D.Decoder s a) -> m a - } - --- | Construct incremental decoder given a way to get chunks --- --- Resulting decoder is not thread safe. -initDecoderIO :: IO ByteString -> IO (Decoder IO) -initDecoderIO getChunk = do - leftover <- newIORef BS.empty - let go :: forall a. (forall s. CBOR.D.Decoder s a) -> IO a - go decoder = do - i <- deserialiseIncrementalIO decoder - case i of - Done bs _ a -> assert (BS.null bs) $ return a - Fail _ _ e -> throwIO e - Partial k -> readIORef leftover >>= (k . Just >=> goWith) - - goWith :: forall a. IDecodeIO a -> IO a - goWith (Partial k) = getChunk' >>= (k >=> goWith) - goWith (Done bs _ a) = writeIORef leftover bs >> return a - goWith (Fail _ _ e) = throwIO e - - return $ Decoder go - - where - getChunk' :: IO (Maybe ByteString) - getChunk' = checkEmpty <$> getChunk - - checkEmpty :: ByteString -> Maybe ByteString - checkEmpty bs | BS.null bs = Nothing - | otherwise = Just bs - {------------------------------------------------------------------------------- Decode as FlatTerm -------------------------------------------------------------------------------} @@ -297,26 +221,6 @@ withStreamIncrementalOffsets hasFS@HasFS{..} decoder fp = \k -> Encoding/decoding lists -------------------------------------------------------------------------------} -encodeList :: (a -> CBOR.E.Encoding) -> [a] -> CBOR.E.Encoding -encodeList _ [] = CBOR.E.encodeListLen 0 -encodeList enc xs = mconcat [ - CBOR.E.encodeListLenIndef - , foldr (\x r -> enc x <> r) CBOR.E.encodeBreak xs - ] - -decodeList :: CBOR.D.Decoder s a -> CBOR.D.Decoder s [a] -decodeList dec = do - mn <- CBOR.D.decodeListLenOrIndef - case mn of - Nothing -> CBOR.D.decodeSequenceLenIndef (flip (:)) [] reverse dec - Just n -> CBOR.D.decodeSequenceLenN (flip (:)) [] reverse n dec - -encodeSeq :: (a -> CBOR.E.Encoding) -> StrictSeq a -> CBOR.E.Encoding -encodeSeq f = encodeList f . toList - -decodeSeq :: CBOR.D.Decoder s a -> CBOR.D.Decoder s (StrictSeq a) -decodeSeq f = Seq.fromList <$> decodeList f - encodeWithOrigin :: (a -> CBOR.E.Encoding) -> WithOrigin a -> CBOR.E.Encoding encodeWithOrigin f = encodeMaybe f . withOriginToMaybe diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util/Condense.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util/Condense.hs index 989578ada6..aa3f495bcc 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util/Condense.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util/Condense.hs @@ -1,7 +1,6 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE TypeApplications #-} {-# LANGUAGE UndecidableInstances #-} module Ouroboros.Consensus.Util.Condense ( @@ -33,15 +32,12 @@ import Data.Int import Data.List (intercalate, maximumBy) import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map -import Data.Proxy import Data.Set (Set) import qualified Data.Set as Set import Data.Text (Text, unpack) import Data.Void import Data.Word import Numeric.Natural -import Ouroboros.Consensus.Util.HList (All, HList (..)) -import qualified Ouroboros.Consensus.Util.HList as HList import Ouroboros.Network.AnchoredFragment (AnchoredFragment) import qualified Ouroboros.Network.AnchoredFragment as AF import Ouroboros.Network.Block @@ -141,16 +137,16 @@ instance Condense a => Condense (Set a) where condense = condense1 instance (Condense a, Condense b) => Condense (a, b) where - condense (a, b) = condense (a :* b :* Nil) + condense (a, b) = "(" ++ condense a ++ "," ++ condense b ++ ")" instance (Condense a, Condense b, Condense c) => Condense (a, b, c) where - condense (a, b, c) = condense (a :* b :* c :* Nil) + condense (a, b, c) = "(" ++ condense a ++ "," ++ condense b ++ "," ++ condense c ++ "," ++ ")" instance (Condense a, Condense b, Condense c, Condense d) => Condense (a, b, c, d) where - condense (a, b, c, d) = condense (a :* b :* c :* d :* Nil) + condense (a, b, c, d) = "(" ++ condense a ++ "," ++ condense b ++ "," ++ condense c ++ "," ++ condense d ++ "," ++ ")" instance (Condense a, Condense b, Condense c, Condense d, Condense e) => Condense (a, b, c, d, e) where - condense (a, b, c, d, e) = condense (a :* b :* c :* d :* e :* Nil) + condense (a, b, c, d, e) = "(" ++ condense a ++ "," ++ condense b ++ "," ++ condense c ++ "," ++ condense d ++ "," ++ condense e ++ "," ++ ")" instance (Condense k, Condense a) => Condense (Map k a) where condense = condense . Map.toList @@ -161,13 +157,6 @@ instance Condense BS.Strict.ByteString where instance Condense BS.Lazy.ByteString where condense bs = show bs ++ "<" ++ show (BS.Lazy.length bs) ++ "b>" -{------------------------------------------------------------------------------- - Consensus specific general purpose types --------------------------------------------------------------------------------} - -instance All Condense as => Condense (HList as) where - condense as = "(" ++ intercalate "," (HList.collapse (Proxy @Condense) condense as) ++ ")" - {------------------------------------------------------------------------------- Instances for ouroboros-network -------------------------------------------------------------------------------} diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util/EarlyExit.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util/EarlyExit.hs index dbd9ad0217..b7dae17dbe 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util/EarlyExit.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util/EarlyExit.hs @@ -22,6 +22,7 @@ module Ouroboros.Consensus.Util.EarlyExit ( import Control.Applicative import Control.Concurrent.Class.MonadMVar +import Control.Concurrent.Class.MonadMVar.NormalForm (StrictMVar) import Control.Monad import Control.Monad.Class.MonadAsync import Control.Monad.Class.MonadEventlog @@ -41,7 +42,6 @@ import NoThunks.Class (NoThunks (..)) import Ouroboros.Consensus.Util ((.:)) import Ouroboros.Consensus.Util.IOLike (IOLike (..), PrimMonad (..), StrictSVar, StrictTVar, castStrictSVar, castStrictTVar) -import Ouroboros.Consensus.Util.NormalForm.StrictMVar (StrictMVar) {------------------------------------------------------------------------------- Basic definitions diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util/HList.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util/HList.hs deleted file mode 100644 index c14dbd3bb5..0000000000 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util/HList.hs +++ /dev/null @@ -1,163 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} - --- | Heterogeneous lists --- --- Intended for qualified import -module Ouroboros.Consensus.Util.HList ( - -- * Basic definitions - All - , HList (..) - -- * Folding - , collapse - , foldMap - , foldl - , foldlM - , foldr - , repeatedly - , repeatedlyM - -- * Singletons - , IsList (..) - , SList - -- * n-ary functions - , Fn - , afterFn - , applyFn - ) where - -import Data.Kind (Constraint, Type) -import Data.Proxy -import Prelude hiding (foldMap, foldl, foldr) - -{------------------------------------------------------------------------------- - Basic definitions --------------------------------------------------------------------------------} - -data HList :: [Type] -> Type where - Nil :: HList '[] - (:*) :: a -> HList as -> HList (a ': as) - -infixr :* - -type family All c as :: Constraint where - All c '[] = () - All c (a ': as) = (c a, All c as) - -instance All Show as => Show (HList as) where - show = show . collapse (Proxy @Show) show - -instance (IsList as, All Eq as) => Eq (HList as) where - (==) = eq isList - where - eq :: All Eq bs => SList bs -> HList bs -> HList bs -> Bool - eq SNil _ _ = True - eq (SCons s) (x :* xs) (y :* ys) = x == y && eq s xs ys - -instance (IsList as, All Eq as, All Ord as) => Ord (HList as) where - compare = cmp isList - where - cmp :: All Ord bs => SList bs -> HList bs -> HList bs -> Ordering - cmp SNil _ _ = EQ - cmp (SCons s) (x :* xs) (y :* ys) = compare x y <> cmp s xs ys - -{------------------------------------------------------------------------------- - Folding --------------------------------------------------------------------------------} - -foldl :: forall c as b proxy. All c as - => proxy c - -> (forall a. c a => b -> a -> b) -> b -> HList as -> b -foldl _ f = go - where - go :: All c as' => b -> HList as' -> b - go !acc Nil = acc - go !acc (a :* as) = go (f acc a) as - -foldlM :: forall c as m b proxy. (All c as, Monad m) - => proxy c - -> (forall a. c a => b -> a -> m b) -> b -> HList as -> m b -foldlM _ f = go - where - go :: All c as' => b -> HList as' -> m b - go !acc Nil = return acc - go !acc (a :* as) = f acc a >>= \acc' -> go acc' as - -foldr :: forall c as b proxy. All c as - => proxy c - -> (forall a. c a => a -> b -> b) -> b -> HList as -> b -foldr _ f e = go - where - go :: All c as' => HList as' -> b - go Nil = e - go (a :* as) = f a (go as) - -foldMap :: forall c as b proxy. (All c as, Monoid b) - => proxy c - -> (forall a. c a => a -> b) - -> HList as - -> b -foldMap p f = foldl p (\b a -> b <> f a) mempty - --- | Apply function repeatedly for all elements of the list --- --- > repeatedly p = flip . foldl p . flip -repeatedly :: forall c as b proxy. All c as - => proxy c - -> (forall a. c a => a -> b -> b) -> (HList as -> b -> b) -repeatedly p f as e = foldl p (\b a -> f a b) e as - -repeatedlyM :: forall c as b proxy m. (Monad m, All c as) - => proxy c - -> (forall a. c a => a -> b -> m b) -> (HList as -> b -> m b) -repeatedlyM p f as e = foldlM p (\b a -> f a b) e as - -collapse :: forall c as b proxy. All c as - => proxy c - -> (forall a. c a => a -> b) -> HList as -> [b] -collapse _ f = go - where - go :: All c as' => HList as' -> [b] - go Nil = [] - go (a :* as) = f a : go as - -{------------------------------------------------------------------------------- - Singleton for HList --------------------------------------------------------------------------------} - -data SList :: [Type] -> Type where - SNil :: SList '[] - SCons :: SList as -> SList (a ': as) - -class IsList (xs :: [Type]) where - isList :: SList xs - -instance IsList '[] where isList = SNil -instance IsList as => IsList (a ': as) where isList = SCons isList - -{------------------------------------------------------------------------------- - n-ary functions --------------------------------------------------------------------------------} - -type family Fn as b where - Fn '[] b = b - Fn (a ': as) b = a -> Fn as b - -withArgs :: HList as -> Fn as b -> b -withArgs Nil b = b -withArgs (a :* as) f = withArgs as (f a) - -applyFn :: Fn as b -> HList as -> b -applyFn = flip withArgs - -afterFn :: SList as -> (b -> c) -> Fn as b -> Fn as c -afterFn SNil g b = g b -afterFn (SCons ss) g f = afterFn ss g . f diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util/IOLike.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util/IOLike.hs index 20dade8dff..7eb1e13695 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util/IOLike.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util/IOLike.hs @@ -13,9 +13,8 @@ module Ouroboros.Consensus.Util.IOLike ( , MonadThrow (..) , SomeException -- *** Variables with NoThunks invariants - , module Ouroboros.Consensus.Util.MonadSTM.NormalForm - , module Ouroboros.Consensus.Util.NormalForm.StrictMVar - , module Ouroboros.Consensus.Util.NormalForm.StrictTVar + , module Control.Concurrent.Class.MonadMVar.NormalForm + , module Control.Concurrent.Class.MonadSTM.NormalForm -- *** MonadFork, TODO: Should we hide this in favour of MonadAsync? , MonadFork (..) , MonadThread (..) @@ -24,10 +23,14 @@ module Ouroboros.Consensus.Util.IOLike ( , ExceptionInLinkedThread (..) , MonadAsync (..) , link - , linkTo -- *** MonadST , MonadST (..) , PrimMonad (..) + -- *** MonadSTM + , MonadInspectSTM (..) + , MonadLabelledSTM + , MonadSTM (..) + , throwSTM -- *** MonadTime , DiffTime , MonadMonotonicTime (..) @@ -48,19 +51,18 @@ import Cardano.Crypto.KES (KESAlgorithm, SignKeyKES) import qualified Cardano.Crypto.KES as KES import Control.Applicative (Alternative) import Control.Concurrent.Class.MonadMVar +import Control.Concurrent.Class.MonadMVar.NormalForm +import Control.Concurrent.Class.MonadSTM.NormalForm import Control.Monad.Class.MonadAsync import Control.Monad.Class.MonadEventlog import Control.Monad.Class.MonadFork import Control.Monad.Class.MonadST +import Control.Monad.Class.MonadSTM import Control.Monad.Class.MonadThrow import Control.Monad.Class.MonadTime.SI import Control.Monad.Class.MonadTimer.SI import Control.Monad.Primitive -import Data.Functor (void) import NoThunks.Class (NoThunks (..)) -import Ouroboros.Consensus.Util.MonadSTM.NormalForm -import Ouroboros.Consensus.Util.NormalForm.StrictMVar -import Ouroboros.Consensus.Util.NormalForm.StrictTVar import Ouroboros.Consensus.Util.Orphans () {------------------------------------------------------------------------------- @@ -94,48 +96,3 @@ class ( MonadAsync m instance IOLike IO where forgetSignKeyKES = KES.forgetSignKeyKES - --- | Generalization of 'link' that links an async to an arbitrary thread. --- --- Non standard (not in 'async' library) --- -linkTo :: (MonadAsync m, MonadFork m, MonadMask m) - => ThreadId m -> Async m a -> m () -linkTo tid = linkToOnly tid (not . isCancel) - --- | Generalization of 'linkOnly' that links an async to an arbitrary thread. --- --- Non standard (not in 'async' library). --- -linkToOnly :: forall m a. (MonadAsync m, MonadFork m, MonadMask m) - => ThreadId m -> (SomeException -> Bool) -> Async m a -> m () -linkToOnly tid shouldThrow a = do - void $ forkRepeat ("linkToOnly " <> show linkedThreadId) $ do - r <- waitCatch a - case r of - Left e | shouldThrow e -> throwTo tid (exceptionInLinkedThread e) - _otherwise -> return () - where - linkedThreadId :: ThreadId m - linkedThreadId = asyncThreadId a - - exceptionInLinkedThread :: SomeException -> ExceptionInLinkedThread - exceptionInLinkedThread = - ExceptionInLinkedThread (show linkedThreadId) - -isCancel :: SomeException -> Bool -isCancel e - | Just AsyncCancelled <- fromException e = True - | otherwise = False - -forkRepeat :: (MonadFork m, MonadMask m) => String -> m a -> m (ThreadId m) -forkRepeat label action = - mask $ \restore -> - let go = do r <- tryAll (restore action) - case r of - Left _ -> go - _ -> return () - in forkIO (labelThisThread label >> go) - -tryAll :: MonadCatch m => m a -> m (Either SomeException a) -tryAll = try diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util/STM.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util/STM.hs index f1193a61b0..081434ed0f 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util/STM.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util/STM.hs @@ -15,24 +15,16 @@ module Ouroboros.Consensus.Util.STM ( -- * Misc , Fingerprint (..) , WithFingerprint (..) - , blockUntilAllJust , blockUntilChanged , blockUntilJust - , runWhenJust - -- * Simulate various monad stacks in STM - , Sim (..) - , simId - , simStateT ) where -import Control.Monad (void) -import Control.Monad.State (StateT (..)) +import Control.ResourceRegistry import Data.Void import Data.Word (Word64) import GHC.Generics (Generic) import GHC.Stack import Ouroboros.Consensus.Util.IOLike -import Ouroboros.Consensus.Util.ResourceRegistry {------------------------------------------------------------------------------- Misc @@ -48,19 +40,6 @@ blockUntilChanged f b getA = do then retry else return (a, b') --- | Spawn a new thread that waits for an STM value to become 'Just' --- --- The thread will be linked to the registry. -runWhenJust :: IOLike m - => ResourceRegistry m - -> String -- ^ Label for the thread - -> STM m (Maybe a) - -> (a -> m ()) - -> m () -runWhenJust registry label getMaybeA action = - void $ forkLinkedThread registry label $ - action =<< atomically (blockUntilJust getMaybeA) - blockUntilJust :: MonadSTM m => STM m (Maybe a) -> STM m a blockUntilJust getMaybeA = do ma <- getMaybeA @@ -68,9 +47,6 @@ blockUntilJust getMaybeA = do Nothing -> retry Just a -> return a -blockUntilAllJust :: MonadSTM m => [STM m (Maybe a)] -> STM m [a] -blockUntilAllJust = mapM blockUntilJust - -- | Simple type that can be used to indicate something in a @TVar@ is -- changed. newtype Fingerprint = Fingerprint Word64 @@ -84,22 +60,6 @@ data WithFingerprint a = WithFingerprint , getFingerprint :: !Fingerprint } deriving (Show, Eq, Functor, Generic, NoThunks) -{------------------------------------------------------------------------------- - Simulate monad stacks --------------------------------------------------------------------------------} - -newtype Sim n m = Sim { runSim :: forall a. n a -> STM m a } - -simId :: Sim (STM m) m -simId = Sim id - -simStateT :: IOLike m => StrictTVar m st -> Sim n m -> Sim (StateT st n) m -simStateT stVar (Sim k) = Sim $ \(StateT f) -> do - st <- readTVar stVar - (a, st') <- k (f st) - writeTVar stVar st' - return a - {------------------------------------------------------------------------------- Watchers -------------------------------------------------------------------------------} diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util/Versioned.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util/Versioned.hs index 631f16df34..01ff7339f9 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util/Versioned.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util/Versioned.hs @@ -15,7 +15,6 @@ module Ouroboros.Consensus.Util.Versioned ( , decodeVersionWithHook , decodeVersioned , encodeVersion - , encodeVersioned -- * opaque , VersionNumber ) where @@ -98,8 +97,7 @@ encodeVersion vn encodedA = mconcat , encodedA ] --- | Decode a /versioned/ @a@ (encoded using 'encodeVersion' or --- 'encodeVersioned'). +-- | Decode a /versioned/ @a@ (encoded using 'encodeVersion'). -- -- The corresponding 'VersionDecoder' for the deserialised 'VersionNumber' is -- looked up in the given list. The first match is used (using the semantics @@ -157,12 +155,6 @@ decodeVersionWithHook hook versionDecoders = do Nothing -> fail $ show $ UnknownVersion vn Just vDec -> getVersionDecoder vn vDec -encodeVersioned :: - ( a -> Encoding) - -> (Versioned a -> Encoding) -encodeVersioned enc (Versioned vn a) = - encodeVersion vn (enc a) - decodeVersioned :: [(VersionNumber, VersionDecoder a)] -> forall s. Decoder s (Versioned a) diff --git a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Ouroboros/Consensus/ChainGenerator/Adversarial.hs b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Consensus/ChainGenerator/Adversarial.hs similarity index 97% rename from ouroboros-consensus/src/unstable-consensus-testlib/Test/Ouroboros/Consensus/ChainGenerator/Adversarial.hs rename to ouroboros-consensus/src/unstable-consensus-testlib/Test/Consensus/ChainGenerator/Adversarial.hs index 386e1f9c57..c7b61ac1fd 100644 --- a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Ouroboros/Consensus/ChainGenerator/Adversarial.hs +++ b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Consensus/ChainGenerator/Adversarial.hs @@ -10,7 +10,7 @@ {-# LANGUAGE TypeApplications #-} -- TODO rename to .Alternative? -module Test.Ouroboros.Consensus.ChainGenerator.Adversarial ( +module Test.Consensus.ChainGenerator.Adversarial ( -- * Generating AdversarialRecipe (AdversarialRecipe, arHonest, arParams, arPrefix) , CheckedAdversarialRecipe (UnsafeCheckedAdversarialRecipe, carHonest, carParams, carWin) @@ -35,17 +35,17 @@ import Data.Maybe (fromJust, fromMaybe) import Data.Proxy (Proxy (Proxy)) import qualified Data.Vector.Unboxed as Vector import qualified System.Random.Stateful as R -import qualified Test.Ouroboros.Consensus.ChainGenerator.BitVector as BV -import qualified Test.Ouroboros.Consensus.ChainGenerator.Counting as C -import Test.Ouroboros.Consensus.ChainGenerator.Honest +import qualified Test.Consensus.ChainGenerator.BitVector as BV +import qualified Test.Consensus.ChainGenerator.Counting as C +import Test.Consensus.ChainGenerator.Honest (ChainSchema (ChainSchema), HonestRecipe (HonestRecipe)) -import Test.Ouroboros.Consensus.ChainGenerator.Params (Asc, - Delta (Delta), Kcp (Kcp), Scg (Scg)) -import qualified Test.Ouroboros.Consensus.ChainGenerator.RaceIterator as RI -import qualified Test.Ouroboros.Consensus.ChainGenerator.Slot as S -import Test.Ouroboros.Consensus.ChainGenerator.Slot +import Test.Consensus.ChainGenerator.Params (Asc, Delta (Delta), + Kcp (Kcp), Scg (Scg)) +import qualified Test.Consensus.ChainGenerator.RaceIterator as RI +import qualified Test.Consensus.ChainGenerator.Slot as S +import Test.Consensus.ChainGenerator.Slot (E (ActiveSlotE, EmptySlotE, SlotE)) -import qualified Test.Ouroboros.Consensus.ChainGenerator.Some as Some +import qualified Test.Consensus.ChainGenerator.Some as Some ----- @@ -488,7 +488,7 @@ uniformAdversarialChain mbAsc recipe g0 = wrap $ C.createV $ do -- -- There will be at least k unstable slots at the end, plus one more -- active slot a stability window earlier. - -- See Note [Minimum schema length] in "Test.Ouroboros.Consensus.ChainGenerator.Honest" + -- See Note [Minimum schema length] in "Test.Consensus.ChainGenerator.Honest" -- for the rationale. let trailingSlots = s + k szFirstActive = sz C.- trailingSlots @@ -778,7 +778,7 @@ withinYS (Delta d) !mbYS !(RI.Race (C.SomeWindow Proxy win)) = case mbYS of -- -- The result is guaranteed to leave more than k active slots after the -- intersection in the honest and the adversarial chains. --- See Note [Minimum schema length] in "Test.Ouroboros.Consensus.ChainGenerator.Honest" +-- See Note [Minimum schema length] in "Test.Consensus.ChainGenerator.Honest" -- for the rationale of the precondition. -- -- PRECONDITION: @schemaSize schedH >= s + d + k + 1@ @@ -802,7 +802,7 @@ genPrefixBlockCount (HonestRecipe (Kcp k) (Scg s) (Delta d) _len) g schedH -- -- In the alternative chain, there is enough room to fit k+1 active slots -- as explained the Note [Minimum schema length] in - -- "Test.Ouroboros.Consensus.ChainGenerator.Honest". + -- "Test.Consensus.ChainGenerator.Honest". activesInPrefix = BV.countActivesInV S.notInverted diff --git a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Ouroboros/Consensus/ChainGenerator/BitVector.hs b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Consensus/ChainGenerator/BitVector.hs similarity index 95% rename from ouroboros-consensus/src/unstable-consensus-testlib/Test/Ouroboros/Consensus/ChainGenerator/BitVector.hs rename to ouroboros-consensus/src/unstable-consensus-testlib/Test/Consensus/ChainGenerator/BitVector.hs index 1964075749..14b5dc6139 100644 --- a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Ouroboros/Consensus/ChainGenerator/BitVector.hs +++ b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Consensus/ChainGenerator/BitVector.hs @@ -9,7 +9,7 @@ {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} -module Test.Ouroboros.Consensus.ChainGenerator.BitVector ( +module Test.Consensus.ChainGenerator.BitVector ( -- * Finding MaybeFound (JustFound, NothingFound) , findIthActiveInV @@ -31,11 +31,11 @@ import Control.Monad.ST (ST, runST) import Data.Functor ((<&>)) import qualified Data.Vector.Unboxed.Mutable as MV import qualified System.Random.Stateful as R -import qualified Test.Ouroboros.Consensus.ChainGenerator.Counting as C -import qualified Test.Ouroboros.Consensus.ChainGenerator.Slot as S -import Test.Ouroboros.Consensus.ChainGenerator.Slot +import qualified Test.Consensus.ChainGenerator.Counting as C +import qualified Test.Consensus.ChainGenerator.Slot as S +import Test.Consensus.ChainGenerator.Slot (E (ActiveSlotE, EmptySlotE, SlotE), POL, PreImage, S) -import qualified Test.Ouroboros.Consensus.ChainGenerator.Some as Some +import qualified Test.Consensus.ChainGenerator.Some as Some ----- diff --git a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Ouroboros/Consensus/ChainGenerator/Counting.hs b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Consensus/ChainGenerator/Counting.hs similarity index 97% rename from ouroboros-consensus/src/unstable-consensus-testlib/Test/Ouroboros/Consensus/ChainGenerator/Counting.hs rename to ouroboros-consensus/src/unstable-consensus-testlib/Test/Consensus/ChainGenerator/Counting.hs index 4113b9ee0d..eff96d83ec 100644 --- a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Ouroboros/Consensus/ChainGenerator/Counting.hs +++ b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Consensus/ChainGenerator/Counting.hs @@ -11,7 +11,7 @@ {-# LANGUAGE TypeOperators #-} -- | Very strong types for working with indices, counts, etc within sequences. -module Test.Ouroboros.Consensus.ChainGenerator.Counting ( +module Test.Consensus.ChainGenerator.Counting ( -- * general counts Count (Count) , forgetBase @@ -84,7 +84,7 @@ import GHC.OverloadedLabels (IsLabel (fromLabel)) import Prelude hiding ((+), (-)) import qualified Prelude import qualified System.Random.Stateful as R -import qualified Test.Ouroboros.Consensus.ChainGenerator.Some as Some +import qualified Test.Consensus.ChainGenerator.Some as Some import qualified Test.QuickCheck as QC ----- @@ -102,7 +102,7 @@ infixl 6 .+, .- -- | A type-indexed Int to represent counts of elements in containers -- -- * @base@ is the type-level name of the container in which we are counting (e.g. @Win (Lbl HonestLbl) skolem1@) --- * @elem@ is the type-level name of the elements in the container (e.g. 'Test.Ouroboros.Consensus.ChainGenerator.Slot.SlotE') +-- * @elem@ is the type-level name of the elements in the container (e.g. 'Test.Consensus.ChainGenerator.Slot.SlotE') -- * @which@ is the type-level name of some property that identifies the -- particular elements that we are counting (e.g. 'Pred', 'Total', or 'Other') -- @@ -176,7 +176,7 @@ data Win (lbl :: klbl) (skolem :: Type) -- A window is an infix of the sequence, and it is described with an -- offset and a length or size (the number of elements in the window). -- --- * @elem@ is a type-level name of the elements in the containing sequence (e.g. 'Test.Ouroboros.Consensus.ChainGenerator.Slot.SlotE') +-- * @elem@ is a type-level name of the elements in the containing sequence (e.g. 'Test.Consensus.ChainGenerator.Slot.SlotE') -- * @outer@ is a type-level name identifying the containing sequence (e.g. @Win (Lbl HonestLbl) skolem1@) -- * @inner@ is a type-level name for the window that the value describes (e.g. @Win (Lbl ScgLbl) skolem2@) -- @@ -333,7 +333,7 @@ createV m = Vector $ V.create (getMVector <$> m) -- | A type-indexed vector carrying values of a container -- -- * @base@ is a type-level name identifying the container (e.g. @Win (Lbl HonestLbl) skolem1@) --- * @elem@ is a type-level name of the elements in the container (e.g. 'Test.Ouroboros.Consensus.ChainGenerator.Slot.SlotE') +-- * @elem@ is a type-level name of the elements in the container (e.g. 'Test.Consensus.ChainGenerator.Slot.SlotE') -- newtype MVector base elem s a = MVector (MV.MVector s a) diff --git a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Ouroboros/Consensus/ChainGenerator/Honest.hs b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Consensus/ChainGenerator/Honest.hs similarity index 97% rename from ouroboros-consensus/src/unstable-consensus-testlib/Test/Ouroboros/Consensus/ChainGenerator/Honest.hs rename to ouroboros-consensus/src/unstable-consensus-testlib/Test/Consensus/ChainGenerator/Honest.hs index e48830ea58..aa02ec3a3d 100644 --- a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Ouroboros/Consensus/ChainGenerator/Honest.hs +++ b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Consensus/ChainGenerator/Honest.hs @@ -7,7 +7,7 @@ {-# LANGUAGE TypeApplications #-} {-# LANGUAGE ViewPatterns #-} -module Test.Ouroboros.Consensus.ChainGenerator.Honest ( +module Test.Consensus.ChainGenerator.Honest ( -- * Generating ChainSchema (ChainSchema) , CheckedHonestRecipe (UnsafeCheckedHonestRecipe, chrScgDensity, chrWin) @@ -37,14 +37,13 @@ import Data.STRef (newSTRef, readSTRef, writeSTRef) import qualified Data.Vector.Unboxed as V import Prelude hiding (words) import qualified System.Random.Stateful as R -import qualified Test.Ouroboros.Consensus.ChainGenerator.BitVector as BV -import qualified Test.Ouroboros.Consensus.ChainGenerator.Counting as C -import Test.Ouroboros.Consensus.ChainGenerator.Params (Asc, - Delta (Delta), Kcp (Kcp), Len (Len), Scg (Scg), genKSD) -import qualified Test.Ouroboros.Consensus.ChainGenerator.Slot as S -import Test.Ouroboros.Consensus.ChainGenerator.Slot - (E (ActiveSlotE, SlotE), S) -import qualified Test.Ouroboros.Consensus.ChainGenerator.Some as Some +import qualified Test.Consensus.ChainGenerator.BitVector as BV +import qualified Test.Consensus.ChainGenerator.Counting as C +import Test.Consensus.ChainGenerator.Params (Asc, Delta (Delta), + Kcp (Kcp), Len (Len), Scg (Scg), genKSD) +import qualified Test.Consensus.ChainGenerator.Slot as S +import Test.Consensus.ChainGenerator.Slot (E (ActiveSlotE, SlotE), S) +import qualified Test.Consensus.ChainGenerator.Some as Some import qualified Test.QuickCheck as QC import Test.QuickCheck.Extras (sized1) diff --git a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Ouroboros/Consensus/ChainGenerator/Params.hs b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Consensus/ChainGenerator/Params.hs similarity index 98% rename from ouroboros-consensus/src/unstable-consensus-testlib/Test/Ouroboros/Consensus/ChainGenerator/Params.hs rename to ouroboros-consensus/src/unstable-consensus-testlib/Test/Consensus/ChainGenerator/Params.hs index 1e863c43c1..e52b427e82 100644 --- a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Ouroboros/Consensus/ChainGenerator/Params.hs +++ b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Consensus/ChainGenerator/Params.hs @@ -1,6 +1,6 @@ {-# LANGUAGE PatternSynonyms #-} -module Test.Ouroboros.Consensus.ChainGenerator.Params ( +module Test.Consensus.ChainGenerator.Params ( Asc (Asc, UnsafeAsc) , Delta (Delta) , Kcp (Kcp) diff --git a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Ouroboros/Consensus/ChainGenerator/README.md b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Consensus/ChainGenerator/README.md similarity index 100% rename from ouroboros-consensus/src/unstable-consensus-testlib/Test/Ouroboros/Consensus/ChainGenerator/README.md rename to ouroboros-consensus/src/unstable-consensus-testlib/Test/Consensus/ChainGenerator/README.md diff --git a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Ouroboros/Consensus/ChainGenerator/RaceIterator.hs b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Consensus/ChainGenerator/RaceIterator.hs similarity index 92% rename from ouroboros-consensus/src/unstable-consensus-testlib/Test/Ouroboros/Consensus/ChainGenerator/RaceIterator.hs rename to ouroboros-consensus/src/unstable-consensus-testlib/Test/Consensus/ChainGenerator/RaceIterator.hs index 636f752d57..8b1c35572e 100644 --- a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Ouroboros/Consensus/ChainGenerator/RaceIterator.hs +++ b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Consensus/ChainGenerator/RaceIterator.hs @@ -19,7 +19,7 @@ Valid windows must have @k+1@ active slots. If the vector doesn't have sufficient slots to meet this condition, 'init' and 'next' return 'Nothing' and we fall back to 'initConservative' and 'nextConservative', which return windows truncated at the end of time. -} -module Test.Ouroboros.Consensus.ChainGenerator.RaceIterator ( +module Test.Consensus.ChainGenerator.RaceIterator ( Race (Race, UnsafeRace) , RaceLbl , init @@ -31,11 +31,10 @@ module Test.Ouroboros.Consensus.ChainGenerator.RaceIterator ( import Control.Monad (when) import Data.Proxy (Proxy (Proxy)) import Prelude hiding (init) -import qualified Test.Ouroboros.Consensus.ChainGenerator.BitVector as BV -import qualified Test.Ouroboros.Consensus.ChainGenerator.Counting as C -import Test.Ouroboros.Consensus.ChainGenerator.Params (Kcp (Kcp)) -import Test.Ouroboros.Consensus.ChainGenerator.Slot - (E (ActiveSlotE, SlotE), S) +import qualified Test.Consensus.ChainGenerator.BitVector as BV +import qualified Test.Consensus.ChainGenerator.Counting as C +import Test.Consensus.ChainGenerator.Params (Kcp (Kcp)) +import Test.Consensus.ChainGenerator.Slot (E (ActiveSlotE, SlotE), S) ----- diff --git a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Ouroboros/Consensus/ChainGenerator/Slot.hs b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Consensus/ChainGenerator/Slot.hs similarity index 94% rename from ouroboros-consensus/src/unstable-consensus-testlib/Test/Ouroboros/Consensus/ChainGenerator/Slot.hs rename to ouroboros-consensus/src/unstable-consensus-testlib/Test/Consensus/ChainGenerator/Slot.hs index 547fd5c854..0e5b4b0522 100644 --- a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Ouroboros/Consensus/ChainGenerator/Slot.hs +++ b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Consensus/ChainGenerator/Slot.hs @@ -6,14 +6,14 @@ {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeFamilies #-} -module Test.Ouroboros.Consensus.ChainGenerator.Slot ( +module Test.Consensus.ChainGenerator.Slot ( -- * Counting E (ActiveSlotE, EmptySlotE, SlotE) , complementActive , complementEmpty -- * Slot , S - , Test.Ouroboros.Consensus.ChainGenerator.Slot.showS + , Test.Consensus.ChainGenerator.Slot.showS , genS -- * Reuse , POL (mkActive, test) @@ -30,8 +30,8 @@ import qualified Data.Vector.Generic.Mutable as MVG import qualified Data.Vector.Unboxed as V import qualified Data.Vector.Unboxed.Mutable as MV import qualified System.Random.Stateful as R -import qualified Test.Ouroboros.Consensus.ChainGenerator.Counting as C -import Test.Ouroboros.Consensus.ChainGenerator.Params (Asc, ascVal) +import qualified Test.Consensus.ChainGenerator.Counting as C +import Test.Consensus.ChainGenerator.Params (Asc, ascVal) import qualified Test.QuickCheck as QC -- | The activeness of some slot diff --git a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Ouroboros/Consensus/ChainGenerator/Some.hs b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Consensus/ChainGenerator/Some.hs similarity index 98% rename from ouroboros-consensus/src/unstable-consensus-testlib/Test/Ouroboros/Consensus/ChainGenerator/Some.hs rename to ouroboros-consensus/src/unstable-consensus-testlib/Test/Consensus/ChainGenerator/Some.hs index dc554a26f6..c29c8c432e 100644 --- a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Ouroboros/Consensus/ChainGenerator/Some.hs +++ b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Consensus/ChainGenerator/Some.hs @@ -16,7 +16,7 @@ -- That can be shoehorned into @some@ with some encoding, but I believe this -- module's weight is preferable to the overhead of using that encoding in our -- existential data types' declarations. -module Test.Ouroboros.Consensus.ChainGenerator.Some ( +module Test.Consensus.ChainGenerator.Some ( -- * 'Show' runShowsPrec , showArg diff --git a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Ouroboros/Consensus/DiffusionPipelining.hs b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Consensus/DiffusionPipelining.hs similarity index 93% rename from ouroboros-consensus/src/unstable-consensus-testlib/Test/Ouroboros/Consensus/DiffusionPipelining.hs rename to ouroboros-consensus/src/unstable-consensus-testlib/Test/Consensus/DiffusionPipelining.hs index 2e74d3029f..0e286b07c1 100644 --- a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Ouroboros/Consensus/DiffusionPipelining.hs +++ b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Consensus/DiffusionPipelining.hs @@ -3,7 +3,7 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} -module Test.Ouroboros.Consensus.DiffusionPipelining (prop_diffusionPipeliningSubsequenceConsistency) where +module Test.Consensus.DiffusionPipelining (prop_diffusionPipeliningSubsequenceConsistency) where import Control.Exception (assert) import Data.Either (isRight) diff --git a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Ouroboros/Consensus/Protocol.hs b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Consensus/Protocol.hs similarity index 93% rename from ouroboros-consensus/src/unstable-consensus-testlib/Test/Ouroboros/Consensus/Protocol.hs rename to ouroboros-consensus/src/unstable-consensus-testlib/Test/Consensus/Protocol.hs index 2a8596c131..9817534b90 100644 --- a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Ouroboros/Consensus/Protocol.hs +++ b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Consensus/Protocol.hs @@ -2,7 +2,7 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} -module Test.Ouroboros.Consensus.Protocol (tests_chainOrder) where +module Test.Consensus.Protocol (tests_chainOrder) where import Data.Proxy import Data.Typeable (Typeable, typeRep) diff --git a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/ChainDB.hs b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/ChainDB.hs index 85f644bbf7..4698b04388 100644 --- a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/ChainDB.hs +++ b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/ChainDB.hs @@ -12,6 +12,7 @@ module Test.Util.ChainDB ( ) where +import Control.ResourceRegistry (ResourceRegistry) import Control.Tracer (nullTracer) import Ouroboros.Consensus.Block.Abstract import Ouroboros.Consensus.Config @@ -33,7 +34,6 @@ import Ouroboros.Consensus.Storage.VolatileDB import qualified Ouroboros.Consensus.Storage.VolatileDB as VolatileDB import Ouroboros.Consensus.Util.Args import Ouroboros.Consensus.Util.IOLike hiding (invariant) -import Ouroboros.Consensus.Util.ResourceRegistry (ResourceRegistry) import System.FS.API (SomeHasFS (..)) import qualified System.FS.Sim.MockFS as Mock import System.FS.Sim.MockFS diff --git a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/HardFork/Future.hs b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/HardFork/Future.hs index 3b6aa2d2f5..78f08da6b5 100644 --- a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/HardFork/Future.hs +++ b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/HardFork/Future.hs @@ -7,7 +7,6 @@ module Test.Util.HardFork.Future ( , Future (..) , futureEpochInFirstEra , futureFirstEpochSize - , futureFirstSlotLength , futureSlotLengths , futureSlotToEpoch , futureSlotToTime @@ -51,12 +50,6 @@ data Future = singleEraFuture :: SlotLength -> EpochSize -> Future singleEraFuture = EraFinal --- | 'SlotLength' of the first era -futureFirstSlotLength :: Future -> SlotLength -futureFirstSlotLength future = case future of - EraCons slotLength _epochSize _eraSize _future -> slotLength - EraFinal slotLength _epochSize -> slotLength - -- | 'EpochSize' of the first era futureFirstEpochSize :: Future -> EpochSize futureFirstEpochSize future = case future of diff --git a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/HardFork/OracularClock.hs b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/HardFork/OracularClock.hs index c9c858a786..734f76316c 100644 --- a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/HardFork/OracularClock.hs +++ b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/HardFork/OracularClock.hs @@ -14,6 +14,7 @@ module Test.Util.HardFork.OracularClock ( ) where import Control.Monad (void, when) +import Control.ResourceRegistry import Data.Foldable (toList) import Data.Function (fix) import Data.Time @@ -21,7 +22,6 @@ import GHC.Stack import Ouroboros.Consensus.Block import qualified Ouroboros.Consensus.BlockchainTime as BTime import Ouroboros.Consensus.Util.IOLike -import Ouroboros.Consensus.Util.ResourceRegistry import Ouroboros.Consensus.Util.Time (nominalDelay) import Test.Util.HardFork.Future (Future, futureSlotLengths, futureSlotToTime, futureTimeToSlot) diff --git a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/InvertedMap.hs b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/InvertedMap.hs index fc6faa8e4f..6b9e1d7ddd 100644 --- a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/InvertedMap.hs +++ b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/InvertedMap.hs @@ -5,10 +5,8 @@ module Test.Util.InvertedMap ( , Test.Util.InvertedMap.null -- * Construction , toMap - , unsafeInvertedMap -- * Conversion , fromMap - , unsafeCoercion -- * Filter , spanAntitone -- * Min/Max @@ -19,7 +17,6 @@ import Data.List.NonEmpty (NonEmpty) import qualified Data.List.NonEmpty as NE import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map -import Data.Type.Coercion -- | An inverted 'Map' -- @@ -30,12 +27,6 @@ import Data.Type.Coercion newtype InvertedMap v k = UnsafeInvertedMap {getInvertedMap :: Map v (NonEmpty k)} deriving (Show) -unsafeCoercion :: Coercion (InvertedMap v k) (Map v (NonEmpty k)) -unsafeCoercion = Coercion - -unsafeInvertedMap :: Map v (NonEmpty k) -> InvertedMap v k -unsafeInvertedMap = UnsafeInvertedMap - -- | This inverts the given 'Map' -- fromMap :: Ord v => Map k v -> InvertedMap v k diff --git a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/LogicalClock.hs b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/LogicalClock.hs index ad9d8e44f9..90f19311d7 100644 --- a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/LogicalClock.hs +++ b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/LogicalClock.hs @@ -17,21 +17,19 @@ module Test.Util.LogicalClock ( , new , sufficientTimeFor -- * Scheduling actions - , blockUntilTick - , onTick , tickWatcher -- * Utilities , tickTracer ) where import Control.Monad +import Control.ResourceRegistry import Control.Tracer (Tracer, contramapM) import Data.Time (NominalDiffTime) import Data.Word import GHC.Stack import qualified Ouroboros.Consensus.BlockchainTime as BTime import Ouroboros.Consensus.Util.IOLike -import Ouroboros.Consensus.Util.ResourceRegistry import Ouroboros.Consensus.Util.STM import Ouroboros.Consensus.Util.Time import System.Random (Random) @@ -97,34 +95,6 @@ tickWatcher clock action = , wReader = getCurrentTick clock } --- | Execute action once at the specified tick -onTick :: (IOLike m, HasCallStack) - => ResourceRegistry m - -> LogicalClock m - -> String - -> Tick - -> m () - -> m () -onTick registry clock threadLabel tick action = do - void $ - forkLinkedThread - registry - threadLabel - (waitForTick clock tick >> action) - --- | Block until the specified tick --- --- Returns 'False' if the current tick is later than the requested one, or --- 'True' if they were equal. -blockUntilTick :: MonadSTM m => LogicalClock m -> Tick -> m Bool -blockUntilTick clock tick = atomically $ do - now <- getCurrentTick clock - if now > tick then - return True - else do - when (now < tick) retry - return False - {------------------------------------------------------------------------------- Utilities -------------------------------------------------------------------------------} @@ -176,30 +146,3 @@ newWithDelay registry (NumTicks numTicks) tickLen = do return () } } - --- | Wait for the specified tick (blocking the current thread) -waitForTick :: IOLike m => LogicalClock m -> Tick -> m () -waitForTick clock tick = do - start <- atomically $ getCurrentTick clock - when (start >= tick) $ - throwIO $ WaitForTickTooLate { - tickRequest = tick - , tickCurrent = start - } - - atomically $ do - now <- getCurrentTick clock - check (now >= tick) - --- | Thrown by 'waitForTick' (and hence 'onTick') -data WaitForTickException = - WaitForTickTooLate { - -- | The time the action should have run at - tickRequest :: Tick - - -- | The time when 'onTick' was called - , tickCurrent :: Tick - } - deriving (Eq, Show) - -instance Exception WaitForTickException diff --git a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/Orphans/Arbitrary.hs b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/Orphans/Arbitrary.hs index b16791cff6..2f40638332 100644 --- a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/Orphans/Arbitrary.hs +++ b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/Orphans/Arbitrary.hs @@ -16,13 +16,8 @@ module Test.Util.Orphans.Arbitrary ( SmallDiffTime (..) - , genLimitedEpochSize - , genLimitedSlotNo - , genSmallEpochNo - , genSmallSlotNo -- * Time , genNominalDiffTime50Years - , genUTCTime50Years ) where import Data.Coerce (coerce) @@ -62,7 +57,6 @@ import Ouroboros.Network.SizeInBytes import Test.Cardano.Slotting.Arbitrary () import Test.QuickCheck hiding (Fixed (..)) import Test.QuickCheck.Instances () -import Test.Util.Time (dawnOfTime) minNumCoreNodes :: Word64 minNumCoreNodes = 2 @@ -81,13 +75,6 @@ genNominalDiffTime50Years = conv <$> choose (0, 50 * daysPerYear * secondsPerDay conv :: Double -> NominalDiffTime conv = realToFrac --- | Picks moment between 'dawnOfTime' and (roughly) 50 years later --- --- /Note/ - Arbitrary instance for `UTCTime` comes from @quickcheck-instances@ and it uses --- a much wider timespan. -genUTCTime50Years :: Gen UTCTime -genUTCTime50Years = (`addUTCTime` dawnOfTime) <$> genNominalDiffTime50Years - -- | Length between 0.001 and 20 seconds, millisecond granularity instance Arbitrary SlotLength where arbitrary = slotLengthFromMillisec <$> choose (1, 20 * 1_000) @@ -101,33 +88,6 @@ instance Arbitrary SlotLength where instance Arbitrary RelativeSlot where arbitrary = RelativeSlot <$> arbitrary <*> arbitrary <*> arbitrary --- | The functions 'slotAtTime' and 'timeUntilNextSlot' suffer from arithmetic --- overflow for very large values, so generate values that avoid overflow when --- used in these two functions. The largest value generated is still sufficently --- large to allow for 5e12 years worth of slots at a slot interval of 20 --- seconds. -genLimitedSlotNo :: Gen SlotNo -genLimitedSlotNo = - SlotNo <$> arbitrary `suchThat` (< 0x8000000000000000) - --- | Generate a small SlotNo for the state machine tests. The runtime of the --- StateMachine prop_sequential tests is proportional the the upper bound. -genSmallSlotNo :: Gen SlotNo -genSmallSlotNo = - SlotNo <$> choose (0, 1000) - --- | The tests for 'CumulEpochSizes' requires that the sum of a list of these --- values does not overflow. --- --- An epoch size must be > 0. -genLimitedEpochSize :: Gen EpochSize -genLimitedEpochSize = - EpochSize <$> choose (1, 100_000) - -genSmallEpochNo :: Gen EpochNo -genSmallEpochNo = - EpochNo <$> choose (0, 10000) - -- | This picks an 'EpochNo' between 0 and 10000 -- -- We don't pick larger values because we're not interested in testing overflow diff --git a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/Orphans/NoThunks.hs b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/Orphans/NoThunks.hs index ad7a869381..a832b2b671 100644 --- a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/Orphans/NoThunks.hs +++ b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/Orphans/NoThunks.hs @@ -8,14 +8,14 @@ module Test.Util.Orphans.NoThunks () where import Control.Concurrent.Class.MonadMVar -import Control.Concurrent.Class.MonadSTM.Strict.TVar.Checked +import Control.Concurrent.Class.MonadMVar.NormalForm +import Control.Concurrent.Class.MonadSTM +import Control.Concurrent.Class.MonadSTM.NormalForm import Control.Monad.IOSim import Control.Monad.ST.Lazy import Control.Monad.ST.Unsafe (unsafeSTToIO) import Data.Proxy import NoThunks.Class (NoThunks (..)) -import Ouroboros.Consensus.Util.MonadSTM.NormalForm -import Ouroboros.Consensus.Util.NormalForm.StrictMVar import System.FS.API.Types import System.FS.Sim.FsTree import System.FS.Sim.MockFS diff --git a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/TestBlock.hs b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/TestBlock.hs index c8230ecd3c..fd4fa98414 100644 --- a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/TestBlock.hs +++ b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/TestBlock.hs @@ -473,7 +473,7 @@ instance ( Typeable ptype , NoThunks (CodecConfig (TestBlockWith ptype)) , NoThunks (StorageConfig (TestBlockWith ptype)) ) => BlockSupportsProtocol (TestBlockWith ptype) where - validateView TestBlockConfig{..} = + validateView TestBlockConfig{testBlockNumCoreNodes} = bftValidateView bftFields where NumCoreNodes numCore = testBlockNumCoreNodes diff --git a/ouroboros-consensus/src/unstable-mempool-test-utils/Test/Consensus/Mempool/Mocked.hs b/ouroboros-consensus/src/unstable-mempool-test-utils/Test/Consensus/Mempool/Mocked.hs index 3d9975c06d..74f3558e27 100644 --- a/ouroboros-consensus/src/unstable-mempool-test-utils/Test/Consensus/Mempool/Mocked.hs +++ b/ouroboros-consensus/src/unstable-mempool-test-utils/Test/Consensus/Mempool/Mocked.hs @@ -1,5 +1,4 @@ {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE NamedFieldPuns #-} -- | Mempool with a mocked ledger interface module Test.Consensus.Mempool.Mocked ( @@ -7,15 +6,13 @@ module Test.Consensus.Mempool.Mocked ( -- * Mempool with a mocked LedgerDB interface , MockedMempool (getMempool) , openMockedMempool - , setLedgerState -- * Mempool API functions , addTx , getTxs - , removeTxs ) where import Control.Concurrent.Class.MonadSTM.Strict (StrictTVar, - atomically, newTVarIO, readTVar, writeTVar) + atomically, newTVarIO, readTVar) import Control.DeepSeq (NFData (rnf)) import Control.Tracer (Tracer) import Ouroboros.Consensus.HeaderValidation as Header @@ -78,13 +75,6 @@ openMockedMempool capacityOverride tracer txSizeImpl initialParams = do , getMempool = mempool } -setLedgerState :: - MockedMempool IO blk - -> LedgerState blk - -> IO () -setLedgerState MockedMempool {getLedgerStateTVar} newSt = - atomically $ writeTVar getLedgerStateTVar newSt - addTx :: MockedMempool m blk -> AddTxOnBehalfOf @@ -92,12 +82,6 @@ addTx :: -> m (MempoolAddTxResult blk) addTx = Mempool.addTx . getMempool -removeTxs :: - MockedMempool m blk - -> [Ledger.GenTxId blk] - -> m () -removeTxs = Mempool.removeTxs . getMempool - getTxs :: (Ledger.LedgerSupportsMempool blk) => MockedMempool IO blk -> IO [Ledger.GenTx blk] diff --git a/ouroboros-consensus/src/unstable-mock-block/Ouroboros/Consensus/Mock/Ledger/Block.hs b/ouroboros-consensus/src/unstable-mock-block/Ouroboros/Consensus/Mock/Ledger/Block.hs index fa5f49c1a9..a0599ee35c 100644 --- a/ouroboros-consensus/src/unstable-mock-block/Ouroboros/Consensus/Mock/Ledger/Block.hs +++ b/ouroboros-consensus/src/unstable-mock-block/Ouroboros/Consensus/Mock/Ledger/Block.hs @@ -81,7 +81,6 @@ import Ouroboros.Consensus.HardFork.Abstract import qualified Ouroboros.Consensus.HardFork.History as HardFork import Ouroboros.Consensus.HeaderValidation import Ouroboros.Consensus.Ledger.Abstract -import Ouroboros.Consensus.Ledger.CommonProtocolParams import Ouroboros.Consensus.Ledger.Extended import Ouroboros.Consensus.Ledger.Inspect import Ouroboros.Consensus.Ledger.Query @@ -394,11 +393,6 @@ updateSimpleUTxO x slot (TickedSimpleLedgerState (SimpleLedgerState st)) = genesisSimpleLedgerState :: AddrDist -> LedgerState (SimpleBlock c ext) genesisSimpleLedgerState = SimpleLedgerState . genesisMockState --- | Dummy values -instance MockProtocolSpecific c ext => CommonProtocolParams (SimpleBlock c ext) where - maxHeaderSize = const 2000000 - maxTxSize = const 2000000 - instance LedgerSupportsPeerSelection (SimpleBlock c ext) where getPeers = const [] diff --git a/ouroboros-consensus/src/unstable-mock-block/Ouroboros/Consensus/Mock/Ledger/Block/PraosRule.hs b/ouroboros-consensus/src/unstable-mock-block/Ouroboros/Consensus/Mock/Ledger/Block/PraosRule.hs index 5cdfd5532c..2572355c94 100644 --- a/ouroboros-consensus/src/unstable-mock-block/Ouroboros/Consensus/Mock/Ledger/Block/PraosRule.hs +++ b/ouroboros-consensus/src/unstable-mock-block/Ouroboros/Consensus/Mock/Ledger/Block/PraosRule.hs @@ -15,7 +15,6 @@ module Ouroboros.Consensus.Mock.Ledger.Block.PraosRule ( PraosCryptoUnused , SimplePraosRuleBlock , SimplePraosRuleExt (..) - , SimplePraosRuleHeader , forgePraosRuleExt ) where @@ -70,8 +69,8 @@ type instance BlockProtocol (SimplePraosRuleBlock c) = WithLeaderSchedule (Praos PraosCryptoUnused) -- | Sanity check that block and header type synonyms agree -_simplePraosRuleHeader :: SimplePraosRuleBlock c -> SimplePraosRuleHeader c -_simplePraosRuleHeader = simpleHeader +_lemma_simplePraosRuleHeader :: SimplePraosRuleBlock c -> SimplePraosRuleHeader c +_lemma_simplePraosRuleHeader = simpleHeader {------------------------------------------------------------------------------- Customization of the generic infrastructure diff --git a/ouroboros-consensus/src/unstable-mock-block/Ouroboros/Consensus/Mock/Ledger/Stake.hs b/ouroboros-consensus/src/unstable-mock-block/Ouroboros/Consensus/Mock/Ledger/Stake.hs index a08bd6abef..e808f17415 100644 --- a/ouroboros-consensus/src/unstable-mock-block/Ouroboros/Consensus/Mock/Ledger/Stake.hs +++ b/ouroboros-consensus/src/unstable-mock-block/Ouroboros/Consensus/Mock/Ledger/Stake.hs @@ -8,7 +8,6 @@ module Ouroboros.Consensus.Mock.Ledger.Stake ( , AddrDist -- * Stake distribution , StakeDist (..) - , equalStakeDist , genesisStakeDist , relativeStakes , stakeWithDefault @@ -20,7 +19,6 @@ module Ouroboros.Consensus.Mock.Ledger.Stake ( import Codec.Serialise (Serialise) import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map -import Data.Maybe (mapMaybe) import NoThunks.Class (NoThunks) import Ouroboros.Consensus.Mock.Ledger.Address import Ouroboros.Consensus.Mock.Ledger.UTxO @@ -71,24 +69,6 @@ totalStakes addrDist = foldl f Map.empty Just (CoreId nid) -> Map.insertWith (+) (StakeCore nid) stake m _ -> Map.insertWith (+) StakeEverybodyElse stake m --- | Stake distribution where every address has equal state -equalStakeDist :: AddrDist -> StakeDist -equalStakeDist ad = - StakeDist $ - Map.fromList $ - mapMaybe (nodeStake . snd) $ - Map.toList ad - where - nodeStake :: NodeId -> Maybe (CoreNodeId, Rational) - nodeStake (RelayId _) = Nothing - nodeStake (CoreId i) = Just (i, recip (fromIntegral n)) - - n = length $ filter isCore $ Map.elems ad - - isCore :: NodeId -> Bool - isCore CoreId{} = True - isCore RelayId{} = False - -- | Genesis stake distribution genesisStakeDist :: AddrDist -> StakeDist genesisStakeDist addrDist = diff --git a/ouroboros-consensus/src/unstable-mock-block/Ouroboros/Consensus/Mock/Protocol/LeaderSchedule.hs b/ouroboros-consensus/src/unstable-mock-block/Ouroboros/Consensus/Mock/Protocol/LeaderSchedule.hs index 09ecd28877..76b1674e9b 100644 --- a/ouroboros-consensus/src/unstable-mock-block/Ouroboros/Consensus/Mock/Protocol/LeaderSchedule.hs +++ b/ouroboros-consensus/src/unstable-mock-block/Ouroboros/Consensus/Mock/Protocol/LeaderSchedule.hs @@ -1,6 +1,6 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE TypeFamilies #-} module Ouroboros.Consensus.Mock.Protocol.LeaderSchedule ( @@ -47,7 +47,7 @@ instance ConsensusProtocol p => ConsensusProtocol (WithLeaderSchedule p) where protocolSecurityParam = protocolSecurityParam . wlsConfigP - checkIsLeader WLSConfig{..} () slot _ = + checkIsLeader WLSConfig{wlsConfigSchedule, wlsConfigNodeId} () slot _ = case Map.lookup slot $ getLeaderSchedule wlsConfigSchedule of Nothing -> error $ "WithLeaderSchedule: missing slot " ++ show slot Just nids diff --git a/ouroboros-consensus/src/unstable-tutorials/Ouroboros/Consensus/Tutorial/WithEpoch.lhs b/ouroboros-consensus/src/unstable-tutorials/Ouroboros/Consensus/Tutorial/WithEpoch.lhs index bc8345b871..eb59d5436a 100644 --- a/ouroboros-consensus/src/unstable-tutorials/Ouroboros/Consensus/Tutorial/WithEpoch.lhs +++ b/ouroboros-consensus/src/unstable-tutorials/Ouroboros/Consensus/Tutorial/WithEpoch.lhs @@ -213,14 +213,6 @@ itself: > , body > ) -Finally, a convenience function `addBlockHash` allows us to properly set the -hash of a `BlockD` to its computed value: - -> addBlockHash :: BlockD -> BlockD -> addBlockHash b = b { bd_header = header' } -> where -> header' = (bd_header b) { hbd_Hash = computeBlockHash b } - The preceding definitions require that `ChainHash BlockD` be `Hashable` so we derive a suitable instance here: diff --git a/ouroboros-consensus/test/consensus-test/Main.hs b/ouroboros-consensus/test/consensus-test/Main.hs index 3d044cec75..a8fc0ed3a2 100644 --- a/ouroboros-consensus/test/consensus-test/Main.hs +++ b/ouroboros-consensus/test/consensus-test/Main.hs @@ -10,8 +10,6 @@ import qualified Test.Consensus.Mempool.Fairness (tests) import qualified Test.Consensus.MiniProtocol.BlockFetch.Client (tests) import qualified Test.Consensus.MiniProtocol.ChainSync.Client (tests) import qualified Test.Consensus.MiniProtocol.LocalStateQuery.Server (tests) -import qualified Test.Consensus.ResourceRegistry (tests) -import qualified Test.Consensus.Util.MonadSTM.NormalForm (tests) import qualified Test.Consensus.Util.MonadSTM.RAWLock (tests) import qualified Test.Consensus.Util.Versioned (tests) import Test.Tasty @@ -31,9 +29,7 @@ tests = , Test.Consensus.MiniProtocol.LocalStateQuery.Server.tests , Test.Consensus.Mempool.tests , Test.Consensus.Mempool.Fairness.tests - , Test.Consensus.ResourceRegistry.tests , Test.Consensus.Util.MonadSTM.RAWLock.tests - , Test.Consensus.Util.MonadSTM.NormalForm.tests , Test.Consensus.Util.Versioned.tests , testGroup "HardFork" [ testGroup "History" [ diff --git a/ouroboros-consensus/test/consensus-test/Test/Consensus/BlockchainTime/Simple.hs b/ouroboros-consensus/test/consensus-test/Test/Consensus/BlockchainTime/Simple.hs index 9226710b78..4f10c4d1d1 100644 --- a/ouroboros-consensus/test/consensus-test/Test/Consensus/BlockchainTime/Simple.hs +++ b/ouroboros-consensus/test/consensus-test/Test/Consensus/BlockchainTime/Simple.hs @@ -46,6 +46,7 @@ import Control.Monad.Class.MonadTimer.SI import Control.Monad.Except (Except, runExcept, throwError) import Control.Monad.IOSim import Control.Monad.Reader (ReaderT (..), lift) +import Control.ResourceRegistry import Control.Tracer import Data.Fixed import qualified Data.Time.Clock as Time @@ -53,7 +54,6 @@ import NoThunks.Class (AllowThunk (..)) import Ouroboros.Consensus.Block import Ouroboros.Consensus.BlockchainTime import Ouroboros.Consensus.Util.IOLike -import Ouroboros.Consensus.Util.ResourceRegistry import Ouroboros.Consensus.Util.STM (withWatcher) import Ouroboros.Consensus.Util.Time import Test.QuickCheck hiding (Fixed) diff --git a/ouroboros-consensus/test/consensus-test/Test/Consensus/MiniProtocol/BlockFetch/Client.hs b/ouroboros-consensus/test/consensus-test/Test/Consensus/MiniProtocol/BlockFetch/Client.hs index b3aa0efe1e..eff61371f3 100644 --- a/ouroboros-consensus/test/consensus-test/Test/Consensus/MiniProtocol/BlockFetch/Client.hs +++ b/ouroboros-consensus/test/consensus-test/Test/Consensus/MiniProtocol/BlockFetch/Client.hs @@ -26,6 +26,7 @@ import Control.Monad (replicateM) import Control.Monad.Class.MonadTime import Control.Monad.Class.MonadTimer.SI (MonadTimer) import Control.Monad.IOSim (runSimOrThrow) +import Control.ResourceRegistry import Control.Tracer (Tracer (..), nullTracer, traceWith) import Data.Bifunctor (first) import Data.Hashable (Hashable) @@ -45,7 +46,6 @@ import qualified Ouroboros.Consensus.Storage.ChainDB.Impl as ChainDBImpl import qualified Ouroboros.Consensus.Storage.ChainDB.Impl.Args as ChainDB import Ouroboros.Consensus.Util.Condense (Condense (..)) import Ouroboros.Consensus.Util.IOLike -import Ouroboros.Consensus.Util.ResourceRegistry import Ouroboros.Consensus.Util.STM (blockUntilJust, forkLinkedWatcher) import Ouroboros.Network.AnchoredFragment (AnchoredFragment) diff --git a/ouroboros-consensus/test/consensus-test/Test/Consensus/MiniProtocol/ChainSync/Client.hs b/ouroboros-consensus/test/consensus-test/Test/Consensus/MiniProtocol/ChainSync/Client.hs index 868ca695dd..0ab36e4f21 100644 --- a/ouroboros-consensus/test/consensus-test/Test/Consensus/MiniProtocol/ChainSync/Client.hs +++ b/ouroboros-consensus/test/consensus-test/Test/Consensus/MiniProtocol/ChainSync/Client.hs @@ -56,6 +56,7 @@ import Control.Monad.Class.MonadThrow (Handler (..), catches) import Control.Monad.Class.MonadTime (MonadTime, getCurrentTime) import Control.Monad.Class.MonadTimer (MonadTimer) import Control.Monad.IOSim (runSimOrThrow) +import Control.ResourceRegistry import Control.Tracer (contramap, contramapM, nullTracer) import Data.DerivingVia (InstantiatedAt (InstantiatedAt)) import Data.List (intercalate) @@ -100,7 +101,6 @@ import Ouroboros.Consensus.Storage.ChainDB.API import Ouroboros.Consensus.Util (whenJust) import Ouroboros.Consensus.Util.Condense import Ouroboros.Consensus.Util.IOLike -import Ouroboros.Consensus.Util.ResourceRegistry import Ouroboros.Consensus.Util.STM (Fingerprint (..), WithFingerprint (..)) import Ouroboros.Consensus.Util.Time (multipleNominalDelay, diff --git a/ouroboros-consensus/test/consensus-test/Test/Consensus/Util/MonadSTM/RAWLock.hs b/ouroboros-consensus/test/consensus-test/Test/Consensus/Util/MonadSTM/RAWLock.hs index 884515d164..73399a83d0 100644 --- a/ouroboros-consensus/test/consensus-test/Test/Consensus/Util/MonadSTM/RAWLock.hs +++ b/ouroboros-consensus/test/consensus-test/Test/Consensus/Util/MonadSTM/RAWLock.hs @@ -29,11 +29,11 @@ import Control.Exception (throw) import Control.Monad.Except import Control.Monad.IOSim (IOSim, SimEventType (..), SimTrace, runSimTrace, selectTraceEvents, traceResult) +import Control.ResourceRegistry import Data.Time.Clock (picosecondsToDiffTime) import Ouroboros.Consensus.Util.IOLike import Ouroboros.Consensus.Util.MonadSTM.RAWLock (RAWLock) import qualified Ouroboros.Consensus.Util.MonadSTM.RAWLock as RAWLock -import Ouroboros.Consensus.Util.ResourceRegistry import Test.QuickCheck import Test.QuickCheck.Gen.Unsafe (Capture (..), capture) import Test.QuickCheck.Monadic diff --git a/ouroboros-consensus/test/doctest.hs b/ouroboros-consensus/test/doctest.hs index 159947adb3..222b4efbc2 100644 --- a/ouroboros-consensus/test/doctest.hs +++ b/ouroboros-consensus/test/doctest.hs @@ -1,5 +1,7 @@ module Main (main) where +import Image.LaTeX.Render () + main :: IO () main = do putStrLn "This test-suite exists only to add dependencies" diff --git a/ouroboros-consensus/test/infra-test/Main.hs b/ouroboros-consensus/test/infra-test/Main.hs index f49ea526ba..f14a442004 100644 --- a/ouroboros-consensus/test/infra-test/Main.hs +++ b/ouroboros-consensus/test/infra-test/Main.hs @@ -13,8 +13,8 @@ module Main (main) where import qualified Ouroboros.Consensus.Util.Tests (tests) -import qualified Test.Ouroboros.Consensus.ChainGenerator.Tests (tests) -import qualified Test.Ouroboros.Consensus.Util.LeakyBucket.Tests (tests) +import qualified Test.Consensus.ChainGenerator.Tests (tests) +import qualified Test.Consensus.Util.LeakyBucket.Tests (tests) import Test.Tasty (TestTree, testGroup) import qualified Test.Util.ChainUpdates.Tests (tests) import qualified Test.Util.Schedule.Tests (tests) @@ -29,8 +29,8 @@ tests :: TestTree tests = testGroup "test-infra" [ Ouroboros.Consensus.Util.Tests.tests - , Test.Ouroboros.Consensus.ChainGenerator.Tests.tests - , Test.Ouroboros.Consensus.Util.LeakyBucket.Tests.tests + , Test.Consensus.ChainGenerator.Tests.tests + , Test.Consensus.Util.LeakyBucket.Tests.tests , Test.Util.ChainUpdates.Tests.tests , Test.Util.Schedule.Tests.tests , Test.Util.Split.Tests.tests diff --git a/ouroboros-consensus/test/infra-test/Test/Consensus/ChainGenerator/Tests.hs b/ouroboros-consensus/test/infra-test/Test/Consensus/ChainGenerator/Tests.hs new file mode 100644 index 0000000000..97c0cabee5 --- /dev/null +++ b/ouroboros-consensus/test/infra-test/Test/Consensus/ChainGenerator/Tests.hs @@ -0,0 +1,16 @@ +module Test.Consensus.ChainGenerator.Tests (tests) where + +import qualified Test.Consensus.ChainGenerator.Tests.Adversarial as A +import qualified Test.Consensus.ChainGenerator.Tests.BitVector as BV +import qualified Test.Consensus.ChainGenerator.Tests.Counting as C +import qualified Test.Consensus.ChainGenerator.Tests.Honest as H +import qualified Test.Tasty as TT + +----- + +tests :: TT.TestTree +tests = TT.testGroup "ChainGenerator" $ [] + <> A.tests + <> BV.tests + <> C.tests + <> H.tests diff --git a/ouroboros-consensus/test/infra-test/Test/Ouroboros/Consensus/ChainGenerator/Tests/Adversarial.hs b/ouroboros-consensus/test/infra-test/Test/Consensus/ChainGenerator/Tests/Adversarial.hs similarity index 95% rename from ouroboros-consensus/test/infra-test/Test/Ouroboros/Consensus/ChainGenerator/Tests/Adversarial.hs rename to ouroboros-consensus/test/infra-test/Test/Consensus/ChainGenerator/Tests/Adversarial.hs index 9afa1a91d6..21bd12fb45 100644 --- a/ouroboros-consensus/test/infra-test/Test/Ouroboros/Consensus/ChainGenerator/Tests/Adversarial.hs +++ b/ouroboros-consensus/test/infra-test/Test/Consensus/ChainGenerator/Tests/Adversarial.hs @@ -9,7 +9,7 @@ {-# OPTIONS_GHC -Wno-x-partial #-} #endif -module Test.Ouroboros.Consensus.ChainGenerator.Tests.Adversarial ( +module Test.Consensus.ChainGenerator.Tests.Adversarial ( SomeTestAdversarial (..) , TestAdversarial (..) , tests @@ -23,19 +23,18 @@ import Data.IORef (modifyIORef', newIORef, readIORef, writeIORef) import Data.Proxy (Proxy (Proxy)) import qualified System.Random as R import qualified System.Timeout as IO (timeout) -import qualified Test.Ouroboros.Consensus.ChainGenerator.Adversarial as A -import Test.Ouroboros.Consensus.ChainGenerator.Adversarial - (genPrefixBlockCount) -import qualified Test.Ouroboros.Consensus.ChainGenerator.BitVector as BV -import qualified Test.Ouroboros.Consensus.ChainGenerator.Counting as C -import qualified Test.Ouroboros.Consensus.ChainGenerator.Honest as H -import Test.Ouroboros.Consensus.ChainGenerator.Params (Asc, - Delta (Delta), Kcp (Kcp), Len (Len), Scg (Scg), genAsc) -import qualified Test.Ouroboros.Consensus.ChainGenerator.RaceIterator as RI -import qualified Test.Ouroboros.Consensus.ChainGenerator.Slot as S -import Test.Ouroboros.Consensus.ChainGenerator.Slot (E (SlotE)) -import qualified Test.Ouroboros.Consensus.ChainGenerator.Some as Some -import qualified Test.Ouroboros.Consensus.ChainGenerator.Tests.Honest as H +import qualified Test.Consensus.ChainGenerator.Adversarial as A +import Test.Consensus.ChainGenerator.Adversarial (genPrefixBlockCount) +import qualified Test.Consensus.ChainGenerator.BitVector as BV +import qualified Test.Consensus.ChainGenerator.Counting as C +import qualified Test.Consensus.ChainGenerator.Honest as H +import Test.Consensus.ChainGenerator.Params (Asc, Delta (Delta), + Kcp (Kcp), Len (Len), Scg (Scg), genAsc) +import qualified Test.Consensus.ChainGenerator.RaceIterator as RI +import qualified Test.Consensus.ChainGenerator.Slot as S +import Test.Consensus.ChainGenerator.Slot (E (SlotE)) +import qualified Test.Consensus.ChainGenerator.Some as Some +import qualified Test.Consensus.ChainGenerator.Tests.Honest as H import qualified Test.QuickCheck as QC hiding (elements) import Test.QuickCheck.Extras (unsafeMapSuchThatJust) import Test.QuickCheck.Random (QCGen) diff --git a/ouroboros-consensus/test/infra-test/Test/Ouroboros/Consensus/ChainGenerator/Tests/BitVector.hs b/ouroboros-consensus/test/infra-test/Test/Consensus/ChainGenerator/Tests/BitVector.hs similarity index 94% rename from ouroboros-consensus/test/infra-test/Test/Ouroboros/Consensus/ChainGenerator/Tests/BitVector.hs rename to ouroboros-consensus/test/infra-test/Test/Consensus/ChainGenerator/Tests/BitVector.hs index 62b597a52a..17d0b842f5 100644 --- a/ouroboros-consensus/test/infra-test/Test/Ouroboros/Consensus/ChainGenerator/Tests/BitVector.hs +++ b/ouroboros-consensus/test/infra-test/Test/Consensus/ChainGenerator/Tests/BitVector.hs @@ -7,18 +7,18 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} -module Test.Ouroboros.Consensus.ChainGenerator.Tests.BitVector (tests) where +module Test.Consensus.ChainGenerator.Tests.BitVector (tests) where import Data.Monoid (Endo (Endo, appEndo)) import qualified Data.Vector.Unboxed as V import GHC.Generics (Generic) import qualified System.Random.Stateful as R -import qualified Test.Ouroboros.Consensus.ChainGenerator.BitVector as BV -import qualified Test.Ouroboros.Consensus.ChainGenerator.Counting as C -import qualified Test.Ouroboros.Consensus.ChainGenerator.Slot as S -import Test.Ouroboros.Consensus.ChainGenerator.Slot - (E (EmptySlotE, SlotE), POL, PreImage, S) -import qualified Test.Ouroboros.Consensus.ChainGenerator.Some as Some +import qualified Test.Consensus.ChainGenerator.BitVector as BV +import qualified Test.Consensus.ChainGenerator.Counting as C +import qualified Test.Consensus.ChainGenerator.Slot as S +import Test.Consensus.ChainGenerator.Slot (E (EmptySlotE, SlotE), POL, + PreImage, S) +import qualified Test.Consensus.ChainGenerator.Some as Some import qualified Test.QuickCheck as QC import Test.QuickCheck.Random (QCGen) import qualified Test.Tasty as TT diff --git a/ouroboros-consensus/test/infra-test/Test/Ouroboros/Consensus/ChainGenerator/Tests/Counting.hs b/ouroboros-consensus/test/infra-test/Test/Consensus/ChainGenerator/Tests/Counting.hs similarity index 87% rename from ouroboros-consensus/test/infra-test/Test/Ouroboros/Consensus/ChainGenerator/Tests/Counting.hs rename to ouroboros-consensus/test/infra-test/Test/Consensus/ChainGenerator/Tests/Counting.hs index 275a74a8f0..693553d5aa 100644 --- a/ouroboros-consensus/test/infra-test/Test/Ouroboros/Consensus/ChainGenerator/Tests/Counting.hs +++ b/ouroboros-consensus/test/infra-test/Test/Consensus/ChainGenerator/Tests/Counting.hs @@ -1,9 +1,9 @@ {-# LANGUAGE DataKinds #-} -module Test.Ouroboros.Consensus.ChainGenerator.Tests.Counting (tests) where +module Test.Consensus.ChainGenerator.Tests.Counting (tests) where import Data.Proxy (Proxy (Proxy)) -import qualified Test.Ouroboros.Consensus.ChainGenerator.Counting as C +import qualified Test.Consensus.ChainGenerator.Counting as C import qualified Test.QuickCheck as QC import qualified Test.Tasty as TT import qualified Test.Tasty.QuickCheck as TT diff --git a/ouroboros-consensus/test/infra-test/Test/Ouroboros/Consensus/ChainGenerator/Tests/Honest.hs b/ouroboros-consensus/test/infra-test/Test/Consensus/ChainGenerator/Tests/Honest.hs similarity index 95% rename from ouroboros-consensus/test/infra-test/Test/Ouroboros/Consensus/ChainGenerator/Tests/Honest.hs rename to ouroboros-consensus/test/infra-test/Test/Consensus/ChainGenerator/Tests/Honest.hs index e30a172ae2..1773e2d068 100644 --- a/ouroboros-consensus/test/infra-test/Test/Ouroboros/Consensus/ChainGenerator/Tests/Honest.hs +++ b/ouroboros-consensus/test/infra-test/Test/Consensus/ChainGenerator/Tests/Honest.hs @@ -1,7 +1,7 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} -module Test.Ouroboros.Consensus.ChainGenerator.Tests.Honest ( +module Test.Consensus.ChainGenerator.Tests.Honest ( -- * Re-use TestHonest (TestHonest, testAsc, testRecipe, testRecipe') , unlines' @@ -17,10 +17,9 @@ import Data.List (intercalate) import Data.Proxy (Proxy (Proxy)) import qualified System.Random as R import qualified System.Timeout as IO (timeout) -import qualified Test.Ouroboros.Consensus.ChainGenerator.Honest as H -import Test.Ouroboros.Consensus.ChainGenerator.Params (Asc, - Delta (Delta), Kcp (Kcp), Len (Len), Scg (Scg), genAsc, - genKSD) +import qualified Test.Consensus.ChainGenerator.Honest as H +import Test.Consensus.ChainGenerator.Params (Asc, Delta (Delta), + Kcp (Kcp), Len (Len), Scg (Scg), genAsc, genKSD) import qualified Test.QuickCheck as QC import Test.QuickCheck.Extras (sized1, unsafeMapSuchThatJust) import Test.QuickCheck.Random (QCGen) diff --git a/ouroboros-consensus/test/infra-test/Test/Ouroboros/Consensus/Util/LeakyBucket/Tests.hs b/ouroboros-consensus/test/infra-test/Test/Consensus/Util/LeakyBucket/Tests.hs similarity index 99% rename from ouroboros-consensus/test/infra-test/Test/Ouroboros/Consensus/Util/LeakyBucket/Tests.hs rename to ouroboros-consensus/test/infra-test/Test/Consensus/Util/LeakyBucket/Tests.hs index 97107aaccd..06dc1f1b08 100644 --- a/ouroboros-consensus/test/infra-test/Test/Ouroboros/Consensus/Util/LeakyBucket/Tests.hs +++ b/ouroboros-consensus/test/infra-test/Test/Consensus/Util/LeakyBucket/Tests.hs @@ -8,7 +8,7 @@ -- “play”, are simple, manual tests; two concern (non-)propagation of exceptions -- between the bucket thread and the action's thread; the last one compares a -- run of the actual bucket implementation against a model. -module Test.Ouroboros.Consensus.Util.LeakyBucket.Tests (tests) where +module Test.Consensus.Util.LeakyBucket.Tests (tests) where import Control.Monad (foldM, void) import Control.Monad.Class.MonadTimer (MonadTimer) diff --git a/ouroboros-consensus/test/infra-test/Test/Ouroboros/Consensus/ChainGenerator/Tests.hs b/ouroboros-consensus/test/infra-test/Test/Ouroboros/Consensus/ChainGenerator/Tests.hs deleted file mode 100644 index af8638ca3c..0000000000 --- a/ouroboros-consensus/test/infra-test/Test/Ouroboros/Consensus/ChainGenerator/Tests.hs +++ /dev/null @@ -1,16 +0,0 @@ -module Test.Ouroboros.Consensus.ChainGenerator.Tests (tests) where - -import qualified Test.Ouroboros.Consensus.ChainGenerator.Tests.Adversarial as A -import qualified Test.Ouroboros.Consensus.ChainGenerator.Tests.BitVector as BV -import qualified Test.Ouroboros.Consensus.ChainGenerator.Tests.Counting as C -import qualified Test.Ouroboros.Consensus.ChainGenerator.Tests.Honest as H -import qualified Test.Tasty as TT - ------ - -tests :: TT.TestTree -tests = TT.testGroup "ChainGenerator" $ [] - <> A.tests - <> BV.tests - <> C.tests - <> H.tests diff --git a/ouroboros-consensus/test/storage-test/Main.hs b/ouroboros-consensus/test/storage-test/Main.hs index 6b3986e1b6..d23a5d24c0 100644 --- a/ouroboros-consensus/test/storage-test/Main.hs +++ b/ouroboros-consensus/test/storage-test/Main.hs @@ -1,6 +1,6 @@ module Main (main) where -import qualified Test.Ouroboros.Storage +import qualified Test.Consensus.Storage import Test.Tasty import Test.Util.TestEnv @@ -9,5 +9,5 @@ main = defaultMainWithTestEnv defaultTestEnvConfig tests tests :: TestTree tests = testGroup "ouroboros-storage" [ - Test.Ouroboros.Storage.tests + Test.Consensus.Storage.tests ] diff --git a/ouroboros-consensus/test/storage-test/Test/Consensus/Storage.hs b/ouroboros-consensus/test/storage-test/Test/Consensus/Storage.hs new file mode 100644 index 0000000000..aa583da20f --- /dev/null +++ b/ouroboros-consensus/test/storage-test/Test/Consensus/Storage.hs @@ -0,0 +1,21 @@ +{-# LANGUAGE CPP #-} + +module Test.Consensus.Storage (tests) where + +import qualified Test.Consensus.Storage.ChainDB as ChainDB +import qualified Test.Consensus.Storage.ImmutableDB as ImmutableDB +import qualified Test.Consensus.Storage.LedgerDB as LedgerDB +import qualified Test.Consensus.Storage.VolatileDB as VolatileDB +import Test.Tasty (TestTree, testGroup) + +-- +-- The list of all tests +-- + +tests :: TestTree +tests = testGroup "Storage" + [ ImmutableDB.tests + , VolatileDB.tests + , LedgerDB.tests + , ChainDB.tests + ] diff --git a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB.hs b/ouroboros-consensus/test/storage-test/Test/Consensus/Storage/ChainDB.hs similarity index 77% rename from ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB.hs rename to ouroboros-consensus/test/storage-test/Test/Consensus/Storage/ChainDB.hs index a9a63f8e88..862f9b7372 100644 --- a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB.hs +++ b/ouroboros-consensus/test/storage-test/Test/Consensus/Storage/ChainDB.hs @@ -20,16 +20,16 @@ -- think it should. -- * The main DB itself. -- -module Test.Ouroboros.Storage.ChainDB (tests) where +module Test.Consensus.Storage.ChainDB (tests) where import System.Info (os) -import qualified Test.Ouroboros.Storage.ChainDB.FollowerPromptness as FollowerPromptness -import qualified Test.Ouroboros.Storage.ChainDB.GcSchedule as GcSchedule -import qualified Test.Ouroboros.Storage.ChainDB.Iterator as Iterator -import qualified Test.Ouroboros.Storage.ChainDB.Model.Test as Model -import qualified Test.Ouroboros.Storage.ChainDB.Paths as Paths -import qualified Test.Ouroboros.Storage.ChainDB.StateMachine as StateMachine -import qualified Test.Ouroboros.Storage.ChainDB.Unit as Unit +import qualified Test.Consensus.Storage.ChainDB.FollowerPromptness as FollowerPromptness +import qualified Test.Consensus.Storage.ChainDB.GcSchedule as GcSchedule +import qualified Test.Consensus.Storage.ChainDB.Iterator as Iterator +import qualified Test.Consensus.Storage.ChainDB.Model.Test as Model +import qualified Test.Consensus.Storage.ChainDB.Paths as Paths +import qualified Test.Consensus.Storage.ChainDB.StateMachine as StateMachine +import qualified Test.Consensus.Storage.ChainDB.Unit as Unit import Test.Tasty tests :: TestTree diff --git a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/FollowerPromptness.hs b/ouroboros-consensus/test/storage-test/Test/Consensus/Storage/ChainDB/FollowerPromptness.hs similarity index 98% rename from ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/FollowerPromptness.hs rename to ouroboros-consensus/test/storage-test/Test/Consensus/Storage/ChainDB/FollowerPromptness.hs index 15559363dc..b616eea62d 100644 --- a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/FollowerPromptness.hs +++ b/ouroboros-consensus/test/storage-test/Test/Consensus/Storage/ChainDB/FollowerPromptness.hs @@ -17,10 +17,11 @@ -- various events. In particular, we can really rely on something occuring at a -- specific point in time, compared to just a plausible range as would be -- necessary with ordinary wall-clock time. -module Test.Ouroboros.Storage.ChainDB.FollowerPromptness (tests) where +module Test.Consensus.Storage.ChainDB.FollowerPromptness (tests) where import Control.Monad (forever) import Control.Monad.IOSim (runSimOrThrow) +import Control.ResourceRegistry import Control.Tracer (Tracer (..), contramapM, traceWith) import Data.Foldable (for_) import Data.Map.Strict (Map) @@ -38,7 +39,6 @@ import qualified Ouroboros.Consensus.Storage.ChainDB.Impl.Args as ChainDB import Ouroboros.Consensus.Util.Condense (Condense (..)) import Ouroboros.Consensus.Util.Enclose import Ouroboros.Consensus.Util.IOLike -import Ouroboros.Consensus.Util.ResourceRegistry import qualified Ouroboros.Network.Mock.Chain as Chain import Test.QuickCheck import Test.Tasty diff --git a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/GcSchedule.hs b/ouroboros-consensus/test/storage-test/Test/Consensus/Storage/ChainDB/GcSchedule.hs similarity index 97% rename from ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/GcSchedule.hs rename to ouroboros-consensus/test/storage-test/Test/Consensus/Storage/ChainDB/GcSchedule.hs index 8fc5bb983c..d8a70429da 100644 --- a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/GcSchedule.hs +++ b/ouroboros-consensus/test/storage-test/Test/Consensus/Storage/ChainDB/GcSchedule.hs @@ -16,10 +16,7 @@ -- We then test that the real implementation behaves exactly as the model -- predicts. -- -module Test.Ouroboros.Storage.ChainDB.GcSchedule ( - example - , tests - ) where +module Test.Consensus.Storage.ChainDB.GcSchedule (tests) where import Control.Monad (forM) import Control.Monad.IOSim (runSimOrThrow) @@ -318,14 +315,6 @@ computeTrace gcParams blocks = -- scanl f z [x1, x2, ...] == [z, z `f` x1, (z `f` x1) `f` x2, ...] (drop 1 (scanl (flip (step gcParams)) emptyGcState blocks)) -summarise :: GcParams -> Int -> Trace GcStateSummary -summarise gcParams numBlocks = - map (uncurry computeGcStateSummary) $ - computeTrace gcParams (genBlocks numBlocks) - -example :: GcParams -> Trace GcStateSummary -example gcParams = summarise gcParams 1000 - -- | Process the remaining scheduled garbage collections in the queue. The -- already performed garbage collections ('gcGarbageCollections') are included -- in the final 'GcGarbageCollections'. diff --git a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/Iterator.hs b/ouroboros-consensus/test/storage-test/Test/Consensus/Storage/ChainDB/Iterator.hs similarity index 97% rename from ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/Iterator.hs rename to ouroboros-consensus/test/storage-test/Test/Consensus/Storage/ChainDB/Iterator.hs index 2e6df1dde8..010464b122 100644 --- a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/Iterator.hs +++ b/ouroboros-consensus/test/storage-test/Test/Consensus/Storage/ChainDB/Iterator.hs @@ -8,14 +8,15 @@ -- -- This is a set of unit tests that check for specific bugs discovered during -- other testing. The more important tests for the iterators is the main model --- based test of the chain DB (@Test.Ouroboros.Storage.ChainDB.Model.Test@). +-- based test of the chain DB (@Test.Consensus.Storage.ChainDB.Model.Test@). -- -module Test.Ouroboros.Storage.ChainDB.Iterator (tests) where +module Test.Consensus.Storage.ChainDB.Iterator (tests) where import Control.Monad (forM_) import Control.Monad.Except (ExceptT (..), runExceptT) import Control.Monad.IOSim (runSimOrThrow) import Control.Monad.Trans.Class (lift) +import Control.ResourceRegistry import Control.Tracer import Data.List (intercalate) import qualified Data.Map.Strict as Map @@ -33,13 +34,12 @@ import Ouroboros.Consensus.Storage.VolatileDB (VolatileDB) import qualified Ouroboros.Consensus.Storage.VolatileDB as VolatileDB import Ouroboros.Consensus.Util.Condense (condense) import Ouroboros.Consensus.Util.IOLike -import Ouroboros.Consensus.Util.ResourceRegistry import Ouroboros.Network.Mock.Chain (Chain) import qualified Ouroboros.Network.Mock.Chain as Chain -import qualified Test.Ouroboros.Storage.ImmutableDB.Mock as ImmutableDB +import qualified Test.Consensus.Storage.ImmutableDB.Mock as ImmutableDB (openDBMock) -import Test.Ouroboros.Storage.TestBlock -import qualified Test.Ouroboros.Storage.VolatileDB.Mock as VolatileDB +import Test.Consensus.Storage.TestBlock +import qualified Test.Consensus.Storage.VolatileDB.Mock as VolatileDB (openDBMock) import Test.Tasty import Test.Tasty.QuickCheck diff --git a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/Model.hs b/ouroboros-consensus/test/storage-test/Test/Consensus/Storage/ChainDB/Model.hs similarity index 96% rename from ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/Model.hs rename to ouroboros-consensus/test/storage-test/Test/Consensus/Storage/ChainDB/Model.hs index b9fac6414f..19ff0ddeeb 100644 --- a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/Model.hs +++ b/ouroboros-consensus/test/storage-test/Test/Consensus/Storage/ChainDB/Model.hs @@ -14,14 +14,13 @@ -- | Model implementation of the chain DB -- -- Intended for qualified import -module Test.Ouroboros.Storage.ChainDB.Model ( +module Test.Consensus.Storage.ChainDB.Model ( Model -- opaque , CPS.FollowerId , IteratorId -- * Construction , addBlock - , addBlockPromise , addBlocks , empty -- * Queries @@ -35,15 +34,12 @@ module Test.Ouroboros.Storage.ChainDB.Model ( , getIsValid , getLedgerDB , getMaxSlotNo - , hasBlock - , hasBlockByPoint , immutableBlockNo , immutableChain , immutableSlotNo , invalid , isOpen , isValid - , lastK , maxClockSkew , tipBlock , tipPoint @@ -86,7 +82,7 @@ import Data.Function (on) import Data.List (isInfixOf, isPrefixOf, sortBy) import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map -import Data.Maybe (fromMaybe, isJust) +import Data.Maybe (fromMaybe) import Data.Proxy import Data.Set (Set) import qualified Data.Set as Set @@ -101,8 +97,7 @@ import Ouroboros.Consensus.Ledger.Extended import Ouroboros.Consensus.Ledger.SupportsProtocol import Ouroboros.Consensus.Protocol.Abstract import Ouroboros.Consensus.Protocol.MockChainSel -import Ouroboros.Consensus.Storage.ChainDB.API (AddBlockPromise (..), - AddBlockResult (..), BlockComponent (..), +import Ouroboros.Consensus.Storage.ChainDB.API (BlockComponent (..), ChainDbError (..), InvalidBlockReason (..), IteratorResult (..), StreamFrom (..), StreamTo (..), UnknownRange (..), validBounds) @@ -110,7 +105,6 @@ import Ouroboros.Consensus.Storage.ChainDB.Impl.ChainSel (olderThanK) import Ouroboros.Consensus.Storage.LedgerDB import Ouroboros.Consensus.Util (repeatedly) import qualified Ouroboros.Consensus.Util.AnchoredFragment as Fragment -import Ouroboros.Consensus.Util.IOLike (MonadSTM) import Ouroboros.Network.AnchoredFragment (AnchoredFragment) import qualified Ouroboros.Network.AnchoredFragment as Fragment import Ouroboros.Network.Block (MaxSlotNo (..)) @@ -184,9 +178,6 @@ currentChain = CPS.producerChain . cps getBlock :: HasHeader blk => HeaderHash blk -> Model blk -> Maybe blk getBlock hash m = Map.lookup hash (blocks m) -hasBlock :: HasHeader blk => HeaderHash blk -> Model blk -> Bool -hasBlock hash = isJust . getBlock hash - getBlockByPoint :: HasHeader blk => RealPoint blk -> Model blk -> Maybe blk @@ -200,12 +191,6 @@ getBlockComponentByPoint :: getBlockComponentByPoint blockComponent pt m = Right $ (`getBlockComponent` blockComponent) <$> getBlockByPoint pt m -hasBlockByPoint :: HasHeader blk - => Point blk -> Model blk -> Bool -hasBlockByPoint pt = case pointHash pt of - GenesisHash -> const False - BlockHash hash -> hasBlock hash - tipBlock :: Model blk -> Maybe blk tipBlock = Chain.head . currentChain @@ -215,17 +200,6 @@ tipPoint = maybe GenesisPoint blockPoint . tipBlock getMaxSlotNo :: HasHeader blk => Model blk -> MaxSlotNo getMaxSlotNo = foldMap (MaxSlotNo . blockSlot) . blocks -lastK :: HasHeader a - => SecurityParam - -> (blk -> a) -- ^ Provided since `AnchoredFragment` is not a functor - -> Model blk - -> AnchoredFragment a -lastK (SecurityParam k) f = - Fragment.anchorNewest k - . Chain.toAnchoredFragment - . fmap f - . currentChain - -- | Actual number of blocks that can be rolled back. Equal to @k@, except -- when: -- @@ -474,23 +448,6 @@ addBlocks :: LedgerSupportsProtocol blk -> Model blk -> Model blk addBlocks cfg = repeatedly (addBlock cfg) --- | Wrapper around 'addBlock' that returns an 'AddBlockPromise'. -addBlockPromise :: - forall m blk. (LedgerSupportsProtocol blk, MonadSTM m) - => TopLevelConfig blk - -> blk - -> Model blk - -> (AddBlockPromise m blk, Model blk) -addBlockPromise cfg blk m = (result, m') - where - m' = addBlock cfg blk m - blockWritten = Map.notMember (blockHash blk) (blocks m) - && Map.member (blockHash blk) (blocks m') - result = AddBlockPromise - { blockWrittenToDisk = return blockWritten - , blockProcessed = return $ SuccesfullyAddedBlock $ tipPoint m' - } - {------------------------------------------------------------------------------- Iterators -------------------------------------------------------------------------------} diff --git a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/Model/Test.hs b/ouroboros-consensus/test/storage-test/Test/Consensus/Storage/ChainDB/Model/Test.hs similarity index 95% rename from ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/Model/Test.hs rename to ouroboros-consensus/test/storage-test/Test/Consensus/Storage/ChainDB/Model/Test.hs index 132008609b..969a0e4396 100644 --- a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/Model/Test.hs +++ b/ouroboros-consensus/test/storage-test/Test/Consensus/Storage/ChainDB/Model/Test.hs @@ -8,7 +8,7 @@ -- | Tests of properties of the chain DB model -- --- The model for the chain DB (@Test.Ouroboros.Storage.ChainDB.Model@) contains +-- The model for the chain DB (@Test.Consensus.Storage.ChainDB.Model@) contains -- a quite a bit of info, but that is primarily because it needs to support -- stateful APIs such as followers (that follow the tip of the chain) and -- iterators (which stream a chunk of the chain). The main part of the model is @@ -22,7 +22,7 @@ -- in particular, we verify that no matter in which order we add blocks to the -- chain DB, we always pick the most preferred chain. -- -module Test.Ouroboros.Storage.ChainDB.Model.Test (tests) where +module Test.Consensus.Storage.ChainDB.Model.Test (tests) where import GHC.Stack import Ouroboros.Consensus.Block @@ -32,8 +32,8 @@ import Ouroboros.Consensus.Storage.ChainDB.API (StreamFrom (..), import qualified Ouroboros.Consensus.Util.AnchoredFragment as AF import qualified Ouroboros.Network.AnchoredFragment as AF import qualified Ouroboros.Network.Mock.Chain as Chain -import qualified Test.Ouroboros.Storage.ChainDB.Model as M -import Test.Ouroboros.Storage.ChainDB.Model (ModelSupportsBlock) +import qualified Test.Consensus.Storage.ChainDB.Model as M +import Test.Consensus.Storage.ChainDB.Model (ModelSupportsBlock) import Test.QuickCheck import Test.Tasty import Test.Tasty.QuickCheck diff --git a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/Paths.hs b/ouroboros-consensus/test/storage-test/Test/Consensus/Storage/ChainDB/Paths.hs similarity index 99% rename from ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/Paths.hs rename to ouroboros-consensus/test/storage-test/Test/Consensus/Storage/ChainDB/Paths.hs index 1b8c048c04..3f9010c65e 100644 --- a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/Paths.hs +++ b/ouroboros-consensus/test/storage-test/Test/Consensus/Storage/ChainDB/Paths.hs @@ -6,7 +6,7 @@ {-# LANGUAGE TupleSections #-} {-# LANGUAGE UndecidableInstances #-} -module Test.Ouroboros.Storage.ChainDB.Paths (tests) where +module Test.Consensus.Storage.ChainDB.Paths (tests) where import Data.List.NonEmpty (NonEmpty) import qualified Data.List.NonEmpty as NE @@ -19,7 +19,7 @@ import Ouroboros.Consensus.Storage.ChainDB.Impl.Paths (isReachable) import qualified Ouroboros.Consensus.Storage.VolatileDB as VolatileDB import Ouroboros.Network.AnchoredFragment (AnchoredFragment) import qualified Ouroboros.Network.AnchoredFragment as AF -import Test.Ouroboros.Storage.TestBlock +import Test.Consensus.Storage.TestBlock import Test.Tasty import Test.Tasty.QuickCheck import Test.Util.Orphans.Arbitrary () diff --git a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/StateMachine.hs b/ouroboros-consensus/test/storage-test/Test/Consensus/Storage/ChainDB/StateMachine.hs similarity index 99% rename from ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/StateMachine.hs rename to ouroboros-consensus/test/storage-test/Test/Consensus/Storage/ChainDB/StateMachine.hs index bd395bb824..81c4e9f360 100644 --- a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/StateMachine.hs +++ b/ouroboros-consensus/test/storage-test/Test/Consensus/Storage/ChainDB/StateMachine.hs @@ -44,7 +44,7 @@ -- the wallclock to a @SlotNo@, although we /can/ always translate the @SlotNo@ -- at the tip of the chain to a @UTCTime@. -- -module Test.Ouroboros.Storage.ChainDB.StateMachine ( +module Test.Consensus.Storage.ChainDB.StateMachine ( -- * Commands At (..) , Cmd (..) @@ -81,6 +81,7 @@ module Test.Ouroboros.Storage.ChainDB.StateMachine ( import Codec.Serialise (Serialise) import Control.Monad (replicateM, void) +import Control.ResourceRegistry import Control.Tracer as CT import Data.Bifoldable import Data.Bifunctor @@ -129,19 +130,18 @@ import Ouroboros.Consensus.Util.CallStack import Ouroboros.Consensus.Util.Condense (condense) import Ouroboros.Consensus.Util.Enclose import Ouroboros.Consensus.Util.IOLike hiding (invariant) -import Ouroboros.Consensus.Util.ResourceRegistry import Ouroboros.Network.AnchoredFragment (AnchoredFragment) import qualified Ouroboros.Network.AnchoredFragment as AF import Ouroboros.Network.Block (ChainUpdate, MaxSlotNo) import qualified Ouroboros.Network.Mock.Chain as Chain import qualified System.FS.Sim.MockFS as Mock import System.FS.Sim.MockFS (MockFS) -import qualified Test.Ouroboros.Storage.ChainDB.Model as Model -import Test.Ouroboros.Storage.ChainDB.Model (FollowerId, IteratorId, +import qualified Test.Consensus.Storage.ChainDB.Model as Model +import Test.Consensus.Storage.ChainDB.Model (FollowerId, IteratorId, ModelSupportsBlock, ShouldGarbageCollect (DoNotGarbageCollect, GarbageCollect)) -import Test.Ouroboros.Storage.Orphans () -import Test.Ouroboros.Storage.TestBlock +import Test.Consensus.Storage.Orphans () +import Test.Consensus.Storage.TestBlock import Test.QuickCheck hiding (elements, forAll) import qualified Test.QuickCheck.Monadic as QC import Test.StateMachine diff --git a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/StateMachine/Utils/RunOnRepl.hs b/ouroboros-consensus/test/storage-test/Test/Consensus/Storage/ChainDB/StateMachine/Utils/RunOnRepl.hs similarity index 92% rename from ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/StateMachine/Utils/RunOnRepl.hs rename to ouroboros-consensus/test/storage-test/Test/Consensus/Storage/ChainDB/StateMachine/Utils/RunOnRepl.hs index 87f6c9829a..92a7db5acb 100644 --- a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/StateMachine/Utils/RunOnRepl.hs +++ b/ouroboros-consensus/test/storage-test/Test/Consensus/Storage/ChainDB/StateMachine/Utils/RunOnRepl.hs @@ -16,7 +16,7 @@ -- 'FlexibleContexts' and 'TypeFamilies' extensions, and set multi-line input. -- -- > cabal new-repl test-storage --- > import Test.Ouroboros.Storage.ChainDB.StateMachine.Utils.RunOnRepl +-- > import Test.Consensus.Storage.ChainDB.StateMachine.Utils.RunOnRepl -- > :set -XFlexibleContexts -XTypeFamilies +m -- -- The commands that are part of the counterexample are usually several lines @@ -34,7 +34,7 @@ -- -- Where 'someClockSkew' and 'someChunkInfo' are the ones given by the -- counterexample found by quickcheck-statemachine. -module Test.Ouroboros.Storage.ChainDB.StateMachine.Utils.RunOnRepl ( +module Test.Consensus.Storage.ChainDB.StateMachine.Utils.RunOnRepl ( -- * Running the counterexamples quickCheckCmdsLockStep -- * Patterns needed to disambiguate the 'At' and 'Command' symbols printed @@ -86,12 +86,12 @@ import Ouroboros.Network.Block (ChainUpdate (RollBack)) import qualified Ouroboros.Network.Block as Block import Ouroboros.Network.Point (Block (..)) import qualified Ouroboros.Network.Point as Point -import qualified Test.Ouroboros.Storage.ChainDB.StateMachine as StateMachine -import Test.Ouroboros.Storage.ChainDB.StateMachine (Cmd (..), +import qualified Test.Consensus.Storage.ChainDB.StateMachine as StateMachine +import Test.Consensus.Storage.ChainDB.StateMachine (Cmd (..), FollowerRef, IterRef, MaxClockSkew (MaxClockSkew), Resp (..), Success (..), runCmdsLockstep) -import Test.Ouroboros.Storage.Orphans () -import Test.Ouroboros.Storage.TestBlock (ChainLength (ChainLength), +import Test.Consensus.Storage.Orphans () +import Test.Consensus.Storage.TestBlock (ChainLength (ChainLength), EBB (EBB, RegularBlock), TestBlock (..), TestBody (..), TestBodyHash (..), TestHeader (..), TestHeaderHash (..)) import Test.QuickCheck (quickCheck) diff --git a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/Unit.hs b/ouroboros-consensus/test/storage-test/Test/Consensus/Storage/ChainDB/Unit.hs similarity index 97% rename from ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/Unit.hs rename to ouroboros-consensus/test/storage-test/Test/Consensus/Storage/ChainDB/Unit.hs index a0922ef467..c2b15a89d7 100644 --- a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/Unit.hs +++ b/ouroboros-consensus/test/storage-test/Test/Consensus/Storage/ChainDB/Unit.hs @@ -11,7 +11,7 @@ {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} -module Test.Ouroboros.Storage.ChainDB.Unit (tests) where +module Test.Consensus.Storage.ChainDB.Unit (tests) where import Cardano.Slotting.Slot (WithOrigin (..)) @@ -22,6 +22,7 @@ import Control.Monad.Reader (MonadReader, ReaderT, ask, runReaderT) import Control.Monad.State (MonadState, StateT, evalStateT, get, modify, put) import Control.Monad.Trans.Class (lift) +import Control.ResourceRegistry (closeRegistry, unsafeNewRegistry) import Data.Maybe (isJust) import Ouroboros.Consensus.Block.Abstract (blockSlot) import Ouroboros.Consensus.Block.RealPoint @@ -40,18 +41,16 @@ import Ouroboros.Consensus.Storage.Common (StreamFrom (..), StreamTo (..)) import Ouroboros.Consensus.Storage.ImmutableDB.Chunks as ImmutableDB import Ouroboros.Consensus.Util.IOLike -import Ouroboros.Consensus.Util.ResourceRegistry (closeRegistry, - unsafeNewRegistry) import Ouroboros.Network.Block (ChainUpdate (..), Point, blockPoint) import qualified Ouroboros.Network.Mock.Chain as Mock -import qualified Test.Ouroboros.Storage.ChainDB.Model as Model -import Test.Ouroboros.Storage.ChainDB.Model (Model) -import qualified Test.Ouroboros.Storage.ChainDB.StateMachine as SM -import Test.Ouroboros.Storage.ChainDB.StateMachine (AllComponents, +import qualified Test.Consensus.Storage.ChainDB.Model as Model +import Test.Consensus.Storage.ChainDB.Model (Model) +import qualified Test.Consensus.Storage.ChainDB.StateMachine as SM +import Test.Consensus.Storage.ChainDB.StateMachine (AllComponents, ChainDBEnv (..), ChainDBState (..), ShouldGarbageCollect (..), TestConstraints, allComponents, close, mkTestCfg, open) -import Test.Ouroboros.Storage.TestBlock +import Test.Consensus.Storage.TestBlock import Test.Tasty (TestTree, testGroup) import Test.Tasty.HUnit (Assertion, assertFailure, testCase) import Test.Util.ChainDB (MinimalChainDbArgs (..), emptyNodeDBs, diff --git a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ImmutableDB.hs b/ouroboros-consensus/test/storage-test/Test/Consensus/Storage/ImmutableDB.hs similarity index 86% rename from ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ImmutableDB.hs rename to ouroboros-consensus/test/storage-test/Test/Consensus/Storage/ImmutableDB.hs index 94e16a35b0..66b08381b3 100644 --- a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ImmutableDB.hs +++ b/ouroboros-consensus/test/storage-test/Test/Consensus/Storage/ImmutableDB.hs @@ -14,10 +14,10 @@ -- property tests of the primary index, and then the main event, model based -- checking. -- -module Test.Ouroboros.Storage.ImmutableDB (tests) where +module Test.Consensus.Storage.ImmutableDB (tests) where -import qualified Test.Ouroboros.Storage.ImmutableDB.Primary as Primary -import qualified Test.Ouroboros.Storage.ImmutableDB.StateMachine as StateMachine +import qualified Test.Consensus.Storage.ImmutableDB.Primary as Primary +import qualified Test.Consensus.Storage.ImmutableDB.StateMachine as StateMachine import Test.Tasty (TestTree, testGroup) {------------------------------------------------------------------------------ diff --git a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ImmutableDB/Mock.hs b/ouroboros-consensus/test/storage-test/Test/Consensus/Storage/ImmutableDB/Mock.hs similarity index 95% rename from ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ImmutableDB/Mock.hs rename to ouroboros-consensus/test/storage-test/Test/Consensus/Storage/ImmutableDB/Mock.hs index e3d597c3ce..e44c77defb 100644 --- a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ImmutableDB/Mock.hs +++ b/ouroboros-consensus/test/storage-test/Test/Consensus/Storage/ImmutableDB/Mock.hs @@ -1,7 +1,7 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ScopedTypeVariables #-} -module Test.Ouroboros.Storage.ImmutableDB.Mock (openDBMock) where +module Test.Consensus.Storage.ImmutableDB.Mock (openDBMock) where import Data.Bifunctor (first) import Ouroboros.Consensus.Block @@ -11,7 +11,7 @@ import Ouroboros.Consensus.Storage.ImmutableDB.Chunks import Ouroboros.Consensus.Storage.Serialisation import Ouroboros.Consensus.Util ((...:), (.:)) import Ouroboros.Consensus.Util.IOLike -import Test.Ouroboros.Storage.ImmutableDB.Model +import Test.Consensus.Storage.ImmutableDB.Model openDBMock :: forall m blk. diff --git a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ImmutableDB/Model.hs b/ouroboros-consensus/test/storage-test/Test/Consensus/Storage/ImmutableDB/Model.hs similarity index 99% rename from ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ImmutableDB/Model.hs rename to ouroboros-consensus/test/storage-test/Test/Consensus/Storage/ImmutableDB/Model.hs index 5797f1935c..e7a1f6615b 100644 --- a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ImmutableDB/Model.hs +++ b/ouroboros-consensus/test/storage-test/Test/Consensus/Storage/ImmutableDB/Model.hs @@ -9,7 +9,7 @@ {-# LANGUAGE UndecidableInstances #-} -- | Model for the 'ImmutableDB'. -module Test.Ouroboros.Storage.ImmutableDB.Model ( +module Test.Consensus.Storage.ImmutableDB.Model ( DBModel (..) , InSlot (..) , IteratorId @@ -59,7 +59,7 @@ import Ouroboros.Consensus.Storage.Serialisation import Ouroboros.Consensus.Util (lastMaybe, takeUntil) import Ouroboros.Consensus.Util.CallStack import System.FS.API.Types (FsPath, fsPathSplit) -import Test.Ouroboros.Storage.TestBlock hiding (EBB) +import Test.Consensus.Storage.TestBlock hiding (EBB) import Test.Util.Orphans.ToExpr () data InSlot blk = diff --git a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ImmutableDB/Primary.hs b/ouroboros-consensus/test/storage-test/Test/Consensus/Storage/ImmutableDB/Primary.hs similarity index 98% rename from ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ImmutableDB/Primary.hs rename to ouroboros-consensus/test/storage-test/Test/Consensus/Storage/ImmutableDB/Primary.hs index a12cb2f200..6e7ca3c9a7 100644 --- a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ImmutableDB/Primary.hs +++ b/ouroboros-consensus/test/storage-test/Test/Consensus/Storage/ImmutableDB/Primary.hs @@ -25,7 +25,7 @@ -- These property tests are QuickCheck based, which means they generate random -- indices, random slot numbers, etc., and come with a proper shrinker. -- -module Test.Ouroboros.Storage.ImmutableDB.Primary (tests) where +module Test.Consensus.Storage.ImmutableDB.Primary (tests) where import Data.Functor ((<&>)) import Data.Maybe (fromJust) @@ -48,7 +48,7 @@ import System.FS.API hiding (allowExisting) import qualified System.FS.Sim.MockFS as Mock import System.FS.Sim.MockFS (HandleMock) import qualified System.FS.Sim.STM as Sim -import Test.Ouroboros.Storage.TestBlock (TestBlock) +import Test.Consensus.Storage.TestBlock (TestBlock) import Test.QuickCheck import Test.QuickCheck.Monadic (monadicIO, run) import Test.Tasty (TestTree, testGroup) diff --git a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ImmutableDB/StateMachine.hs b/ouroboros-consensus/test/storage-test/Test/Consensus/Storage/ImmutableDB/StateMachine.hs similarity index 96% rename from ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ImmutableDB/StateMachine.hs rename to ouroboros-consensus/test/storage-test/Test/Consensus/Storage/ImmutableDB/StateMachine.hs index 01a317e524..51e04ad537 100644 --- a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ImmutableDB/StateMachine.hs +++ b/ouroboros-consensus/test/storage-test/Test/Consensus/Storage/ImmutableDB/StateMachine.hs @@ -35,17 +35,15 @@ -- course needs to be able /detect/ the corruption, minimize quite how far we -- truncate, etc. -- --- The model (defined in 'Test.Ouroboros.Storage.ImmutableDB.Model') is +-- The model (defined in 'Test.Consensus.Storage.ImmutableDB.Model') is -- essentially just a mapping from slots to blocks. It needs to maintain a /bit/ -- more state than that, in order to deal with stateful API components such as -- database cursors, but that's basically it. -- -module Test.Ouroboros.Storage.ImmutableDB.StateMachine ( - showLabelledExamples - , tests - ) where +module Test.Consensus.Storage.ImmutableDB.StateMachine (tests) where import Control.Monad (forM_, void) +import Control.ResourceRegistry import Data.Bifunctor (first) import Data.ByteString.Lazy (ByteString) import Data.Coerce (Coercible, coerce) @@ -75,22 +73,18 @@ import qualified Ouroboros.Consensus.Storage.ImmutableDB.Impl.Index as Index (CacheConfig (..)) import Ouroboros.Consensus.Storage.ImmutableDB.Impl.Util import Ouroboros.Consensus.Util.IOLike -import Ouroboros.Consensus.Util.ResourceRegistry import Prelude hiding (elem, notElem) import System.FS.API (HasFS (..), SomeHasFS (..)) import System.FS.API.Types (FsPath, mkFsPath) import System.FS.Sim.Error (Errors, emptyErrors, mkSimErrorHasFS, withErrors) import qualified System.FS.Sim.MockFS as Mock -import System.Random (getStdRandom, randomR) -import Test.Ouroboros.Storage.ImmutableDB.Model -import Test.Ouroboros.Storage.Orphans () -import Test.Ouroboros.Storage.TestBlock +import Test.Consensus.Storage.ImmutableDB.Model +import Test.Consensus.Storage.Orphans () +import Test.Consensus.Storage.TestBlock import Test.QuickCheck hiding (forAll) import qualified Test.QuickCheck.Monadic as QC -import Test.QuickCheck.Random (mkQCGen) -import Test.StateMachine hiding (showLabelledExamples, - showLabelledExamples') +import Test.StateMachine import qualified Test.StateMachine.Labelling as C import qualified Test.StateMachine.Sequential as QSM import qualified Test.StateMachine.Types as QSM @@ -100,14 +94,12 @@ import Test.Tasty.QuickCheck (testProperty) import Test.Util.ChunkInfo import Test.Util.Orphans.Arbitrary () import Test.Util.Orphans.ToExpr () -import Test.Util.QuickCheck (collects) import qualified Test.Util.RefEnv as RE import Test.Util.RefEnv (RefEnv) import Test.Util.SOP import Test.Util.ToExpr () import Test.Util.Tracer (recordingTracerIORef) import Test.Util.WithEq -import Text.Show.Pretty (ppShow) {------------------------------------------------------------------------------- Abstract model @@ -1134,35 +1126,6 @@ instance ToExpr (Model m Concrete) Top-level tests -------------------------------------------------------------------------------} --- | Show minimal examples for each of the generated tags -showLabelledExamples' - :: Maybe Int - -- ^ Seed - -> Int - -- ^ Number of tests to run to find examples - -> (Tag -> Bool) - -- ^ Tag filter (can be @const True@) - -> ChunkInfo - -> IO () -showLabelledExamples' mbReplay numTests focus chunkInfo = do - replaySeed <- case mbReplay of - Nothing -> getStdRandom (randomR (1,999999)) - Just seed -> return seed - - labelledExamplesWith (stdArgs { replay = Just (mkQCGen replaySeed, 0) - , maxSuccess = numTests - }) $ - forAllShrinkShow (QSM.generateCommands smUnused Nothing) - (QSM.shrinkCommands smUnused) - ppShow $ \cmds -> - collects (filter focus . tag . execCmds (QSM.initModel smUnused) $ cmds) $ - property True - where - smUnused = sm unusedEnv $ initDBModel chunkInfo TestBlockCodecConfig - -showLabelledExamples :: ChunkInfo -> IO () -showLabelledExamples = showLabelledExamples' Nothing 1000 (const True) - prop_sequential :: Index.CacheConfig -> SmallChunkInfo -> Property prop_sequential cacheConfig (SmallChunkInfo chunkInfo) = forAllCommands smUnused Nothing $ \cmds -> QC.monadicIO $ do diff --git a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/LedgerDB.hs b/ouroboros-consensus/test/storage-test/Test/Consensus/Storage/LedgerDB.hs similarity index 63% rename from ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/LedgerDB.hs rename to ouroboros-consensus/test/storage-test/Test/Consensus/Storage/LedgerDB.hs index 9336e09cd7..18788515ec 100644 --- a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/LedgerDB.hs +++ b/ouroboros-consensus/test/storage-test/Test/Consensus/Storage/LedgerDB.hs @@ -4,11 +4,11 @@ -- pure Haskell (no IO anywhere) and so can be tested using normal property -- tests, and the on-disk component, which is tested with a model based test. -- -module Test.Ouroboros.Storage.LedgerDB (tests) where +module Test.Consensus.Storage.LedgerDB (tests) where -import qualified Test.Ouroboros.Storage.LedgerDB.DiskPolicy as DiskPolicy -import qualified Test.Ouroboros.Storage.LedgerDB.InMemory as InMemory -import qualified Test.Ouroboros.Storage.LedgerDB.OnDisk as OnDisk +import qualified Test.Consensus.Storage.LedgerDB.DiskPolicy as DiskPolicy +import qualified Test.Consensus.Storage.LedgerDB.InMemory as InMemory +import qualified Test.Consensus.Storage.LedgerDB.OnDisk as OnDisk import Test.Tasty tests :: TestTree diff --git a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/LedgerDB/DiskPolicy.hs b/ouroboros-consensus/test/storage-test/Test/Consensus/Storage/LedgerDB/DiskPolicy.hs similarity index 99% rename from ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/LedgerDB/DiskPolicy.hs rename to ouroboros-consensus/test/storage-test/Test/Consensus/Storage/LedgerDB/DiskPolicy.hs index daa8d591f0..3212a3b9aa 100644 --- a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/LedgerDB/DiskPolicy.hs +++ b/ouroboros-consensus/test/storage-test/Test/Consensus/Storage/LedgerDB/DiskPolicy.hs @@ -3,7 +3,7 @@ {-# LANGUAGE NumericUnderscores #-} {-# LANGUAGE TypeApplications #-} -module Test.Ouroboros.Storage.LedgerDB.DiskPolicy (tests) where +module Test.Consensus.Storage.LedgerDB.DiskPolicy (tests) where import Data.Time.Clock (DiffTime, diffTimeToPicoseconds, picosecondsToDiffTime, secondsToDiffTime) diff --git a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/LedgerDB/InMemory.hs b/ouroboros-consensus/test/storage-test/Test/Consensus/Storage/LedgerDB/InMemory.hs similarity index 99% rename from ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/LedgerDB/InMemory.hs rename to ouroboros-consensus/test/storage-test/Test/Consensus/Storage/LedgerDB/InMemory.hs index 3194eb9323..faccdbd4d2 100644 --- a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/LedgerDB/InMemory.hs +++ b/ouroboros-consensus/test/storage-test/Test/Consensus/Storage/LedgerDB/InMemory.hs @@ -25,7 +25,7 @@ -- * The maximum rollback supported is always @k@ (unless we are near genesis) -- * etc. -- -module Test.Ouroboros.Storage.LedgerDB.InMemory (tests) where +module Test.Consensus.Storage.LedgerDB.InMemory (tests) where import Codec.CBOR.FlatTerm (FlatTerm, TermToken (..), fromFlatTerm, toFlatTerm) @@ -39,7 +39,7 @@ import qualified Ouroboros.Consensus.HardFork.History as HardFork import Ouroboros.Consensus.Ledger.Abstract import Ouroboros.Consensus.Storage.LedgerDB import Ouroboros.Consensus.Util -import Test.Ouroboros.Storage.LedgerDB.OrphanArbitrary () +import Test.Consensus.Storage.LedgerDB.OrphanArbitrary () import Test.QuickCheck import Test.Tasty import Test.Tasty.HUnit diff --git a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/LedgerDB/OnDisk.hs b/ouroboros-consensus/test/storage-test/Test/Consensus/Storage/LedgerDB/OnDisk.hs similarity index 96% rename from ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/LedgerDB/OnDisk.hs rename to ouroboros-consensus/test/storage-test/Test/Consensus/Storage/LedgerDB/OnDisk.hs index 709f4de7f5..d7011d85f7 100644 --- a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/LedgerDB/OnDisk.hs +++ b/ouroboros-consensus/test/storage-test/Test/Consensus/Storage/LedgerDB/OnDisk.hs @@ -36,10 +36,7 @@ -- The model here is satisfyingly simple: just a map from blocks to their -- corresponding ledger state. -- -module Test.Ouroboros.Storage.LedgerDB.OnDisk ( - showLabelledExamples - , tests - ) where +module Test.Consensus.Storage.LedgerDB.OnDisk (tests) where import Codec.Serialise (Serialise) import qualified Codec.Serialise as S @@ -71,14 +68,12 @@ import Prelude hiding (elem) import System.FS.API import qualified System.FS.Sim.MockFS as MockFS import System.FS.Sim.STM -import System.Random (getStdRandom, randomR) -import Test.Ouroboros.Storage.LedgerDB.InMemory () -import Test.Ouroboros.Storage.LedgerDB.OrphanArbitrary () +import Test.Consensus.Storage.LedgerDB.InMemory () +import Test.Consensus.Storage.LedgerDB.OrphanArbitrary () import qualified Test.QuickCheck as QC import Test.QuickCheck (Gen) import qualified Test.QuickCheck.Monadic as QC -import qualified Test.QuickCheck.Random as QC -import Test.StateMachine hiding (showLabelledExamples) +import Test.StateMachine import qualified Test.StateMachine.Labelling as C import qualified Test.StateMachine.Types as QSM import qualified Test.StateMachine.Types.Rank2 as Rank2 @@ -1166,31 +1161,3 @@ tagEvents k = C.classify [ case eventCmd ev of At Restore | mockRecentSnap mock == mST -> Just (mockChainLength mock) _otherwise -> Nothing - -{------------------------------------------------------------------------------- - Inspecting the labelling function --------------------------------------------------------------------------------} - -showLabelledExamples :: SecurityParam - -> Maybe Int - -> (Tag -> Bool) -- ^ Which tag are we interested in? - -> IO () -showLabelledExamples secParam mReplay relevant = do - replaySeed <- case mReplay of - Nothing -> getStdRandom $ randomR (1, 999999) - Just seed -> return seed - - putStrLn $ "Using replaySeed " ++ show replaySeed - - let args = QC.stdArgs { - QC.maxSuccess = 10000 - , QC.replay = Just (QC.mkQCGen replaySeed, 0) - } - - QC.labelledExamplesWith args $ - forAllCommands (sm secParam dbUnused) Nothing $ \cmds -> - repeatedly QC.collect (run cmds) $ - QC.property True - where - run :: QSM.Commands (At Cmd) (At Resp) -> [Tag] - run = filter relevant . tagEvents secParam . execCmds secParam diff --git a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/LedgerDB/OrphanArbitrary.hs b/ouroboros-consensus/test/storage-test/Test/Consensus/Storage/LedgerDB/OrphanArbitrary.hs similarity index 88% rename from ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/LedgerDB/OrphanArbitrary.hs rename to ouroboros-consensus/test/storage-test/Test/Consensus/Storage/LedgerDB/OrphanArbitrary.hs index a515ab81db..18307a0f1f 100644 --- a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/LedgerDB/OrphanArbitrary.hs +++ b/ouroboros-consensus/test/storage-test/Test/Consensus/Storage/LedgerDB/OrphanArbitrary.hs @@ -1,6 +1,6 @@ {-# OPTIONS_GHC -Wno-orphans #-} -module Test.Ouroboros.Storage.LedgerDB.OrphanArbitrary () where +module Test.Consensus.Storage.LedgerDB.OrphanArbitrary () where import Ouroboros.Consensus.Config.SecurityParam (SecurityParam (..)) import Test.QuickCheck diff --git a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/Orphans.hs b/ouroboros-consensus/test/storage-test/Test/Consensus/Storage/Orphans.hs similarity index 98% rename from ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/Orphans.hs rename to ouroboros-consensus/test/storage-test/Test/Consensus/Storage/Orphans.hs index 381bf0071a..352ba8c91f 100644 --- a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/Orphans.hs +++ b/ouroboros-consensus/test/storage-test/Test/Consensus/Storage/Orphans.hs @@ -2,7 +2,7 @@ {-# OPTIONS_GHC -Wno-orphans #-} -module Test.Ouroboros.Storage.Orphans () where +module Test.Consensus.Storage.Orphans () where import Data.Maybe (isJust) import Ouroboros.Consensus.Block diff --git a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/TestBlock.hs b/ouroboros-consensus/test/storage-test/Test/Consensus/Storage/TestBlock.hs similarity index 97% rename from ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/TestBlock.hs rename to ouroboros-consensus/test/storage-test/Test/Consensus/Storage/TestBlock.hs index cde467d73b..a9577861d1 100644 --- a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/TestBlock.hs +++ b/ouroboros-consensus/test/storage-test/Test/Consensus/Storage/TestBlock.hs @@ -16,7 +16,7 @@ {-# OPTIONS_GHC -Wno-orphans #-} -module Test.Ouroboros.Storage.TestBlock ( +module Test.Consensus.Storage.TestBlock ( -- * Test block BlockConfig (..) , ChainLength (..) @@ -42,8 +42,6 @@ module Test.Ouroboros.Storage.TestBlock ( , testBlockIsEBB , testBlockIsValid -- ** Serialisation - , testBlockFromLazyByteString - , testBlockToBuilder , testBlockToLazyByteString -- * Ledger , TestBlockError (..) @@ -60,7 +58,6 @@ module Test.Ouroboros.Storage.TestBlock ( ) where import Cardano.Crypto.DSIGN -import qualified Codec.CBOR.Read as CBOR import qualified Codec.CBOR.Write as CBOR import Codec.Serialise (Serialise (decode, encode), serialise) import Control.Monad (forM, when) @@ -68,7 +65,6 @@ import Control.Monad.Class.MonadThrow import Control.Monad.Except (throwError) import Data.Binary (Binary) import qualified Data.Binary as Binary -import Data.ByteString.Builder (Builder) import qualified Data.ByteString.Lazy as Lazy import Data.Functor (($>)) import Data.Hashable @@ -113,7 +109,7 @@ import qualified Ouroboros.Network.Mock.Chain as Chain import System.FS.API.Lazy import Test.Cardano.Slotting.Numeric () import Test.Cardano.Slotting.TreeDiff () -import Test.Ouroboros.Storage.ChainDB.Model +import Test.Consensus.Storage.ChainDB.Model import Test.QuickCheck import Test.Util.Orphans.Arbitrary () import Test.Util.Orphans.SignableRepresentation () @@ -268,9 +264,6 @@ testBlockIsValid (TestBlock hdr body) = thHash hdr == hashHeader hdr && thBodyHash hdr == hashBody body -testBlockToBuilder :: TestBlock -> Builder -testBlockToBuilder = CBOR.toBuilder . encode - testBlockHeaderOffset :: Word16 testBlockHeaderOffset = 2 -- For the 'encodeListLen' @@ -280,15 +273,6 @@ testBlockHeaderSize = fromIntegral . Lazy.length . serialise . testHeader testBlockToLazyByteString :: TestBlock -> Lazy.ByteString testBlockToLazyByteString = CBOR.toLazyByteString . encode -testBlockFromLazyByteString :: HasCallStack => Lazy.ByteString -> TestBlock -testBlockFromLazyByteString bs = case CBOR.deserialiseFromBytes decode bs of - Left e -> error $ show e - Right (bs', a) - | Lazy.null bs' - -> a - | otherwise - -> error $ "left-over bytes: " <> show bs' - {------------------------------------------------------------------------------- Real chain length -------------------------------------------------------------------------------} @@ -559,7 +543,7 @@ instance IsLedger (LedgerState TestBlock) where applyChainTickLedgerResult _ _ = pureLedgerResult . TickedTestLedger instance ApplyBlock (LedgerState TestBlock) TestBlock where - applyBlockLedgerResult _ tb@TestBlock{..} (TickedTestLedger TestLedger{..}) + applyBlockLedgerResult _ tb@TestBlock{..} (TickedTestLedger TestLedger{lastAppliedHash}) | blockPrevHash tb /= lastAppliedHash = throwError $ InvalidHash lastAppliedHash (blockPrevHash tb) | not $ tbIsValid testBody diff --git a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/VolatileDB.hs b/ouroboros-consensus/test/storage-test/Test/Consensus/Storage/VolatileDB.hs similarity index 55% rename from ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/VolatileDB.hs rename to ouroboros-consensus/test/storage-test/Test/Consensus/Storage/VolatileDB.hs index c4b73159f0..7f0989ef36 100644 --- a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/VolatileDB.hs +++ b/ouroboros-consensus/test/storage-test/Test/Consensus/Storage/VolatileDB.hs @@ -1,6 +1,6 @@ -module Test.Ouroboros.Storage.VolatileDB (tests) where +module Test.Consensus.Storage.VolatileDB (tests) where -import qualified Test.Ouroboros.Storage.VolatileDB.StateMachine as StateMachine +import qualified Test.Consensus.Storage.VolatileDB.StateMachine as StateMachine import Test.Tasty (TestTree, testGroup) diff --git a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/VolatileDB/Mock.hs b/ouroboros-consensus/test/storage-test/Test/Consensus/Storage/VolatileDB/Mock.hs similarity index 94% rename from ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/VolatileDB/Mock.hs rename to ouroboros-consensus/test/storage-test/Test/Consensus/Storage/VolatileDB/Mock.hs index eeae311d11..1da74cced5 100644 --- a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/VolatileDB/Mock.hs +++ b/ouroboros-consensus/test/storage-test/Test/Consensus/Storage/VolatileDB/Mock.hs @@ -2,7 +2,7 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE ScopedTypeVariables #-} -module Test.Ouroboros.Storage.VolatileDB.Mock (openDBMock) where +module Test.Consensus.Storage.VolatileDB.Mock (openDBMock) where import Ouroboros.Consensus.Block import Ouroboros.Consensus.Storage.Serialisation (EncodeDisk (..), @@ -11,7 +11,7 @@ import Ouroboros.Consensus.Storage.VolatileDB hiding (VolatileDbArgs (..)) import Ouroboros.Consensus.Util ((.:)) import Ouroboros.Consensus.Util.IOLike -import Test.Ouroboros.Storage.VolatileDB.Model +import Test.Consensus.Storage.VolatileDB.Model openDBMock :: forall m blk. diff --git a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/VolatileDB/Model.hs b/ouroboros-consensus/test/storage-test/Test/Consensus/Storage/VolatileDB/Model.hs similarity index 96% rename from ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/VolatileDB/Model.hs rename to ouroboros-consensus/test/storage-test/Test/Consensus/Storage/VolatileDB/Model.hs index cf774dd4bb..879605454e 100644 --- a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/VolatileDB/Model.hs +++ b/ouroboros-consensus/test/storage-test/Test/Consensus/Storage/VolatileDB/Model.hs @@ -9,7 +9,7 @@ {-# LANGUAGE UndecidableInstances #-} -- | In-memory model implementation of 'VolatileDB' -module Test.Ouroboros.Storage.VolatileDB.Model ( +module Test.Consensus.Storage.VolatileDB.Model ( DBModel (..) , initDBModel -- * Basic API @@ -19,14 +19,12 @@ module Test.Ouroboros.Storage.VolatileDB.Model ( , getBlockComponentModel , getBlockInfoModel , getMaxSlotNoModel - , isOpenModel , putBlockModel , reOpenModel -- * Corruptions , runCorruptionsModel -- * Exported for testing purposes , BlocksInFile (..) - , blockHashes , blockIndex , getCurrentFile , getDBFileIds @@ -57,7 +55,7 @@ import Ouroboros.Consensus.Storage.VolatileDB.Impl.Util (filePath, parseFd) import Ouroboros.Network.Block (MaxSlotNo (..)) import System.FS.API.Types (FsPath) -import Test.Ouroboros.Storage.TestBlock (Corruptions, +import Test.Consensus.Storage.TestBlock (Corruptions, FileCorruption (..)) data DBModel blk = DBModel { @@ -94,9 +92,6 @@ initDBModel blocksPerFile codecConfig = DBModel { blockIndex :: HasHeader blk => DBModel blk -> Map (HeaderHash blk) blk blockIndex = foldMap fileToBlockIndex . fileIndex -blockHashes :: HasHeader blk => DBModel blk -> [HeaderHash blk] -blockHashes = concatMap fileHashes . fileIndex - getBlockToPredecessor :: GetPrevHash blk => DBModel blk @@ -187,9 +182,6 @@ fileToBlockIndex = Map.fromList . map addKey . getBlocksInFile where addKey blk = (blockHash blk, blk) -fileHashes :: HasHeader blk => BlocksInFile blk -> [HeaderHash blk] -fileHashes = map blockHash . getBlocksInFile - fileBlockToPredecessor :: GetPrevHash blk => BlocksInFile blk @@ -243,9 +235,6 @@ blockSize ccfg = closeModel :: DBModel blk -> DBModel blk closeModel dbm = dbm { open = False } -isOpenModel :: DBModel blk -> Bool -isOpenModel = open - reOpenModel :: DBModel blk -> DBModel blk reOpenModel dbm | open dbm diff --git a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/VolatileDB/StateMachine.hs b/ouroboros-consensus/test/storage-test/Test/Consensus/Storage/VolatileDB/StateMachine.hs similarity index 94% rename from ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/VolatileDB/StateMachine.hs rename to ouroboros-consensus/test/storage-test/Test/Consensus/Storage/VolatileDB/StateMachine.hs index 9c437cda0b..467ed21646 100644 --- a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/VolatileDB/StateMachine.hs +++ b/ouroboros-consensus/test/storage-test/Test/Consensus/Storage/VolatileDB/StateMachine.hs @@ -21,18 +21,16 @@ -- -- in addition to a few commands that are supported only by the volatile DB, -- such as "find all blocks with the given predecessor" (used by chain selection). --- The model (defined in @Test.Ouroboros.Storage.VolatileDB.Model@) is a list +-- The model (defined in @Test.Consensus.Storage.VolatileDB.Model@) is a list -- of "files", where every file is modelled simply as a list of blocks and some -- block metadata. The reason that this is slightly more detailed than one might -- hope (just a set of blocks) is that we need the additional detail to be able -- to predict the effects of disk corruption. -- -module Test.Ouroboros.Storage.VolatileDB.StateMachine ( - showLabelledExamples - , tests - ) where +module Test.Consensus.Storage.VolatileDB.StateMachine (tests) where import Control.Monad (forM_, void) +import Control.ResourceRegistry import Data.Bifunctor (first) import Data.ByteString.Lazy (ByteString) import Data.Functor.Classes @@ -54,21 +52,17 @@ import Ouroboros.Consensus.Storage.VolatileDB import Ouroboros.Consensus.Storage.VolatileDB.Impl.Types (FileId) import Ouroboros.Consensus.Storage.VolatileDB.Impl.Util import Ouroboros.Consensus.Util.IOLike -import Ouroboros.Consensus.Util.ResourceRegistry import Ouroboros.Network.Block (MaxSlotNo) import Prelude hiding (elem) import System.FS.API.Lazy import System.FS.Sim.Error import qualified System.FS.Sim.MockFS as Mock -import System.Random (getStdRandom, randomR) -import Test.Ouroboros.Storage.Orphans () -import Test.Ouroboros.Storage.TestBlock -import Test.Ouroboros.Storage.VolatileDB.Model +import Test.Consensus.Storage.Orphans () +import Test.Consensus.Storage.TestBlock +import Test.Consensus.Storage.VolatileDB.Model import Test.QuickCheck hiding (elements, forAll) import Test.QuickCheck.Monadic -import Test.QuickCheck.Random (mkQCGen) -import Test.StateMachine hiding (showLabelledExamples, - showLabelledExamples') +import Test.StateMachine import qualified Test.StateMachine.Labelling as C import qualified Test.StateMachine.Sequential as QSM import Test.StateMachine.Types @@ -81,8 +75,6 @@ import Test.Util.QuickCheck import Test.Util.SOP import Test.Util.ToExpr () import Test.Util.Tracer (recordingTracerIORef) -import Text.Show.Pretty (ppShow) - type Block = TestBlock @@ -814,28 +806,3 @@ execCmds model (Commands cs) = go model cs go :: Model Symbolic -> [Command (At CmdErr) (At Resp)] -> [Event Symbolic] go _ [] = [] go m (c : css) = let ev = execCmd m c in ev : go (eventAfter ev) css - -showLabelledExamples :: IO () -showLabelledExamples = showLabelledExamples' Nothing 1000 - -showLabelledExamples' :: Maybe Int - -- ^ Seed - -> Int - -- ^ Number of tests to run to find examples - -> IO () -showLabelledExamples' mReplay numTests = do - replaySeed <- case mReplay of - Nothing -> getStdRandom (randomR (1,999999)) - Just seed -> return seed - - labelledExamplesWith (stdArgs { replay = Just (mkQCGen replaySeed, 0) - , maxSuccess = numTests - }) $ - forAllShrinkShow (QSM.generateCommands smUnused Nothing) - (QSM.shrinkCommands smUnused) - ppShow $ \cmds -> - collects (tag . execCmds (initModel smUnused) $ cmds) $ - property True - where - dbm = initDBModel testMaxBlocksPerFile TestBlockCodecConfig - smUnused = sm unusedEnv dbm diff --git a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage.hs b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage.hs deleted file mode 100644 index 8a0f3d2eb1..0000000000 --- a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage.hs +++ /dev/null @@ -1,21 +0,0 @@ -{-# LANGUAGE CPP #-} - -module Test.Ouroboros.Storage (tests) where - -import qualified Test.Ouroboros.Storage.ChainDB as ChainDB -import qualified Test.Ouroboros.Storage.ImmutableDB as ImmutableDB -import qualified Test.Ouroboros.Storage.LedgerDB as LedgerDB -import qualified Test.Ouroboros.Storage.VolatileDB as VolatileDB -import Test.Tasty (TestTree, testGroup) - --- --- The list of all tests --- - -tests :: TestTree -tests = testGroup "Storage" - [ ImmutableDB.tests - , VolatileDB.tests - , LedgerDB.tests - , ChainDB.tests - ] diff --git a/resource-registry/CHANGELOG.md b/resource-registry/CHANGELOG.md new file mode 100644 index 0000000000..4c459ea231 --- /dev/null +++ b/resource-registry/CHANGELOG.md @@ -0,0 +1,8 @@ +# resource-registry Changelog + +# Changelog entries + + +## 0.1.0.0 — 2024-06-21 + +- First release, extracted from `ouroboros-consensus`. diff --git a/resource-registry/LICENSE b/resource-registry/LICENSE new file mode 100644 index 0000000000..d645695673 --- /dev/null +++ b/resource-registry/LICENSE @@ -0,0 +1,202 @@ + + Apache License + Version 2.0, January 2004 + http://www.apache.org/licenses/ + + TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION + + 1. Definitions. + + "License" shall mean the terms and conditions for use, reproduction, + and distribution as defined by Sections 1 through 9 of this document. + + "Licensor" shall mean the copyright owner or entity authorized by + the copyright owner that is granting the License. + + "Legal Entity" shall mean the union of the acting entity and all + other entities that control, are controlled by, or are under common + control with that entity. For the purposes of this definition, + "control" means (i) the power, direct or indirect, to cause the + direction or management of such entity, whether by contract or + otherwise, or (ii) ownership of fifty percent (50%) or more of the + outstanding shares, or (iii) beneficial ownership of such entity. + + "You" (or "Your") shall mean an individual or Legal Entity + exercising permissions granted by this License. + + "Source" form shall mean the preferred form for making modifications, + including but not limited to software source code, documentation + source, and configuration files. + + "Object" form shall mean any form resulting from mechanical + transformation or translation of a Source form, including but + not limited to compiled object code, generated documentation, + and conversions to other media types. + + "Work" shall mean the work of authorship, whether in Source or + Object form, made available under the License, as indicated by a + copyright notice that is included in or attached to the work + (an example is provided in the Appendix below). + + "Derivative Works" shall mean any work, whether in Source or Object + form, that is based on (or derived from) the Work and for which the + editorial revisions, annotations, elaborations, or other modifications + represent, as a whole, an original work of authorship. For the purposes + of this License, Derivative Works shall not include works that remain + separable from, or merely link (or bind by name) to the interfaces of, + the Work and Derivative Works thereof. + + "Contribution" shall mean any work of authorship, including + the original version of the Work and any modifications or additions + to that Work or Derivative Works thereof, that is intentionally + submitted to Licensor for inclusion in the Work by the copyright owner + or by an individual or Legal Entity authorized to submit on behalf of + the copyright owner. For the purposes of this definition, "submitted" + means any form of electronic, verbal, or written communication sent + to the Licensor or its representatives, including but not limited to + communication on electronic mailing lists, source code control systems, + and issue tracking systems that are managed by, or on behalf of, the + Licensor for the purpose of discussing and improving the Work, but + excluding communication that is conspicuously marked or otherwise + designated in writing by the copyright owner as "Not a Contribution." + + "Contributor" shall mean Licensor and any individual or Legal Entity + on behalf of whom a Contribution has been received by Licensor and + subsequently incorporated within the Work. + + 2. Grant of Copyright License. Subject to the terms and conditions of + this License, each Contributor hereby grants to You a perpetual, + worldwide, non-exclusive, no-charge, royalty-free, irrevocable + copyright license to reproduce, prepare Derivative Works of, + publicly display, publicly perform, sublicense, and distribute the + Work and such Derivative Works in Source or Object form. + + 3. Grant of Patent License. Subject to the terms and conditions of + this License, each Contributor hereby grants to You a perpetual, + worldwide, non-exclusive, no-charge, royalty-free, irrevocable + (except as stated in this section) patent license to make, have made, + use, offer to sell, sell, import, and otherwise transfer the Work, + where such license applies only to those patent claims licensable + by such Contributor that are necessarily infringed by their + Contribution(s) alone or by combination of their Contribution(s) + with the Work to which such Contribution(s) was submitted. If You + institute patent litigation against any entity (including a + cross-claim or counterclaim in a lawsuit) alleging that the Work + or a Contribution incorporated within the Work constitutes direct + or contributory patent infringement, then any patent licenses + granted to You under this License for that Work shall terminate + as of the date such litigation is filed. + + 4. Redistribution. You may reproduce and distribute copies of the + Work or Derivative Works thereof in any medium, with or without + modifications, and in Source or Object form, provided that You + meet the following conditions: + + (a) You must give any other recipients of the Work or + Derivative Works a copy of this License; and + + (b) You must cause any modified files to carry prominent notices + stating that You changed the files; and + + (c) You must retain, in the Source form of any Derivative Works + that You distribute, all copyright, patent, trademark, and + attribution notices from the Source form of the Work, + excluding those notices that do not pertain to any part of + the Derivative Works; and + + (d) If the Work includes a "NOTICE" text file as part of its + distribution, then any Derivative Works that You distribute must + include a readable copy of the attribution notices contained + within such NOTICE file, excluding those notices that do not + pertain to any part of the Derivative Works, in at least one + of the following places: within a NOTICE text file distributed + as part of the Derivative Works; within the Source form or + documentation, if provided along with the Derivative Works; or, + within a display generated by the Derivative Works, if and + wherever such third-party notices normally appear. The contents + of the NOTICE file are for informational purposes only and + do not modify the License. You may add Your own attribution + notices within Derivative Works that You distribute, alongside + or as an addendum to the NOTICE text from the Work, provided + that such additional attribution notices cannot be construed + as modifying the License. + + You may add Your own copyright statement to Your modifications and + may provide additional or different license terms and conditions + for use, reproduction, or distribution of Your modifications, or + for any such Derivative Works as a whole, provided Your use, + reproduction, and distribution of the Work otherwise complies with + the conditions stated in this License. + + 5. Submission of Contributions. Unless You explicitly state otherwise, + any Contribution intentionally submitted for inclusion in the Work + by You to the Licensor shall be under the terms and conditions of + this License, without any additional terms or conditions. + Notwithstanding the above, nothing herein shall supersede or modify + the terms of any separate license agreement you may have executed + with Licensor regarding such Contributions. + + 6. Trademarks. This License does not grant permission to use the trade + names, trademarks, service marks, or product names of the Licensor, + except as required for reasonable and customary use in describing the + origin of the Work and reproducing the content of the NOTICE file. + + 7. Disclaimer of Warranty. Unless required by applicable law or + agreed to in writing, Licensor provides the Work (and each + Contributor provides its Contributions) on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or + implied, including, without limitation, any warranties or conditions + of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A + PARTICULAR PURPOSE. You are solely responsible for determining the + appropriateness of using or redistributing the Work and assume any + risks associated with Your exercise of permissions under this License. + + 8. Limitation of Liability. In no event and under no legal theory, + whether in tort (including negligence), contract, or otherwise, + unless required by applicable law (such as deliberate and grossly + negligent acts) or agreed to in writing, shall any Contributor be + liable to You for damages, including any direct, indirect, special, + incidental, or consequential damages of any character arising as a + result of this License or out of the use or inability to use the + Work (including but not limited to damages for loss of goodwill, + work stoppage, computer failure or malfunction, or any and all + other commercial damages or losses), even if such Contributor + has been advised of the possibility of such damages. + + 9. Accepting Warranty or Additional Liability. While redistributing + the Work or Derivative Works thereof, You may choose to offer, + and charge a fee for, acceptance of support, warranty, indemnity, + or other liability obligations and/or rights consistent with this + License. However, in accepting such obligations, You may act only + on Your own behalf and on Your sole responsibility, not on behalf + of any other Contributor, and only if You agree to indemnify, + defend, and hold each Contributor harmless for any liability + incurred by, or claims asserted against, such Contributor by reason + of your accepting any such warranty or additional liability. + + END OF TERMS AND CONDITIONS + + APPENDIX: How to apply the Apache License to your work. + + To apply the Apache License to your work, attach the following + boilerplate notice, with the fields enclosed by brackets "[]" + replaced with your own identifying information. (Don't include + the brackets!) The text should be enclosed in the appropriate + comment syntax for the file format. We also recommend that a + file or class name and description of purpose be included on the + same "printed page" as the copyright notice for easier + identification within third-party archives. + + Copyright [yyyy] [name of copyright owner] + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. diff --git a/resource-registry/resource-registry.cabal b/resource-registry/resource-registry.cabal new file mode 100644 index 0000000000..7a802cf982 --- /dev/null +++ b/resource-registry/resource-registry.cabal @@ -0,0 +1,85 @@ +cabal-version: 3.0 +name: resource-registry +version: 0.1.0.0 +synopsis: Track allocated resources +description: + When the scope of a @bracket@ doesn't enclose all uses of the resource, a + 'ResourceRegistry' can be used instead to capture the lifetime of those + resources. + +homepage: https://github.com/input-output-hk/resource-registry +license: Apache-2.0 +license-file: LICENSE +author: IOG Engineering Team +maintainer: hackage@iohk.io +copyright: + 2019-2023 Input Output Global Inc (IOG) + 2023-2024 INTERSECT + 2024 Input Output Global Inc (IOG) + +category: Control +build-type: Simple +extra-doc-files: + CHANGELOG.md + +tested-with: + ghc ==8.10 || ==9.6 || ==9.8 + +source-repository head + type: git + location: https://github.com/input-output-hk/resource-registry + +common warnings + ghc-options: + -Wall + -Wcompat + -Wincomplete-uni-patterns + -Wincomplete-record-updates + -Wpartial-fields + -Widentities + -Wredundant-constraints + -Wmissing-export-lists + -Wunused-packages + -Wno-unticked-promoted-constructors + +library + import: warnings + exposed-modules: Control.ResourceRegistry + build-depends: + base >=4.14 && <4.21, + bimap, + containers, + io-classes ^>=1.5, + mtl, + nf-vars ^>=0.1, + nothunks ^>=0.1.5, + + hs-source-dirs: src + default-language: Haskell2010 + +test-suite resource-registry-test + import: warnings + default-language: Haskell2010 + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Main.hs + other-modules: + Test.Util.QSM + Test.Util.SOP + Test.Util.ToExpr + + build-depends: + QuickCheck, + base, + containers, + generics-sop, + io-classes, + mtl, + quickcheck-state-machine:no-vendored-treediff, + resource-registry, + si-timers, + strict-mvar, + strict-stm, + tasty, + tasty-quickcheck, + tree-diff, diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util/ResourceRegistry.hs b/resource-registry/src/Control/ResourceRegistry.hs similarity index 82% rename from ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util/ResourceRegistry.hs rename to resource-registry/src/Control/ResourceRegistry.hs index ef4e3ebec7..6cd1235494 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util/ResourceRegistry.hs +++ b/resource-registry/src/Control/ResourceRegistry.hs @@ -3,85 +3,22 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DerivingVia #-} {-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE QuantifiedConstraints #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE UndecidableInstances #-} -module Ouroboros.Consensus.Util.ResourceRegistry ( - RegistryClosedException (..) - , ResourceRegistryThreadException - -- * Creating and releasing the registry itself - , bracketWithPrivateRegistry - , registryThread - , withRegistry - -- * Allocating and releasing regular resources - , ResourceKey - , allocate - , allocateEither - , release - , releaseAll - , unsafeRelease - , unsafeReleaseAll - -- * Threads - , cancelThread - , forkLinkedThread - , forkThread - , linkToRegistry - , threadId - , waitAnyThread - , waitThread - , withThread - -- ** opaque - , Thread - -- * Temporary registry - , TempRegistryException (..) - , allocateTemp - , modifyWithTempRegistry - , runInnerWithTempRegistry - , runWithTempRegistry - -- ** opaque - , WithTempRegistry - -- * Combinators primarily for testing - , closeRegistry - , countResources - , unsafeNewRegistry - -- * opaque - , ResourceRegistry - ) where +{-# OPTIONS_GHC -Wno-orphans #-} -import Control.Applicative ((<|>)) -import Control.Exception (asyncExceptionFromException) -import Control.Monad -import Control.Monad.Reader -import Control.Monad.State.Strict -import Data.Bifunctor -import Data.Bimap (Bimap) -import qualified Data.Bimap as Bimap -import Data.Either (partitionEithers) -import Data.Map.Strict (Map) -import qualified Data.Map.Strict as Map -import Data.Maybe (catMaybes, listToMaybe) -import Data.Set (Set) -import qualified Data.Set as Set -import Data.Word (Word64) -import GHC.Generics (Generic) -import NoThunks.Class (InspectHeapNamed (..), OnlyCheckWhnfNamed (..), - allNoThunks) -import Ouroboros.Consensus.Util (mustBeRight, whenJust) -import Ouroboros.Consensus.Util.CallStack -import Ouroboros.Consensus.Util.IOLike -import Ouroboros.Consensus.Util.Orphans () - --- | Resource registry --- --- Note on terminology: when thread A forks thread B, we will say that thread A --- is the " parent " and thread B is the " child ". No further relationship +-- | Note on terminology: when thread A forks thread B, we will say that thread A +-- is the \"parent\" and thread B is the \"child\". No further relationship -- between the two threads is implied by this terminology. In particular, note --- that the child may outlive the parent. We will use "fork" and "spawn" +-- that the child may outlive the parent. We will use \"fork\" and \"spawn\" -- interchangeably. -- -- = Motivation @@ -189,13 +126,14 @@ import Ouroboros.Consensus.Util.Orphans () -- = Spawning threads -- -- We already observed in the introduction that insisting on lexical scoping --- for threads is often inconvenient, and that simply using 'fork' is no --- solution as it means we might leak resources. There is however another --- problem with 'fork'. Consider this snippet: +-- for threads is often inconvenient, and that simply using +-- 'Control.Monad.Class.MonadFork.forkIO' is no solution as it means we might +-- leak resources. There is however another problem with +-- 'Control.Monad.Class.MonadFork.forkIO'. Consider this snippet: -- -- > withRegistry $ \registry -> -- > r <- allocate registry allocateResource releaseResource --- > fork $ .. use r .. +-- > forkIO $ .. use r .. -- -- It is easy to see that this code is problematic: we allocate a resource @r@, -- then spawn a thread that uses @r@, and finally leave the scope of @@ -284,6 +222,77 @@ import Ouroboros.Consensus.Util.Orphans () -- registries, but even if we do have easy access to a parent regisry, creating -- a local one where possibly is useful as it limits the scope of the resources -- created within, and hence their maximum lifetimes. + +module Control.ResourceRegistry ( + -- * The resource registry proper + Context + , ResourceId + , ResourceRegistry + -- * Exceptions + , RegistryClosedException (..) + , ResourceRegistryThreadException + -- * Creating and releasing the registry itself + , bracketWithPrivateRegistry + , registryThread + , withRegistry + -- * Allocating and releasing regular resources + , ResourceKey + , allocate + , allocateEither + , release + , releaseAll + , unsafeRelease + , unsafeReleaseAll + -- * Threads + , Thread + , cancelThread + , forkLinkedThread + , forkThread + , linkToRegistry + , threadId + , waitAnyThread + , waitThread + , withThread + -- * Temporary registry + , TempRegistryException (..) + , WithTempRegistry + , allocateTemp + , modifyWithTempRegistry + , runInnerWithTempRegistry + , runWithTempRegistry + -- * Unsafe combinators primarily for testing + , closeRegistry + , countResources + , unsafeNewRegistry + ) where + +import Control.Applicative ((<|>)) +import Control.Concurrent.Class.MonadSTM (MonadSTM (atomically)) +import Control.Concurrent.Class.MonadSTM.NormalForm +import Control.Exception (asyncExceptionFromException) +import Control.Monad +import Control.Monad.Class.MonadAsync +import Control.Monad.Class.MonadFork +import Control.Monad.Class.MonadThrow +import Control.Monad.Reader +import Control.Monad.State.Strict +import Data.Bifunctor +import Data.Bimap (Bimap) +import qualified Data.Bimap as Bimap +import Data.Either (partitionEithers) +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as Map +import Data.Maybe (catMaybes, listToMaybe) +import Data.Set (Set) +import qualified Data.Set as Set +import Data.Void +import Data.Word (Word64) +import GHC.Generics (Generic) +import GHC.Stack (CallStack, HasCallStack) +import qualified GHC.Stack as GHC +import NoThunks.Class hiding (Context) + +-- | Tracks resources during their lifetime. data ResourceRegistry m = ResourceRegistry { -- | Context in which the registry was created registryContext :: !(Context m) @@ -293,7 +302,8 @@ data ResourceRegistry m = ResourceRegistry { } deriving (Generic) -deriving instance IOLike m => NoThunks (ResourceRegistry m) +deriving instance (forall a. NoThunks a => NoThunks (StrictTVar m a)) + => NoThunks (ResourceRegistry m) {------------------------------------------------------------------------------- Internal: registry state @@ -326,14 +336,14 @@ nextYoungerAge :: Age -> Age nextYoungerAge (Age n) = Age (n - 1) -- | Internal registry state --- --- INVARIANT: We record exactly the ages of currently allocated resources, --- @'Bimap.keys' . 'registryAges' = 'Map.keys' . 'registryResources'@. data RegistryState m = RegistryState { -- | Forked threads registryThreads :: !(KnownThreads m) -- | Currently allocated resources + -- + -- INVARIANT: We record exactly the ages of currently allocated resources, + -- @'Bimap.keys' . 'registryAges' = 'Map.keys' . 'registryResources'@. , registryResources :: !(Map ResourceId (Resource m)) -- | Next available resource key @@ -387,7 +397,10 @@ data RegistryStatus = -- -- Resource keys are tied to a particular registry. data ResourceKey m = ResourceKey !(ResourceRegistry m) !ResourceId - deriving (Generic, NoThunks) + deriving Generic + +deriving instance NoThunks (ResourceRegistry m) + => NoThunks (ResourceKey m) -- | Return the 'ResourceId' of a 'ResourceKey'. resourceKeyId :: ResourceKey m -> ResourceId @@ -427,13 +440,16 @@ instance Show (Release m) where Internal: pure functions on the registry state -------------------------------------------------------------------------------} -modifyKnownThreads :: (Set (ThreadId m) -> Set (ThreadId m)) - -> KnownThreads m -> KnownThreads m +modifyKnownThreads :: + (Set (ThreadId m) -> Set (ThreadId m)) + -> KnownThreads m + -> KnownThreads m modifyKnownThreads f (KnownThreads ts) = KnownThreads (f ts) -- | Auxiliary for functions that should be disallowed when registry is closed -unlessClosed :: State (RegistryState m) a - -> State (RegistryState m) (Either PrettyCallStack a) +unlessClosed :: + State (RegistryState m) a + -> State (RegistryState m) (Either PrettyCallStack a) unlessClosed f = do status <- gets registryStatus case status of @@ -448,9 +464,10 @@ allocKey = unlessClosed $ do return nextKey -- | Insert new resource -insertResource :: ResourceId - -> Resource m - -> State (RegistryState m) (Either PrettyCallStack ()) +insertResource :: + ResourceId + -> Resource m + -> State (RegistryState m) (Either PrettyCallStack ()) insertResource key r = unlessClosed $ do modify $ \st -> st { registryResources = Map.insert key r (registryResources st) @@ -476,7 +493,7 @@ removeResource key = state $ \st -> in (mbResource, st') -- | Insert thread into the set of known threads -insertThread :: IOLike m => ThreadId m -> State (RegistryState m) () +insertThread :: MonadThread m => ThreadId m -> State (RegistryState m) () insertThread tid = modify $ \st -> st { registryThreads = modifyKnownThreads (Set.insert tid) $ @@ -484,7 +501,7 @@ insertThread tid = } -- | Remove thread from set of known threads -removeThread :: IOLike m => ThreadId m -> State (RegistryState m) () +removeThread :: MonadThread m => ThreadId m -> State (RegistryState m) () removeThread tid = modify $ \st -> st { registryThreads = modifyKnownThreads (Set.delete tid) $ @@ -496,17 +513,20 @@ removeThread tid = -- Returns the keys currently allocated if the registry is not already closed. -- -- POSTCONDITION: They are returned in youngest-to-oldest order. -close :: PrettyCallStack - -> State (RegistryState m) (Either PrettyCallStack [ResourceId]) +close :: + PrettyCallStack + -> State (RegistryState m) (Either PrettyCallStack [ResourceId]) close closeCallStack = unlessClosed $ do modify $ \st -> st {registryStatus = RegistryClosed closeCallStack} gets getYoungestToOldest -- | Convenience function for updating the registry state -updateState :: forall m a. IOLike m - => ResourceRegistry m - -> State (RegistryState m) a - -> m a +updateState :: + forall m a. + MonadSTM m + => ResourceRegistry m + -> State (RegistryState m) a + -> m a updateState rr f = atomically $ stateTVar (registryState rr) (runState f) @@ -522,16 +542,17 @@ updateState rr f = -- -- It is probably not particularly useful for threads to try and catch this -- exception (apart from in a generic handler that does local resource cleanup). --- The thread will anyway soon receive a 'ThreadKilled' exception. +-- The thread will anyway soon receive a 'Control.Exception.ThreadKilled' +-- exception. data RegistryClosedException = - forall m. IOLike m => RegistryClosedException { + forall m. MonadThread m => RegistryClosedException { -- | The context in which the registry was created registryClosedRegistryContext :: !(Context m) - -- | Callstack to the call to 'close' + -- | Callstack to the call to 'closeRegistry' -- - -- Note that 'close' can only be called from the same thread that - -- created the registry. + -- Note that 'closeRegistry' can only be called from the same thread + -- that created the registry. , registryClosedCloseCallStack :: !PrettyCallStack -- | Context of the call resulting in the exception @@ -549,7 +570,9 @@ instance Exception RegistryClosedException -- -- You are strongly encouraged to use 'withRegistry' instead. -- Exported primarily for the benefit of tests. -unsafeNewRegistry :: (IOLike m, HasCallStack) => m (ResourceRegistry m) +unsafeNewRegistry :: + (MonadSTM m, MonadThread m, HasCallStack) + => m (ResourceRegistry m) unsafeNewRegistry = do context <- captureContext stateVar <- newTVarIO initState @@ -587,7 +610,10 @@ unsafeNewRegistry = do -- will prioritize asynchronous exceptions over other exceptions. This may be -- important for exception handlers that catch all-except-asynchronous -- exceptions. -closeRegistry :: (IOLike m, HasCallStack) => ResourceRegistry m -> m () +closeRegistry :: + (MonadMask m, MonadThread m, MonadSTM m, HasCallStack) + => ResourceRegistry m + -> m () closeRegistry rr = mask_ $ do context <- captureContext unless (contextThreadId context == contextThreadId (registryContext rr)) $ @@ -616,15 +642,16 @@ closeRegistry rr = mask_ $ do -- the resources allocated with the given 'ResourceId's. -- -- Returns the contexts of the resources that were actually released. -releaseResources :: IOLike m - => ResourceRegistry m - -> [ResourceId] - -- ^ PRECONDITION: The currently allocated keys, - -- youngest-to-oldest - -> (ResourceKey m -> m (Maybe (Context m))) - -- ^ How to release the resource, e.g., 'release' or - -- 'unsafeRelease'. - -> m [Context m] +releaseResources :: + MonadCatch m + => ResourceRegistry m + -> [ResourceId] + -- ^ PRECONDITION: The currently allocated keys, + -- youngest-to-oldest + -> (ResourceKey m -> m (Maybe (Context m))) + -- ^ How to release the resource, e.g., 'release' or + -- 'unsafeRelease'. + -> m [Context m] releaseResources rr sortedKeys releaser = do (exs, mbContexts) <- fmap partitionEithers $ forM sortedKeys $ try . releaser . ResourceKey rr @@ -643,7 +670,10 @@ releaseResources rr sortedKeys releaser = do -- | Create a new registry -- -- See documentation of 'ResourceRegistry' for a detailed discussion. -withRegistry :: (IOLike m, HasCallStack) => (ResourceRegistry m -> m a) -> m a +withRegistry :: + (MonadSTM m, MonadMask m, MonadThread m, HasCallStack) + => (ResourceRegistry m -> m a) + -> m a withRegistry = bracket unsafeNewRegistry closeRegistry -- | Create a new private registry for use by a bracketed resource @@ -681,11 +711,12 @@ withRegistry = bracket unsafeNewRegistry closeRegistry -- private to the bracketed resource. -- -- See documentation of 'ResourceRegistry' for a more general discussion. -bracketWithPrivateRegistry :: (IOLike m, HasCallStack) - => (ResourceRegistry m -> m a) - -> (a -> m ()) -- ^ Release the resource - -> (a -> m r) - -> m r +bracketWithPrivateRegistry :: + (MonadSTM m, MonadMask m, MonadThread m, HasCallStack) + => (ResourceRegistry m -> m a) + -> (a -> m ()) -- ^ Release the resource + -> (a -> m r) + -> m r bracketWithPrivateRegistry newA closeA body = withRegistry $ \registry -> do (_key, a) <- allocate registry (\_key -> newA registry) closeA @@ -698,10 +729,11 @@ bracketWithPrivateRegistry newA closeA body = -- | Run an action with a temporary resource registry. -- -- When allocating resources that are meant to end up in some final state, --- e.g., stored in a 'TVar', after which they are guaranteed to be released --- correctly, it is possible that an exception is thrown after allocating such --- a resource, but before it was stored in the final state. In that case, the --- resource would be leaked. 'runWithTempRegistry' solves that problem. +-- e.g., stored in a 'Control.Monad.Class.MonadSTM.TVar', after which they are +-- guaranteed to be released correctly, it is possible that an exception is +-- thrown after allocating such a resource, but before it was stored in the +-- final state. In that case, the resource would be leaked. +-- 'runWithTempRegistry' solves that problem. -- -- When no exception is thrown before the end of 'runWithTempRegistry', the -- user must have transferred all the resources it allocated to their final @@ -734,7 +766,7 @@ bracketWithPrivateRegistry newA closeA body = -- because the state /must/ have been stored somewhere safely, transferring -- the resources, before the temporary registry is closed. runWithTempRegistry :: - (IOLike m, HasCallStack) + (MonadSTM m, MonadMask m, MonadThread m, HasCallStack) => WithTempRegistry st m (a, st) -> m a runWithTempRegistry m = withRegistry $ \rr -> do @@ -749,7 +781,7 @@ runWithTempRegistry m = withRegistry $ \rr -> do -- -- No need to mask here, whether we throw the async exception or -- 'TempRegistryRemainingResource' doesn't matter. - transferredTo <- atomically $ readTVar varTransferredTo + transferredTo <- readTVarIO varTransferredTo untrackTransferredTo rr transferredTo st context <- captureContext @@ -762,6 +794,10 @@ runWithTempRegistry m = withRegistry $ \rr -> do } return a + where + whenJust (Just x) f = f x + whenJust Nothing _ = pure () + -- | Embed a self-contained 'WithTempRegistry' computation into a larger one. -- -- The internal 'WithTempRegistry' is effectively passed to @@ -786,7 +822,8 @@ runWithTempRegistry m = withRegistry $ \rr -> do -- closed and then the composite resource will be closed. This means there's a -- risk of /double freeing/, which can be harmless if anticipated. runInnerWithTempRegistry :: - forall innerSt st m res a. IOLike m + forall innerSt st m res a. + (MonadSTM m, MonadMask m, MonadThread m) => WithTempRegistry innerSt m (a, innerSt, res) -- ^ The embedded computation; see ASSUMPTION above -> (res -> m Bool) @@ -811,13 +848,13 @@ runInnerWithTempRegistry inner free isTransferred = do -- 'runWithTempRegistry' that lets us perform some action with async -- exceptions masked "at the same time" it closes its registry. - -- Note that everything in `inner` allocated via `allocateTemp` must either be - -- closed or else present in `innerSt` by this point -- `runWithTempRegistry` - -- would have thrown if not. + -- Note that everything in `inner` allocated via `allocateTemp` must + -- either be closed or else present in `innerSt` by this point -- + -- `runWithTempRegistry` would have thrown if not. pure (a, innerSt) where - withFixedTempRegistry - :: TempRegistry st m + withFixedTempRegistry :: + TempRegistry st m -> WithTempRegistry st m res -> WithTempRegistry innerSt m res withFixedTempRegistry env (WithTempRegistry (ReaderT f)) = @@ -827,7 +864,7 @@ runInnerWithTempRegistry inner free isTransferred = do -- resources remaining in the temporary registry that haven't been transferred -- to the final state. data TempRegistryException = - forall m. IOLike m => TempRegistryRemainingResource { + forall m. MonadThread m => TempRegistryRemainingResource { -- | The context in which the temporary registry was created. tempRegistryContext :: !(Context m) @@ -861,7 +898,13 @@ data TempRegistry st m = TempRegistry { newtype WithTempRegistry st m a = WithTempRegistry { unWithTempRegistry :: ReaderT (TempRegistry st m) m a } - deriving newtype (Functor, Applicative, Monad, MonadThrow, MonadCatch, MonadMask) + deriving newtype ( Functor + , Applicative + , Monad + , MonadThrow + , MonadCatch + , MonadMask + ) instance MonadTrans (WithTempRegistry st) where lift = WithTempRegistry . lift @@ -878,7 +921,7 @@ instance MonadState s m => MonadState s (WithTempRegistry st m) where -- NOTE: does not check that it's called by the same thread that allocated the -- resources, as it's an internal function only used in 'runWithTempRegistry'. untrackTransferredTo :: - IOLike m + MonadSTM m => ResourceRegistry m -> TransferredTo st -> st @@ -891,7 +934,7 @@ untrackTransferredTo rr transferredTo st = -- | Allocate a resource in a temporary registry until it has been transferred -- to the final state @st@. See 'runWithTempRegistry' for more details. allocateTemp :: - (IOLike m, HasCallStack) + (MonadSTM m, MonadMask m, MonadThread m, HasCallStack) => m a -- ^ Allocate the resource -> (a -> m Bool) @@ -904,8 +947,8 @@ allocateTemp :: -> WithTempRegistry st m a allocateTemp alloc free isTransferred = WithTempRegistry $ do TempRegistry rr varTransferredTo <- ask - (key, a) <- lift $ fmap mustBeRight $ - allocateEither rr (fmap Right . const alloc) free + (key, a) <- lift (mustBeRight <$> + allocateEither rr (fmap Right . const alloc) free) lift $ atomically $ modifyTVar varTransferredTo $ mappend $ TransferredTo $ \st -> if isTransferred st a @@ -917,7 +960,8 @@ allocateTemp alloc free isTransferred = WithTempRegistry $ do -- allocating resources in the process that will be transferred to the -- returned @st@. modifyWithTempRegistry :: - forall m st a. IOLike m + forall m st a. + (MonadSTM m, MonadMask m, MonadThread m) => m st -- ^ Get the state -> (st -> ExitCase st -> m ()) -- ^ Store the new state -> StateT st (WithTempRegistry st m) a -- ^ Modify the state @@ -942,7 +986,7 @@ registryThread = contextThreadId . registryContext -- | Number of currently allocated resources -- -- Primarily for the benefit of testing. -countResources :: IOLike m => ResourceRegistry m -> m Int +countResources :: MonadSTM m => ResourceRegistry m -> m Int countResources rr = atomically $ aux <$> readTVar (registryState rr) where aux :: RegistryState m -> Int @@ -958,28 +1002,32 @@ countResources rr = atomically $ aux <$> readTVar (registryState rr) -- means that the resource allocation must either be fast or else interruptible; -- see "Dealing with Asynchronous Exceptions during Resource Acquisition" -- for details. -allocate :: forall m a. (IOLike m, HasCallStack) - => ResourceRegistry m - -> (ResourceId -> m a) - -> (a -> m ()) -- ^ Release the resource - -> m (ResourceKey m, a) +allocate :: + forall m a. + (MonadSTM m, MonadMask m, MonadThread m, HasCallStack) + => ResourceRegistry m + -> (ResourceId -> m a) + -> (a -> m ()) -- ^ Release the resource + -> m (ResourceKey m, a) allocate rr alloc free = mustBeRight <$> allocateEither rr (fmap Right . alloc) (\a -> free a >> return True) -- | Generalization of 'allocate' for allocation functions that may fail -allocateEither :: forall m e a. (IOLike m, HasCallStack) - => ResourceRegistry m - -> (ResourceId -> m (Either e a)) - -> (a -> m Bool) - -- ^ Release the resource, return 'True' when the resource - -- hasn't been released or closed before. - -> m (Either e (ResourceKey m, a)) +allocateEither :: + forall m e a. + (MonadSTM m, MonadMask m, MonadThread m, HasCallStack) + => ResourceRegistry m + -> (ResourceId -> m (Either e a)) + -> (a -> m Bool) + -- ^ Release the resource, return 'True' when the resource + -- hasn't been released or closed before. + -> m (Either e (ResourceKey m, a)) allocateEither rr alloc free = do context <- captureContext ensureKnownThread rr context -- We check if the registry has been closed when we allocate the key, so -- that we can avoid needlessly allocating the resource. - mKey <- updateState rr $ allocKey + mKey <- updateState rr allocKey case mKey of Left closed -> throwRegistryClosed rr context closed @@ -990,7 +1038,8 @@ allocateEither rr alloc free = do Right a -> do -- TODO: Might want to have an exception handler around this call to -- 'updateState' just in case /that/ throws an exception. - inserted <- updateState rr $ insertResource key (mkResource context a) + inserted <- updateState rr $ + insertResource key (mkResource context a) case inserted of Left closed -> do -- Despite the earlier check, it's possible that the registry @@ -1008,11 +1057,12 @@ allocateEither rr alloc free = do , resourceRelease = Release $ free a } -throwRegistryClosed :: IOLike m - => ResourceRegistry m - -> Context m - -> PrettyCallStack - -> m x +throwRegistryClosed :: + (MonadThrow m, MonadThread m) + => ResourceRegistry m + -> Context m + -> PrettyCallStack + -> m x throwRegistryClosed rr context closed = throwIO RegistryClosedException { registryClosedRegistryContext = registryContext rr , registryClosedCloseCallStack = closed @@ -1031,7 +1081,10 @@ throwRegistryClosed rr context closed = throwIO RegistryClosedException { -- Releasing an already released resource is a no-op. -- -- When the resource has not been released before, its context is returned. -release :: (IOLike m, HasCallStack) => ResourceKey m -> m (Maybe (Context m)) +release :: + (MonadMask m, MonadSTM m, MonadThread m, HasCallStack) + => ResourceKey m + -> m (Maybe (Context m)) release key@(ResourceKey rr _) = do context <- captureContext ensureKnownThread rr context @@ -1049,7 +1102,10 @@ release key@(ResourceKey rr _) = do -- -- This function should only be used if the above situation can be ruled out -- or handled by other means. -unsafeRelease :: IOLike m => ResourceKey m -> m (Maybe (Context m)) +unsafeRelease :: + (MonadMask m, MonadSTM m) + => ResourceKey m + -> m (Maybe (Context m)) unsafeRelease (ResourceKey rr rid) = do mask_ $ do mResource <- updateState rr $ removeResource rid @@ -1065,7 +1121,10 @@ unsafeRelease (ResourceKey rr rid) = do -- | Release all resources in the 'ResourceRegistry' without closing. -- -- See 'closeRegistry' for more details. -releaseAll :: (IOLike m, HasCallStack) => ResourceRegistry m -> m () +releaseAll :: + (MonadMask m, MonadSTM m, MonadThread m, HasCallStack) + => ResourceRegistry m + -> m () releaseAll rr = do context <- captureContext unless (contextThreadId context == contextThreadId (registryContext rr)) $ @@ -1078,18 +1137,22 @@ releaseAll rr = do -- | This is to 'releaseAll' what 'unsafeRelease' is to 'release': we do not -- insist that this funciton is called from a thread that is known to the -- registry. See 'unsafeRelease' for why this is dangerous. -unsafeReleaseAll :: (IOLike m, HasCallStack) => ResourceRegistry m -> m () +unsafeReleaseAll :: + (MonadMask m, MonadSTM m, MonadThread m, HasCallStack) + => ResourceRegistry m + -> m () unsafeReleaseAll rr = do context <- captureContext void $ releaseAllHelper rr context unsafeRelease -- | Internal helper used by 'releaseAll' and 'unsafeReleaseAll'. -releaseAllHelper :: IOLike m - => ResourceRegistry m - -> Context m - -> (ResourceKey m -> m (Maybe (Context m))) - -- ^ How to release a resource - -> m [Context m] +releaseAllHelper :: + (MonadMask m, MonadSTM m, MonadThread m) + => ResourceRegistry m + -> Context m + -> (ResourceKey m -> m (Maybe (Context m))) + -- ^ How to release a resource + -> m [Context m] releaseAllHelper rr context releaser = mask_ $ do mKeys <- updateState rr $ unlessClosed $ gets getYoungestToOldest case mKeys of @@ -1103,7 +1166,8 @@ releaseAllHelper rr context releaser = mask_ $ do -- | Thread -- -- The internals of this type are not exported. -data Thread m a = IOLike m => Thread { +data Thread m a = MonadThread m => Thread { + -- | The underlying @async@ thread id threadId :: !(ThreadId m) , threadResourceId :: !ResourceId , threadAsync :: !(Async m a) @@ -1112,7 +1176,7 @@ data Thread m a = IOLike m => Thread { deriving NoThunks via OnlyCheckWhnfNamed "Thread" (Thread m a) -- | 'Eq' instance for 'Thread' compares 'threadId' only. -instance Eq (Thread m a) where +instance MonadThread m => Eq (Thread m a) where Thread{threadId = a} == Thread{threadId = b} = a == b -- | Cancel a thread @@ -1121,7 +1185,7 @@ instance Eq (Thread m a) where -- function returns. -- -- Uses 'uninterruptibleCancel' because that's what 'withAsync' does. -cancelThread :: IOLike m => Thread m a -> m () +cancelThread :: MonadAsync m => Thread m a -> m () cancelThread = uninterruptibleCancel . threadAsync -- | Wait for thread to terminate and return its result. @@ -1130,20 +1194,22 @@ cancelThread = uninterruptibleCancel . threadAsync -- -- NOTE: If A waits on B, and B is linked to the registry, and B throws an -- exception, then A might /either/ receive the exception thrown by B /or/ --- the 'ThreadKilled' exception thrown by the registry. -waitThread :: IOLike m => Thread m a -> m a +-- the 'Control.Exception.ThreadKilled' exception thrown by the registry. +waitThread :: MonadAsync m => Thread m a -> m a waitThread = wait . threadAsync -- | Lift 'waitAny' to 'Thread' -waitAnyThread :: forall m a. IOLike m => [Thread m a] -> m a +waitAnyThread :: forall m a. MonadAsync m => [Thread m a] -> m a waitAnyThread ts = snd <$> waitAny (map threadAsync ts) -- | Fork a new thread -forkThread :: forall m a. (IOLike m, HasCallStack) - => ResourceRegistry m - -> String -- ^ Label for the thread - -> m a - -> m (Thread m a) +forkThread :: + forall m a. + (MonadMask m, MonadAsync m, HasCallStack) + => ResourceRegistry m + -> String -- ^ Label for the thread + -> m a + -> m (Thread m a) forkThread rr label body = snd <$> allocate rr (\key -> mkThread key <$> async (body' key)) cancelThread where @@ -1208,7 +1274,7 @@ forkThread rr label body = snd <$> -- the parent, the child should probably be linked to the registry instead and -- the thread that spawned the registry should handle any exceptions. -- --- Note that in /principle/ there is no problem in using 'withAync' alongside a +-- Note that in /principle/ there is no problem in using 'withAsync' alongside a -- registry. After all, in a pattern like -- -- > withRegistry $ \registry -> @@ -1236,26 +1302,28 @@ forkThread rr label body = snd <$> -- NOTE: Threads that are spawned out of the user's control but that must still -- make use of the registry can use the unsafe API. This should be used with -- caution, however. -withThread :: IOLike m - => ResourceRegistry m - -> String -- ^ Label for the thread - -> m a - -> (Thread m a -> m b) - -> m b +withThread :: + (MonadMask m, MonadAsync m) + => ResourceRegistry m + -> String -- ^ Label for the thread + -> m a + -> (Thread m a -> m b) + -> m b withThread rr label body = bracket (forkThread rr label body) cancelThread -- | Link specified 'Thread' to the (thread that created) the registry -linkToRegistry :: IOLike m => Thread m a -> m () +linkToRegistry :: (MonadAsync m, MonadFork m, MonadMask m) => Thread m a -> m () linkToRegistry t = linkTo (registryThread $ threadRegistry t) (threadAsync t) -- | Fork a thread and link to it to the registry. -- -- This function is just a convenience. -forkLinkedThread :: (IOLike m, HasCallStack) - => ResourceRegistry m - -> String -- ^ Label for the thread - -> m a - -> m (Thread m a) +forkLinkedThread :: + (MonadAsync m, MonadFork m, MonadMask m, HasCallStack) + => ResourceRegistry m + -> String -- ^ Label for the thread + -> m a + -> m (Thread m a) forkLinkedThread rr label body = do t <- forkThread rr label body -- There is no race condition here between the new thread throwing an @@ -1269,8 +1337,12 @@ forkLinkedThread rr label body = do Check that registry is used from known thread -------------------------------------------------------------------------------} -ensureKnownThread :: forall m. IOLike m - => ResourceRegistry m -> Context m -> m () +ensureKnownThread :: + forall m. + (MonadThrow m, MonadThread m, MonadSTM m) + => ResourceRegistry m + -> Context m + -> m () ensureKnownThread rr context = do isKnown <- checkIsKnown unless isKnown $ @@ -1294,7 +1366,7 @@ data ResourceRegistryThreadException = -- | If the registry is used from an untracked thread, we cannot do proper -- reference counting. The following threads are /tracked/: the thread -- that spawned the registry and all threads spawned by the registry. - forall m. IOLike m => ResourceRegistryUsedFromUntrackedThread { + forall m. MonadThread m => ResourceRegistryUsedFromUntrackedThread { -- | Information about the context in which the registry was created resourceRegistryCreatedIn :: !(Context m) @@ -1303,7 +1375,7 @@ data ResourceRegistryThreadException = } -- | Registry closed from different threat than that created it - | forall m. IOLike m => ResourceRegistryClosedFromWrongThread { + | forall m. MonadThread m => ResourceRegistryClosedFromWrongThread { -- | Information about the context in which the registry was created resourceRegistryCreatedIn :: !(Context m) @@ -1318,7 +1390,9 @@ instance Exception ResourceRegistryThreadException Auxiliary: context -------------------------------------------------------------------------------} -data Context m = IOLike m => Context { +-- | The internal context of a resource registry, recording a 'PrettyCallStack' +-- of its creation and the creator's 'ThreadId' +data Context m = MonadThread m => Context { -- | CallStack in which it was created contextCallStack :: !PrettyCallStack @@ -1336,5 +1410,89 @@ instance NoThunks (Context m) where deriving instance Show (Context m) -captureContext :: IOLike m => HasCallStack => m (Context m) +captureContext :: MonadThread m => HasCallStack => m (Context m) captureContext = Context prettyCallStack <$> myThreadId + +{------------------------------------------------------------------------------- + Misc utilities +-------------------------------------------------------------------------------} + +-- | Generalization of 'link' that links an async to an arbitrary thread. +-- +-- Non standard (not in 'async' library) +-- +linkTo :: + (MonadAsync m, MonadFork m, MonadMask m) + => ThreadId m + -> Async m a + -> m () +linkTo tid = linkToOnly tid (not . isCancel) + +-- | Generalization of 'linkOnly' that links an async to an arbitrary thread. +-- +-- Non standard (not in 'async' library). +-- +linkToOnly :: + forall m a. + (MonadAsync m, MonadFork m, MonadMask m) + => ThreadId m + -> (SomeException -> Bool) + -> Async m a + -> m () +linkToOnly tid shouldThrow a = do + void $ forkRepeat ("linkToOnly " <> show linkedThreadId) $ do + r <- waitCatch a + case r of + Left e | shouldThrow e -> throwTo tid (exceptionInLinkedThread e) + _otherwise -> return () + where + linkedThreadId :: ThreadId m + linkedThreadId = asyncThreadId a + + exceptionInLinkedThread :: SomeException -> ExceptionInLinkedThread + exceptionInLinkedThread = + ExceptionInLinkedThread (show linkedThreadId) + +isCancel :: SomeException -> Bool +isCancel e + | Just AsyncCancelled <- fromException e = True + | otherwise = False + +forkRepeat :: (MonadFork m, MonadMask m) => String -> m a -> m (ThreadId m) +forkRepeat label action = + mask $ \restore -> + let go = do r <- tryAll (restore action) + case r of + Left _ -> go + _ -> return () + in forkIO (labelThisThread label >> go) + +tryAll :: MonadCatch m => m a -> m (Either SomeException a) +tryAll = try + +mustBeRight :: Either Void a -> a +mustBeRight (Left v) = absurd v +mustBeRight (Right a) = a + +{------------------------------------------------------------------------------- + Auxiliary: CallStack with different Show instance +-------------------------------------------------------------------------------} + +-- | CallStack with 'Show' instance using 'prettyCallStack' +newtype PrettyCallStack = PrettyCallStack CallStack + deriving newtype (NoThunks) + +instance Show PrettyCallStack where + show (PrettyCallStack cs) = GHC.prettyCallStack cs + +-- | Capture a 'PrettyCallStack' +prettyCallStack :: HasCallStack => PrettyCallStack +prettyCallStack = PrettyCallStack GHC.callStack + +{------------------------------------------------------------------------------- + Orphan instance +-------------------------------------------------------------------------------} + +instance (NoThunks k, NoThunks v) + => NoThunks (Bimap k v) where + wNoThunks ctxt = noThunksInKeysAndValues ctxt . Bimap.toList diff --git a/ouroboros-consensus/test/consensus-test/Test/Consensus/ResourceRegistry.hs b/resource-registry/test/Main.hs similarity index 86% rename from ouroboros-consensus/test/consensus-test/Test/Consensus/ResourceRegistry.hs rename to resource-registry/test/Main.hs index 979f582f3b..0e24d2f419 100644 --- a/ouroboros-consensus/test/consensus-test/Test/Consensus/ResourceRegistry.hs +++ b/resource-registry/test/Main.hs @@ -1,22 +1,18 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DeriveTraversable #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeApplications #-} -- | Tests for the resource registry -- --- The resource registry is a component throughout the consensus layer that --- helps us keep track of resources and makes sure that all resources that we --- allocate are eventually also deallocated in the right order. --- -- The tests for the registry are model based. The model records which resources -- we expect to be alive and which we expect to have been deallocated. The only -- resources we are modelling here are threads; the commands we then execute are @@ -28,18 +24,24 @@ -- -- We then verify that the resource registry behaves like the model, cleaning -- up resources as threads terminate or crash. --- -module Test.Consensus.ResourceRegistry (tests) where - -import Control.Monad ((>=>)) +module Main (main) where + +import Control.Concurrent.Class.MonadMVar.Strict +import Control.Concurrent.Class.MonadSTM.Strict +import Control.Monad +import Control.Monad.Class.MonadAsync +import Control.Monad.Class.MonadFork +import Control.Monad.Class.MonadThrow import Control.Monad.Class.MonadTimer.SI -import Control.Monad.Except (Except, MonadError, runExcept, - throwError) -import Control.Monad.IO.Class (liftIO) -import Data.Foldable (toList) -import Data.Function (on) +import Control.Monad.Except +#if __GLASGOW_HASKELL__ >= 900 +import Control.Monad.IO.Class +#endif +import Control.ResourceRegistry +import Data.Foldable +import Data.Function import Data.Functor.Classes -import Data.Kind (Type) +import Data.Kind import Data.List (delete, sort) import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map @@ -47,23 +49,21 @@ import Data.TreeDiff import Data.Typeable import qualified Generics.SOP as SOP import GHC.Generics (Generic, Generic1) -import Ouroboros.Consensus.Util.IOLike -import Ouroboros.Consensus.Util.ResourceRegistry -import Prelude hiding (elem) -import qualified Test.QuickCheck as QC -import Test.QuickCheck (Gen) -import qualified Test.QuickCheck.Monadic as QC +import Prelude +import Test.QuickCheck hiding (forAll) +import Test.QuickCheck.Monadic hiding (run) import Test.StateMachine import qualified Test.StateMachine.Types as QSM import qualified Test.StateMachine.Types.Rank2 as Rank2 import Test.Tasty hiding (after) -import Test.Tasty.QuickCheck (testProperty) +import Test.Tasty.QuickCheck hiding (forAll) import Test.Util.QSM import Test.Util.SOP import Test.Util.ToExpr () -tests :: TestTree -tests = testGroup "ResourceRegistry" [ +main :: IO () +main = defaultMain + $ testGroup "ResourceRegistry" [ testProperty "sequential" prop_sequential ] @@ -274,7 +274,7 @@ data TestThread m = TestThread { , threadLinked :: Link (TestThread m) -- | Send the thread instructions (see 'ThreadInstr') - , threadComms :: TQueue m (QueuedInstr m) + , threadComms :: StrictTQueue m (QueuedInstr m) } -- | Instructions to a thread @@ -293,16 +293,16 @@ data ThreadInstr m :: Type -> Type where -- | Instruction along with an MVar for the result data QueuedInstr m = forall a. QueuedInstr (ThreadInstr m a) (StrictMVar m a) -runInThread :: IOLike m => TestThread m -> ThreadInstr m a -> m a +runInThread :: (MonadMVar m, MonadSTM m) => TestThread m -> ThreadInstr m a -> m a runInThread TestThread{..} instr = do - result <- uncheckedNewEmptyMVar + result <- newEmptyMVar atomically $ writeTQueue threadComms (QueuedInstr instr result) takeMVar result -instance (IOLike m) => Show (TestThread m) where +instance (MonadThread m) => Show (TestThread m) where show TestThread{..} = "" -instance (IOLike m) => Eq (TestThread m) where +instance (MonadThread m) => Eq (TestThread m) where (==) = (==) `on` (threadId . testThread) -- | Create a new thread in the given registry @@ -310,14 +310,14 @@ instance (IOLike m) => Eq (TestThread m) where -- In order to be able to see which threads are alive, we have threads -- register and unregister themselves. We do not reuse the registry for this, -- to avoid circular reasoning in the tests. -newThread :: forall m. IOLike m +newThread :: forall m. (MonadMVar m, MonadMask m, MonadAsync m, MonadFork m) => StrictTVar m [TestThread m] -> ResourceRegistry m -> Link (TestThread m) -> m (TestThread m) newThread alive parentReg = \shouldLink -> do comms <- atomically $ newTQueue - spawned <- uncheckedNewEmptyMVar + spawned <- newEmptyMVar thread <- forkThread parentReg "newThread" $ withRegistry $ \childReg -> @@ -340,7 +340,7 @@ newThread alive parentReg = \shouldLink -> do where threadBody :: ResourceRegistry m -> StrictMVar m (TestThread m) - -> TQueue m (QueuedInstr m) + -> StrictTQueue m (QueuedInstr m) -> m () threadBody childReg spawned comms = do us <- readMVar spawned @@ -360,7 +360,7 @@ newThread alive parentReg = \shouldLink -> do putMVar result () error "crashing" -runIO :: forall m. (IOLike m, MonadTimer m) +runIO :: forall m. (MonadMVar m, MonadTimer m, MonadMask m, MonadAsync m, MonadFork m) => StrictTVar m [TestThread m] -> ResourceRegistry m -> Cmd (TestThread m) -> m (Resp (TestThread m)) @@ -398,8 +398,8 @@ runIO alive reg cmd = catchEx $ timeout 1 $ newtype At m f r = At (f (Reference (TestThread m) r)) -deriving instance (Show1 r, IOLike m) => Show (At m Cmd r) -deriving instance (Show1 r, IOLike m) => Show (At m Resp r) +deriving instance (MonadThread m, Show1 r) => Show (At m Cmd r) +deriving instance (MonadThread m, Show1 r) => Show (At m Resp r) {------------------------------------------------------------------------------- Relate model to IO @@ -423,11 +423,11 @@ initModel = Model emptyMock [] Events -------------------------------------------------------------------------------} -toMock :: forall m f r. (Functor f, Eq1 r, Show1 r, IOLike m) +toMock :: forall m f r. (Functor f, Eq1 r, Show1 r, MonadThread m) => Model m r -> At m f r -> f MockThread toMock (Model _ hs) (At fr) = (hs !) <$> fr -step :: (Eq1 r, Show1 r, IOLike m) +step :: (Eq1 r, Show1 r, MonadThread m) => Model m r -> At m Cmd r -> (Resp MockThread, Mock) step m@(Model mock _) c = runMock (toMock m c) mock @@ -438,7 +438,7 @@ data Event m r = Event { , mockResp :: Resp MockThread } -lockstep :: (Eq1 r, Show1 r, IOLike m) +lockstep :: (Eq1 r, Show1 r, MonadThread m) => Model m r -> At m Cmd r -> At m Resp r @@ -464,9 +464,9 @@ lockstep m@(Model _ hs) c (At resp) = Event { -------------------------------------------------------------------------------} generator :: forall m. Model m Symbolic -> Maybe (Gen (At m Cmd Symbolic)) -generator (Model _ hs) = Just $ QC.oneof $ concat [ +generator (Model _ hs) = Just $ oneof $ concat [ withoutHandle - , if null hs then [] else withHandle (QC.elements (map fst hs)) + , if null hs then [] else withHandle (elements (map fst hs)) ] where withoutHandle :: [Gen (At m Cmd Symbolic)] @@ -484,7 +484,7 @@ generator (Model _ hs) = Just $ QC.oneof $ concat [ ] genLink :: Gen (Link ()) - genLink = aux <$> QC.arbitrary + genLink = aux <$> arbitrary where aux :: Bool -> Link () aux True = LinkFromParent () @@ -519,14 +519,14 @@ instance ToExpr Mock instance ToExpr (Link MockThread) instance ToExpr (Model IO Concrete) -instance (IOLike m) => ToExpr (TestThread m) where +instance (MonadThread m) => ToExpr (TestThread m) where toExpr = defaultExprViaShow {------------------------------------------------------------------------------- QSM toplevel -------------------------------------------------------------------------------} -semantics :: (IOLike m, MonadTimer m, Typeable m) +semantics :: (MonadMVar m, MonadMask m, MonadAsync m, MonadFork m, MonadTimer m, Typeable m) => StrictTVar m [TestThread m] -> ResourceRegistry m -> At m Cmd Concrete -> m (At m Resp Concrete) @@ -534,11 +534,11 @@ semantics alive reg (At c) = (At . fmap reference) <$> runIO alive reg (concrete <$> c) -transition :: (Eq1 r, Show1 r, IOLike m) +transition :: (Eq1 r, Show1 r, MonadThread m) => Model m r -> At m Cmd r -> At m Resp r -> Model m r transition m c = after . lockstep m c -precondition :: forall m. (IOLike m) +precondition :: forall m. (MonadThread m) => Model m Symbolic -> At m Cmd Symbolic -> Logic precondition (Model mock hs) (At c) = forAll (toList c) checkRef @@ -549,7 +549,7 @@ precondition (Model mock hs) (At c) = Nothing -> Bot Just r' -> r' `member` mockLiveThreads (threads mock) -postcondition :: (IOLike m) +postcondition :: (MonadThread m) => Model m Concrete -> At m Cmd Concrete -> At m Resp Concrete @@ -559,7 +559,7 @@ postcondition m c r = where e = lockstep m c r -symbolicResp :: (IOLike m, Typeable m) +symbolicResp :: (MonadThread m, Typeable m) => Model m Symbolic -> At m Cmd Symbolic -> GenSym (At m Resp Symbolic) @@ -567,7 +567,7 @@ symbolicResp m c = At <$> traverse (const genSym) resp where (resp, _mock') = step m c -sm :: (IOLike m, MonadTimer m, Typeable m) +sm :: (MonadMVar m, MonadMask m, MonadAsync m, MonadFork m, MonadTimer m, Typeable m) => StrictTVar m [TestThread m] -> ResourceRegistry m -> StateMachine (Model m) (At m Cmd) m (At m Resp) @@ -584,18 +584,18 @@ sm alive reg = StateMachine { , cleanup = noCleanup } -prop_sequential :: QC.Property +prop_sequential :: Property prop_sequential = forAllCommands (sm unused unused) Nothing prop_sequential' -prop_sequential' :: QSM.Commands (At IO Cmd) (At IO Resp) -> QC.Property -prop_sequential' cmds = QC.monadicIO $ do - alive <- liftIO $ uncheckedNewTVarM [] +prop_sequential' :: QSM.Commands (At IO Cmd) (At IO Resp) -> Property +prop_sequential' cmds = monadicIO $ do + alive <- liftIO $ newTVarIO [] reg <- liftIO $ unsafeNewRegistry let sm' = sm alive reg (hist, _model, res) <- runCommands sm' cmds prettyCommands sm' hist $ checkCommandNames cmds - $ res QC.=== Ok + $ res === Ok unused :: a unused = error "not used during command generation" diff --git a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/QSM.hs b/resource-registry/test/Test/Util/QSM.hs similarity index 100% rename from ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/QSM.hs rename to resource-registry/test/Test/Util/QSM.hs diff --git a/resource-registry/test/Test/Util/SOP.hs b/resource-registry/test/Test/Util/SOP.hs new file mode 100644 index 0000000000..cf05a42b31 --- /dev/null +++ b/resource-registry/test/Test/Util/SOP.hs @@ -0,0 +1,31 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} + +module Test.Util.SOP ( + constrName + , constrNames + ) where + +import Data.Proxy +import qualified Generics.SOP as SOP + +constrInfo :: SOP.HasDatatypeInfo a + => proxy a + -> SOP.NP SOP.ConstructorInfo (SOP.Code a) +constrInfo = SOP.constructorInfo . SOP.datatypeInfo + +constrName :: forall a. SOP.HasDatatypeInfo a => a -> String +constrName a = + SOP.hcollapse $ SOP.hliftA2 go (constrInfo p) (SOP.unSOP (SOP.from a)) + where + go :: SOP.ConstructorInfo b -> SOP.NP SOP.I b -> SOP.K String b + go nfo _ = SOP.K $ SOP.constructorName nfo + + p = Proxy @a + +constrNames :: SOP.HasDatatypeInfo a => proxy a -> [String] +constrNames p = + SOP.hcollapse $ SOP.hmap go (constrInfo p) + where + go :: SOP.ConstructorInfo a -> SOP.K String a + go nfo = SOP.K $ SOP.constructorName nfo diff --git a/resource-registry/test/Test/Util/ToExpr.hs b/resource-registry/test/Test/Util/ToExpr.hs new file mode 100644 index 0000000000..704b66befc --- /dev/null +++ b/resource-registry/test/Test/Util/ToExpr.hs @@ -0,0 +1,36 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +{-# OPTIONS_GHC -Wno-orphans #-} + +-- | This module implements QSM's @CanDiff@ typeclass using @tree-diff@'s +-- @ToExpr@. +module Test.Util.ToExpr () where + +import Data.TreeDiff as T +import qualified Test.StateMachine as QSM +import Test.StateMachine.Diffing (CanDiff (..)) +import qualified Test.StateMachine.Types.References as QSM + +instance ToExpr x => CanDiff x where + type ADiff x = Edit EditExpr + type AnExpr x = Expr + + toDiff = toExpr + exprDiff _ = T.exprDiff + diffToDocCompact _ = ansiWlBgEditExprCompact + diffToDoc _ = ansiWlBgEditExpr + exprToDoc _ = ansiWlBgExpr + +{------------------------------------------------------------------------------- + QSM's References instances +-------------------------------------------------------------------------------} + +instance ToExpr (r k) => ToExpr (QSM.Reference k r) + +instance ToExpr a => ToExpr (QSM.Concrete a) where + toExpr (QSM.Concrete x) = toExpr x + +instance ToExpr (QSM.Opaque a) where + toExpr _ = App "Opaque" [] diff --git a/scripts/ci/check-changelogs.sh b/scripts/ci/check-changelogs.sh index de4e00ab73..fbffd699d6 100755 --- a/scripts/ci/check-changelogs.sh +++ b/scripts/ci/check-changelogs.sh @@ -4,7 +4,7 @@ # - NO_CHANGELOG_LABEL: disables the check for changelog fragments additions # - BASE_REF: what to compare this branch against -packages=(ouroboros-consensus ouroboros-consensus-diffusion ouroboros-consensus-protocol ouroboros-consensus-cardano sop-extras strict-sop-core) +packages=(ouroboros-consensus ouroboros-consensus-diffusion ouroboros-consensus-protocol ouroboros-consensus-cardano sop-extras strict-sop-core resource-registry nf-vars) ok=1 diff --git a/scripts/ci/run-cabal-gild.sh b/scripts/ci/run-cabal-gild.sh index cb352ed8c9..9ebf27b362 100755 --- a/scripts/ci/run-cabal-gild.sh +++ b/scripts/ci/run-cabal-gild.sh @@ -15,8 +15,8 @@ if ! command -v "$fdcmd" &> /dev/null; then fi case "$(uname -s)" in - MINGW*) path="$(pwd -W | sed 's_/_\\\\_g')\\\\(ouroboros-consensus|sop-extras|strict-sop-core)";; - *) path="$(pwd)/(ouroboros-consensus|sop-extras|strict-sop-core)";; + MINGW*) path="$(pwd -W | sed 's_/_\\\\_g')\\\\(ouroboros-consensus|sop-extras|strict-sop-core|resource-registry|nf-vars)";; + *) path="$(pwd)/(ouroboros-consensus|sop-extras|strict-sop-core|resource-registry|nf-vars)";; esac $fdcmd --full-path "$path" -e cabal -x cabal-gild -i {} -o {} diff --git a/scripts/ci/run-stylish.sh b/scripts/ci/run-stylish.sh index 43190a0333..79d69953fb 100755 --- a/scripts/ci/run-stylish.sh +++ b/scripts/ci/run-stylish.sh @@ -20,20 +20,23 @@ if ! command -v "$fdcmd" &> /dev/null; then fi case "$(uname -s)" in - MINGW*) path="$(pwd -W | sed 's_/_\\\\_g')\\\\(ouroboros-consensus|sop-extras|strict-sop-core)";; - *) path="$(pwd)/(ouroboros-consensus|sop-extras|strict-sop-core)";; + MINGW*) path="$(pwd -W | sed 's_/_\\\\_g')\\\\(ouroboros-consensus|sop-extras|strict-sop-core|resource-registry|nf-vars)";; + *) path="$(pwd)/(ouroboros-consensus|sop-extras|strict-sop-core|resource-registry|nf-vars)";; esac $fdcmd --full-path "$path" \ --extension hs \ - --exclude Setup.hs \ --exclude ouroboros-consensus-cardano/app/DBAnalyser/Parsers.hs \ + --exclude resource-registry/test/Main.hs \ --exec-batch stylish-haskell -c .stylish-haskell.yaml -i -# We don't want these deprecation warnings to be removed accidentally +# We don't want these to be removed accidentally grep "#if __GLASGOW_HASKELL__ < 900 import Data.Foldable (asum) -#endif" ouroboros-consensus-cardano/app/DBAnalyser/Parsers.hs >/dev/null 2>&1 +#endif" ouroboros-consensus-cardano/app/DBAnalyser/Parsers.hs >/dev/null 2>&1 +grep "#if __GLASGOW_HASKELL__ >= 900 +import Control.Monad.IO.Class +#endif" resource-registry/test/Main.hs >/dev/null 2>&1 case "$(uname -s)" in MINGW*) git ls-files --eol | grep "w/crlf" | awk '{print $4}' | xargs dos2unix;; diff --git a/scripts/docs/prologue.haddock b/scripts/docs/prologue.haddock index 46d247ad91..747afd2897 100644 --- a/scripts/docs/prologue.haddock +++ b/scripts/docs/prologue.haddock @@ -56,7 +56,7 @@ implementation of consensus. * Utilities: - * "Ouroboros.Consensus.Util.ResourceRegistry" + * "Control.ResourceRegistry" == Consensus Components diff --git a/scripts/release/cabal-plan-diff.sh b/scripts/release/cabal-plan-diff.sh index 81d1274eb0..2dd7bb2512 100755 --- a/scripts/release/cabal-plan-diff.sh +++ b/scripts/release/cabal-plan-diff.sh @@ -64,6 +64,8 @@ tests: False benchmarks: False packages: + nf-vars + resource-registry ouroboros-consensus ouroboros-consensus-cardano ouroboros-consensus-protocol diff --git a/weeder.toml b/weeder.toml new file mode 100644 index 0000000000..d9095f04e4 --- /dev/null +++ b/weeder.toml @@ -0,0 +1,24 @@ +unused-types = true +roots = [ # consensus api + "Ouroboros.Consensus.Node" + , "Ouroboros.Consensus.NodeKernel" + , "Ouroboros.Consensus.Cardano" + # lemmas + , "^*._lemma_*" + # GHCI helper for ChainDB + , "Test.Consensus.Storage.ChainDB.StateMachine.Utils.RunOnRepl" + # tests mains + , "Main" + # sop-extras & strict-sop-core + , "Data.SOP.*" + # resource-registry + , "Control.ResourceRegistry" + # nf-vars + , "Control.Concurrent.*.NormalForm.*" + , "Control.Concurrent.Class.MonadSTM.Strict.SVar" + # code ported from cardano-api for db-synthesizer + , "^Cardano.*" + # ad-hoc + , "^*_should_process_and_return$" + ] +type-class-roots = true