From faccfff41ef877ab089793324ec9ead9ffb28052 Mon Sep 17 00:00:00 2001 From: Javier Sagredo Date: Tue, 22 Oct 2024 17:43:07 +0200 Subject: [PATCH] Use hackage `resource-registry` --- .../changelog.d/js-resourcereg.md | 3 + .../ouroboros-consensus-cardano.cabal | 1 + .../Cardano/Tools/DBAnalyser/Analysis.hs | 2 +- .../Cardano/Tools/DBAnalyser/Run.hs | 2 +- .../Cardano/Tools/DBImmutaliser/Run.hs | 2 +- .../Cardano/Tools/DBSynthesizer/Run.hs | 2 +- .../Cardano/Tools/DBTruncater/Run.hs | 3 +- .../Cardano/Tools/ImmDBServer/Diffusion.hs | 2 +- .../Tools/ImmDBServer/MiniProtocols.hs | 2 +- .../changelog.d/js-resourcereg.md | 3 + .../ouroboros-consensus-diffusion.cabal | 3 + .../Consensus/Network/NodeToClient.hs | 2 +- .../Ouroboros/Consensus/Network/NodeToNode.hs | 2 +- .../Ouroboros/Consensus/Node.hs | 2 +- .../Ouroboros/Consensus/Node/ErrorPolicy.hs | 5 +- .../Ouroboros/Consensus/Node/RethrowPolicy.hs | 5 +- .../Ouroboros/Consensus/NodeKernel.hs | 2 +- .../Test/ThreadNet/Network.hs | 2 +- .../Consensus/PeerSimulator/BlockFetch.hs | 2 +- .../Consensus/PeerSimulator/NodeLifecycle.hs | 2 +- .../Test/Consensus/PeerSimulator/Run.hs | 2 +- .../bench/ChainSync-client-bench/Main.hs | 2 +- .../changelog.d/js-resourcereg.md | 3 + ouroboros-consensus/ouroboros-consensus.cabal | 15 +- .../BlockchainTime/WallClock/HardFork.hs | 2 +- .../BlockchainTime/WallClock/Simple.hs | 2 +- .../Ouroboros/Consensus/Mempool/Init.hs | 2 +- .../MiniProtocol/BlockFetch/Server.hs | 2 +- .../MiniProtocol/ChainSync/Server.hs | 2 +- .../Consensus/Storage/ChainDB/API.hs | 2 +- .../Consensus/Storage/ChainDB/Impl.hs | 4 +- .../Consensus/Storage/ChainDB/Impl/Args.hs | 2 +- .../Storage/ChainDB/Impl/Background.hs | 2 +- .../Storage/ChainDB/Impl/Follower.hs | 2 +- .../Storage/ChainDB/Impl/Iterator.hs | 2 +- .../Consensus/Storage/ChainDB/Impl/Types.hs | 2 +- .../Consensus/Storage/ImmutableDB/API.hs | 2 +- .../Consensus/Storage/ImmutableDB/Impl.hs | 2 +- .../Storage/ImmutableDB/Impl/Index.hs | 2 +- .../Storage/ImmutableDB/Impl/Index/Cache.hs | 2 +- .../Storage/ImmutableDB/Impl/Iterator.hs | 4 +- .../Storage/ImmutableDB/Impl/State.hs | 2 +- .../Storage/ImmutableDB/Impl/Validation.hs | 2 +- .../Consensus/Storage/ImmutableDB/Stream.hs | 2 +- .../Consensus/Storage/VolatileDB/Impl.hs | 2 +- .../Storage/VolatileDB/Impl/State.hs | 4 +- .../Ouroboros/Consensus/Util/EarlyExit.hs | 19 +- .../Ouroboros/Consensus/Util/IOLike.hs | 32 +- .../Consensus/Util/NormalForm/StrictMVar.hs | 11 +- .../Consensus/Util/NormalForm/StrictTVar.hs | 24 +- .../Consensus/Util/ResourceRegistry.hs | 1340 ----------------- .../Ouroboros/Consensus/Util/STM.hs | 2 +- .../Test/Util/ChainDB.hs | 2 +- .../Test/Util/HardFork/OracularClock.hs | 2 +- .../Test/Util/LogicalClock.hs | 2 +- .../Test/Util/Orphans/NoThunks.hs | 21 +- .../test/consensus-test/Main.hs | 2 - .../Test/Consensus/BlockchainTime/Simple.hs | 10 +- .../MiniProtocol/BlockFetch/Client.hs | 2 +- .../MiniProtocol/ChainSync/Client.hs | 2 +- .../Test/Consensus/ResourceRegistry.hs | 629 -------- .../Storage/ChainDB/FollowerPromptness.hs | 2 +- .../Ouroboros/Storage/ChainDB/Iterator.hs | 2 +- .../Ouroboros/Storage/ChainDB/StateMachine.hs | 2 +- .../Test/Ouroboros/Storage/ChainDB/Unit.hs | 3 +- .../Storage/ImmutableDB/StateMachine.hs | 2 +- .../Storage/VolatileDB/StateMachine.hs | 2 +- scripts/docs/prologue.haddock | 5 - 68 files changed, 161 insertions(+), 2078 deletions(-) create mode 100644 ouroboros-consensus-cardano/changelog.d/js-resourcereg.md create mode 100644 ouroboros-consensus-diffusion/changelog.d/js-resourcereg.md create mode 100644 ouroboros-consensus/changelog.d/js-resourcereg.md delete mode 100644 ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util/ResourceRegistry.hs delete mode 100644 ouroboros-consensus/test/consensus-test/Test/Consensus/ResourceRegistry.hs diff --git a/ouroboros-consensus-cardano/changelog.d/js-resourcereg.md b/ouroboros-consensus-cardano/changelog.d/js-resourcereg.md new file mode 100644 index 0000000000..dce8a32365 --- /dev/null +++ b/ouroboros-consensus-cardano/changelog.d/js-resourcereg.md @@ -0,0 +1,3 @@ +## Patch + +* Use [`resource-registry`](https://hackage.haskell.org/package/resource-registry). diff --git a/ouroboros-consensus-cardano/ouroboros-consensus-cardano.cabal b/ouroboros-consensus-cardano/ouroboros-consensus-cardano.cabal index 8aa5bbd4e3..bec7e5a1dd 100644 --- a/ouroboros-consensus-cardano/ouroboros-consensus-cardano.cabal +++ b/ouroboros-consensus-cardano/ouroboros-consensus-cardano.cabal @@ -557,6 +557,7 @@ library unstable-cardano-tools ouroboros-network-api, ouroboros-network-framework ^>=0.14, ouroboros-network-protocols, + resource-registry, serialise ^>=0.2, singletons, sop-core, 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 4058652f8b..b96b2226ba 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 Cardano.Tools.DBAnalyser.Types 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.LedgerDB (DiskSnapshot (..), import Ouroboros.Consensus.Storage.Serialisation (encodeDisk) import Ouroboros.Consensus.Util ((..:)) import qualified Ouroboros.Consensus.Util.IOLike as IOLike -import Ouroboros.Consensus.Util.ResourceRegistry import Ouroboros.Network.SizeInBytes 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 953c5decbe..043d084da3 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 9dea66f1e3..03b82dd25a 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 3fddfe1997..2fc13d581f 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 @@ -16,6 +16,7 @@ import Control.Monad (filterM) 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) @@ -36,7 +37,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 f9782352ad..236c5cc5e8 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 @@ -13,6 +13,7 @@ import Cardano.Tools.DBTruncater.Types import Control.Monad import Control.Monad.Trans.Class (lift) import Control.Monad.Trans.Maybe (MaybeT (..)) +import Control.ResourceRegistry (runWithTempRegistry, withRegistry) import Control.Tracer import Data.Foldable (asum) import Data.Functor ((<&>)) @@ -27,8 +28,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 05c51e4bac..434b594361 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 b04b520542..ce5f4ae1ed 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-diffusion/changelog.d/js-resourcereg.md b/ouroboros-consensus-diffusion/changelog.d/js-resourcereg.md new file mode 100644 index 0000000000..dce8a32365 --- /dev/null +++ b/ouroboros-consensus-diffusion/changelog.d/js-resourcereg.md @@ -0,0 +1,3 @@ +## Patch + +* Use [`resource-registry`](https://hackage.haskell.org/package/resource-registry). diff --git a/ouroboros-consensus-diffusion/ouroboros-consensus-diffusion.cabal b/ouroboros-consensus-diffusion/ouroboros-consensus-diffusion.cabal index 623e5b86a8..c255270097 100644 --- a/ouroboros-consensus-diffusion/ouroboros-consensus-diffusion.cabal +++ b/ouroboros-consensus-diffusion/ouroboros-consensus-diffusion.cabal @@ -95,6 +95,7 @@ library ouroboros-network-framework ^>=0.14, ouroboros-network-protocols ^>=0.12, random, + resource-registry ^>=0.1, safe-wild-cards ^>=1.0, serialise ^>=0.2, si-timers ^>=1.5, @@ -149,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, @@ -302,6 +304,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 0d7b9fb83c..bae1f4ce6a 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 @@ -38,6 +38,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) @@ -61,7 +62,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) 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 400827d7ab..f30ad37a31 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 @@ -72,7 +73,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 b234f7b6a1..4e835a5233 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 @@ -65,6 +65,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 (..)) @@ -113,7 +114,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/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 8cbceba692..aa4df6ccec 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) @@ -87,7 +88,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/Network.hs b/ouroboros-consensus-diffusion/src/unstable-diffusion-testlib/Test/ThreadNet/Network.hs index 22d63fc9ff..09f1b4c0c2 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 @@ -44,6 +44,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) @@ -99,7 +100,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/test/consensus-test/Test/Consensus/PeerSimulator/BlockFetch.hs b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PeerSimulator/BlockFetch.hs index 6f320285d9..def5645104 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) @@ -37,7 +38,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 0418ac9f4b..60f7476286 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 2b18210e4e..1010c7eda3 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/bench/ChainSync-client-bench/Main.hs b/ouroboros-consensus/bench/ChainSync-client-bench/Main.hs index 0304a79bee..04b6e5ca20 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 @@ -33,7 +34,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/changelog.d/js-resourcereg.md b/ouroboros-consensus/changelog.d/js-resourcereg.md new file mode 100644 index 0000000000..dce8a32365 --- /dev/null +++ b/ouroboros-consensus/changelog.d/js-resourcereg.md @@ -0,0 +1,3 @@ +## Patch + +* Use [`resource-registry`](https://hackage.haskell.org/package/resource-registry). diff --git a/ouroboros-consensus/ouroboros-consensus.cabal b/ouroboros-consensus/ouroboros-consensus.cabal index 3b46d7be74..61948d6787 100644 --- a/ouroboros-consensus/ouroboros-consensus.cabal +++ b/ouroboros-consensus/ouroboros-consensus.cabal @@ -266,7 +266,6 @@ library 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 @@ -303,6 +302,7 @@ library quiet ^>=0.2, rawlock ^>=0.1, reflection, + resource-registry ^>=0.1, semialign >=1.1, serialise ^>=0.2, si-timers ^>=1.5, @@ -310,6 +310,7 @@ library sop-extras ^>=0.2, streaming, strict-checked-vars ^>=0.2, + strict-mvar ^>=1.5, strict-sop-core ^>=0.1, strict-stm ^>=1.5, text, @@ -417,11 +418,12 @@ 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-mvar, strict-sop-core, strict-stm, tasty, @@ -532,7 +534,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.Versioned @@ -550,7 +551,6 @@ test-suite consensus-test contra-tracer, deepseq, fs-api ^>=0.3, - generics-sop, hashable, io-classes, io-sim, @@ -561,19 +561,20 @@ 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, sop-extras, + strict-mvar, strict-sop-core, + strict-stm, tasty, tasty-hunit, tasty-quickcheck, time, - tree-diff, typed-protocols ^>=0.3, typed-protocols-examples, typed-protocols-stateful, @@ -670,6 +671,7 @@ test-suite storage-test pretty-show, quickcheck-state-machine:no-vendored-treediff ^>=0.10, random, + resource-registry, serialise, strict-stm, tasty, @@ -729,6 +731,7 @@ benchmark ChainSync-client-bench ouroboros-network-api, ouroboros-network-mock, ouroboros-network-protocols, + resource-registry, time, typed-protocols-examples, unstable-consensus-testlib, 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 1055ef33e7..8d381f5af7 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 f77c446d9c..27f16e68f9 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/Mempool/Init.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Mempool/Init.hs index fdaf362035..31cec4c6b5 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 Data.Functor.Contravariant ((>$<)) import Ouroboros.Consensus.Block @@ -21,7 +22,6 @@ import Ouroboros.Consensus.Mempool.Query import Ouroboros.Consensus.Mempool.Update import Ouroboros.Consensus.Util.Enclose 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 9b0fc40995..bf4b3adee5 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 5027c93680..7a536b9ccf 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/Storage/ChainDB/API.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/API.hs index 1ed76832a5..db7577e835 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 @@ -68,6 +68,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 @@ -86,7 +87,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 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 3a893568c5..6709a6cffa 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 84627b9ee7..f95aadee7d 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 {------------------------------------------------------------------------------- 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 08435dd4de..aab651ccb1 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 a54b02df94..8f6366e3f9 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 0ae8b39623..cbd08b2769 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 f696a509e9..33fe5d4321 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 @@ -64,6 +64,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) @@ -104,7 +105,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) 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 8ac3f5d5c5..b35eb013e8 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 @@ -56,6 +56,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) @@ -70,7 +71,6 @@ import Ouroboros.Consensus.Storage.Common import Ouroboros.Consensus.Storage.ImmutableDB.Chunks.Internal 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) 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 bb62a7800a..d4b4716b84 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 28224da880..65b6156121 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 @@ -16,6 +16,7 @@ module Ouroboros.Consensus.Storage.ImmutableDB.Impl.Index ( , cachedIndex ) where +import Control.ResourceRegistry import Control.Tracer (Tracer) import Data.Functor.Identity (Identity (..)) import Data.Proxy (Proxy (..)) @@ -38,7 +39,6 @@ import qualified Ouroboros.Consensus.Storage.ImmutableDB.Impl.Index.Secondary as 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) 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 d86d76db1e..ae55a1e18b 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/Iterator.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ImmutableDB/Impl/Iterator.hs index 1c590e5a0a..ac897e5e6a 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 @@ -20,6 +20,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) @@ -43,8 +45,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 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 380efaf978..0e6da84388 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) @@ -42,7 +43,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 458dfa44f7..6ab3e82d46 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 13a6b6cddc..cb4fee2e40 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/VolatileDB/Impl.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/VolatileDB/Impl.hs index cbe5ee3b53..6d1d09cfcd 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 @@ -120,6 +120,7 @@ import Control.Monad (unless, when) import Control.Monad.State.Strict (get, gets, lift, modify, put, state) import qualified Control.RAWLock as RAWLock +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.Types import Ouroboros.Consensus.Storage.VolatileDB.Impl.Util import Ouroboros.Consensus.Util.Args import Ouroboros.Consensus.Util.IOLike -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 e23440e33e..acec6f9c1c 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 @@ -35,6 +35,8 @@ import Control.Monad import Control.Monad.State.Strict hiding (withState) import Control.RAWLock (RAWLock) import qualified Control.RAWLock as RAWLock +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 +58,6 @@ import Ouroboros.Consensus.Storage.VolatileDB.Impl.Types import Ouroboros.Consensus.Storage.VolatileDB.Impl.Util import Ouroboros.Consensus.Util (whenJust) import Ouroboros.Consensus.Util.IOLike -import Ouroboros.Consensus.Util.ResourceRegistry (WithTempRegistry, - allocateTemp, modifyWithTempRegistry) import Ouroboros.Network.Block (MaxSlotNo (..)) import System.FS.API 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 8cf8da55a6..d132bec59c 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util/EarlyExit.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util/EarlyExit.hs @@ -21,7 +21,9 @@ module Ouroboros.Consensus.Util.EarlyExit ( ) where import Control.Applicative -import Control.Concurrent.Class.MonadMVar +import Control.Concurrent.Class.MonadMVar (MVar, MonadMVar (..)) +import qualified Control.Concurrent.Class.MonadMVar.Strict as Strict +import qualified Control.Concurrent.Class.MonadSTM.Strict as StrictSTM import Control.Monad import Control.Monad.Class.MonadAsync import Control.Monad.Class.MonadEventlog @@ -41,8 +43,7 @@ import Data.Proxy 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) + StrictMVar, StrictSVar, StrictTVar, castStrictSVar) {------------------------------------------------------------------------------- Basic definitions @@ -59,11 +60,17 @@ newtype WithEarlyExit m a = WithEarlyExit { , MonadPlus ) -instance NoThunks (StrictTVar m a) - => NoThunks (StrictTVar (WithEarlyExit m) a) where +instance NoThunks (StrictSTM.StrictTVar m a) + => NoThunks (StrictSTM.StrictTVar (WithEarlyExit m) a) where showTypeOf _ = "StrictTVar (WithEarlyExit m)" wNoThunks ctxt tv = do - wNoThunks ctxt (castStrictTVar tv :: StrictTVar m a) + wNoThunks ctxt (StrictSTM.castStrictTVar tv :: StrictSTM.StrictTVar m a) + +instance NoThunks (Strict.StrictMVar m a) + => NoThunks (Strict.StrictMVar (WithEarlyExit m) a) where + showTypeOf _ = "StrictMVar (WithEarlyExit m)" + wNoThunks ctxt mv = do + wNoThunks ctxt (Strict.castStrictMVar mv :: Strict.StrictMVar m a) instance NoThunks (StrictSVar m a) => NoThunks (StrictSVar (WithEarlyExit m) a) where 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 f5567139e5..88a2b43a44 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util/IOLike.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util/IOLike.hs @@ -1,7 +1,10 @@ {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE QuantifiedConstraints #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# OPTIONS_GHC -Wno-orphans #-} + module Ouroboros.Consensus.Util.IOLike ( IOLike (..) -- * Re-exports @@ -47,7 +50,9 @@ module Ouroboros.Consensus.Util.IOLike ( 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 (MonadInspectMVar (..)) +import qualified Control.Concurrent.Class.MonadMVar.Strict as Strict +import qualified Control.Concurrent.Class.MonadSTM.Strict as StrictSTM import Control.Monad.Class.MonadAsync import Control.Monad.Class.MonadEventlog import Control.Monad.Class.MonadFork @@ -57,12 +62,14 @@ import Control.Monad.Class.MonadTime.SI import Control.Monad.Class.MonadTimer.SI import Control.Monad.Primitive import Data.Functor (void) +import Data.Proxy (Proxy (..)) 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 () + {------------------------------------------------------------------------------- IOLike -------------------------------------------------------------------------------} @@ -85,8 +92,10 @@ class ( MonadAsync m , MonadCatch (STM m) , PrimMonad m , forall a. NoThunks (m a) - , forall a. NoThunks a => NoThunks (StrictTVar m a) + , forall a. NoThunks a => NoThunks (StrictSTM.StrictTVar m a) , forall a. NoThunks a => NoThunks (StrictSVar m a) + , forall a. NoThunks a => NoThunks (Strict.StrictMVar m a) + , forall a. NoThunks a => NoThunks (StrictTVar m a) , forall a. NoThunks a => NoThunks (StrictMVar m a) ) => IOLike m where -- | Securely forget a KES signing key. @@ -141,3 +150,22 @@ forkRepeat label action = tryAll :: MonadCatch m => m a -> m (Either SomeException a) tryAll = try + + +{------------------------------------------------------------------------------- + NoThunks instance +-------------------------------------------------------------------------------} + +instance NoThunks a => NoThunks (StrictSTM.StrictTVar IO a) where + showTypeOf _ = "StrictTVar IO" + wNoThunks ctxt tv = do + -- We can't use @atomically $ readTVar ..@ here, as that will lead to a + -- "Control.Concurrent.STM.atomically was nested" exception. + a <- StrictSTM.readTVarIO tv + noThunks ctxt a + +instance NoThunks a => NoThunks (Strict.StrictMVar IO a) where + showTypeOf _ = "StrictMVar IO" + wNoThunks ctxt mvar = do + aMay <- inspectMVar (Proxy :: Proxy IO) (Strict.toLazyMVar mvar) + noThunks ctxt aMay diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util/NormalForm/StrictMVar.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util/NormalForm/StrictMVar.hs index eca85640d6..20f48ecef1 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util/NormalForm/StrictMVar.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util/NormalForm/StrictMVar.hs @@ -1,4 +1,6 @@ +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -Wno-orphans #-} @@ -29,12 +31,11 @@ module Ouroboros.Consensus.Util.NormalForm.StrictMVar ( , module Control.Concurrent.Class.MonadMVar.Strict.Checked ) where -import Control.Concurrent.Class.MonadMVar (MonadInspectMVar (..)) +import qualified Control.Concurrent.Class.MonadMVar.Strict as Strict import Control.Concurrent.Class.MonadMVar.Strict.Checked hiding (newEmptyMVar, newEmptyMVarWithInvariant, newMVar, newMVarWithInvariant) import qualified Control.Concurrent.Class.MonadMVar.Strict.Checked as Checked -import Data.Proxy (Proxy (..)) import GHC.Stack (HasCallStack) import NoThunks.Class (NoThunks (..), unsafeNoThunks) @@ -85,11 +86,9 @@ noThunksInvariant = fmap show . unsafeNoThunks NoThunks instance -------------------------------------------------------------------------------} -instance NoThunks a => NoThunks (StrictMVar IO a) where +instance NoThunks (Strict.StrictMVar IO a) => NoThunks (StrictMVar IO a) where showTypeOf _ = "StrictMVar IO" - wNoThunks ctxt mvar = do - aMay <- inspectMVar (Proxy :: Proxy IO) (toLazyMVar mvar) - noThunks ctxt aMay + wNoThunks ctxt mvar = wNoThunks ctxt (Checked.unsafeToUncheckedStrictMVar mvar) {------------------------------------------------------------------------------- Unchecked diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util/NormalForm/StrictTVar.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util/NormalForm/StrictTVar.hs index d17be2215d..717fb30089 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util/NormalForm/StrictTVar.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util/NormalForm/StrictTVar.hs @@ -1,4 +1,6 @@ +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -Wno-orphans #-} @@ -28,11 +30,11 @@ module Ouroboros.Consensus.Util.NormalForm.StrictTVar ( , module Control.Concurrent.Class.MonadSTM.Strict.TVar.Checked ) where +import qualified Control.Concurrent.Class.MonadSTM.Strict as StrictSTM import Control.Concurrent.Class.MonadSTM.Strict.TVar.Checked hiding (checkInvariant, newTVar, newTVarIO, newTVarWithInvariant, newTVarWithInvariantIO) import qualified Control.Concurrent.Class.MonadSTM.Strict.TVar.Checked as Checked -import Control.Monad.Class.MonadSTM as StrictSTM import GHC.Stack import NoThunks.Class (NoThunks (..)) import Ouroboros.Consensus.Util.NormalForm.StrictMVar @@ -43,11 +45,11 @@ import Ouroboros.Consensus.Util.NormalForm.StrictMVar -------------------------------------------------------------------------------} -- | Create a 'StrictTVar' with a 'NoThunks' invariant. -newTVar :: (HasCallStack, MonadSTM m, NoThunks a) => a -> STM m (StrictTVar m a) +newTVar :: (HasCallStack, StrictSTM.MonadSTM m, NoThunks a) => a -> StrictSTM.STM m (StrictTVar m a) newTVar = Checked.newTVarWithInvariant noThunksInvariant -- | Create an 'StrictTVar' with a 'NoThunks' invariant. -newTVarIO :: (HasCallStack, MonadSTM m, NoThunks a) => a -> m (StrictTVar m a) +newTVarIO :: (HasCallStack, StrictSTM.MonadSTM m, NoThunks a) => a -> m (StrictTVar m a) newTVarIO = Checked.newTVarWithInvariantIO noThunksInvariant -- | Create a 'StrictTVar' with a custom invariant /and/ a 'NoThunks' invariant. @@ -55,10 +57,10 @@ newTVarIO = Checked.newTVarWithInvariantIO noThunksInvariant -- When both the custom and 'NoThunks' invariants are broken, only the error -- related to the custom invariant is reported. newTVarWithInvariant :: - (HasCallStack, MonadSTM m, NoThunks a) + (HasCallStack, StrictSTM.MonadSTM m, NoThunks a) => (a -> Maybe String) -> a - -> STM m (StrictTVar m a) + -> StrictSTM.STM m (StrictTVar m a) newTVarWithInvariant inv = Checked.newTVarWithInvariant (\x -> inv x <> noThunksInvariant x) @@ -67,7 +69,7 @@ newTVarWithInvariant inv = -- When both the custom and 'NoThunks' invariants are broken, only the error -- related to the custom invariant is reported. newTVarWithInvariantIO :: - (HasCallStack, MonadSTM m, NoThunks a) + (HasCallStack, StrictSTM.MonadSTM m, NoThunks a) => (a -> Maybe String) -> a -> m (StrictTVar m a) @@ -78,18 +80,14 @@ newTVarWithInvariantIO inv = NoThunks instance -------------------------------------------------------------------------------} -instance NoThunks a => NoThunks (StrictTVar IO a) where +instance NoThunks (StrictSTM.StrictTVar IO a) => NoThunks (StrictTVar IO a) where showTypeOf _ = "StrictTVar IO" - wNoThunks ctxt tv = do - -- We can't use @atomically $ readTVar ..@ here, as that will lead to a - -- "Control.Concurrent.STM.atomically was nested" exception. - a <- readTVarIO tv - noThunks ctxt a + wNoThunks ctxt tv = wNoThunks ctxt (Checked.unsafeToUncheckedStrictTVar tv) {------------------------------------------------------------------------------- Unchecked -------------------------------------------------------------------------------} -- | Like 'newTVarIO', but without a 'NoThunks' invariant. -uncheckedNewTVarM :: MonadSTM m => a -> m (StrictTVar m a) +uncheckedNewTVarM :: StrictSTM.MonadSTM m => a -> m (StrictTVar m a) uncheckedNewTVarM = Checked.newTVarIO diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util/ResourceRegistry.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util/ResourceRegistry.hs deleted file mode 100644 index 5cc8d92179..0000000000 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util/ResourceRegistry.hs +++ /dev/null @@ -1,1340 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DerivingVia #-} -{-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# 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 - -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 --- 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" --- interchangeably. --- --- = Motivation --- --- Whenever we allocate resources, we must keep track of them so that we can --- deallocate them when they are no longer required. The most important tool we --- have to achieve this is 'bracket': --- --- > bracket allocateResource releaseResource $ \r -> --- > .. use r .. --- --- Often 'bracket' comes in the guise of a with-style combinator --- --- > withResource $ \r -> --- > .. use r .. --- --- Where this pattern is applicable, it should be used and there is no need to --- use the 'ResourceRegistry'. However, 'bracket' introduces strict lexical --- scoping: the resource is available inside the scope of the bracket, and --- will be deallocated once we leave that scope. That pattern is sometimes --- hard to use. --- --- For example, suppose we have this interface to an SQL server --- --- > query :: Query -> IO QueryHandle --- > close :: QueryHandle -> IO () --- > next :: QueryHandle -> IO Row --- --- and suppose furthermore that we are writing a simple webserver that allows a --- client to send multiple SQL queries, get rows from any open query, and close --- queries when no longer required: --- --- > server :: IO () --- > server = go Map.empty --- > where --- > go :: Map QueryId QueryHandle -> IO () --- > go handles = getRequest >>= \case --- > New q -> do --- > h <- query q -- allocate --- > qId <- generateQueryId --- > sendResponse qId --- > go $ Map.insert qId h handles --- > Close qId -> do --- > close (handles ! qId) -- release --- > go $ Map.delete qId handles --- > Next qId -> do --- > sendResponse =<< next (handles ! qId) --- > go handles --- --- The server opens and closes query handles in response to client requests. --- Restructuring this code to use 'bracket' would be awkward, but as it stands --- this code does not ensure that resources get deallocated; for example, if --- the server thread is killed ('killThread'), resources will be leaked. --- --- Another, perhaps simpler, example is spawning threads. Threads too should --- be considered to be resources that we should keep track of and deallocate --- when they are no longer required, primarily because when we deallocate --- (terminate) those threads they too will have a chance to deallocate /their/ --- resources. As for other resources, we have a with-style combinator for this --- --- > withAsync $ \thread -> .. --- --- Lexical scoping of threads is often inconvenient, however, more so than for --- regular resources. The temptation is therefore to simply fork a thread and --- forget about it, but if we are serious about resource deallocation this is --- not an acceptable solution. --- --- = The resource registry --- --- The resource registry is essentially a piece of state tracking which --- resources have been allocated. The registry itself is allocated with a --- with-style combinator 'withRegistry', and when we leave that scope any --- resources not yet deallocated will be released at that point. Typically --- the registry is only used as a fall-back, ensuring that resources will --- deallocated even in the presence of exceptions. For example, here's how --- we might rewrite the above server example using a registry: --- --- > server' :: IO () --- > server' = --- > withRegistry $ \registry -> go registry Map.empty --- > where --- > go :: ResourceRegistry IO --- > -> Map QueryId (ResourceKey, QueryHandle) --- > -> IO () --- > go registry handles = getRequest >>= \case --- > New q -> do --- > (key, h) <- allocate registry (query q) close -- allocate --- > qId <- generateQueryId --- > sendResponse qId --- > go registry $ Map.insert qId (key, h) handles --- > Close qId -> do --- > release registry (fst (handles ! qId)) -- release --- > go registry $ Map.delete qId handles --- > Next qId -> do --- > sendResponse =<< next (snd (handles ! qId)) --- > go registry handles --- --- We allocate the query with the help of the registry, providing the registry --- with the means to deallocate the query should that be required. We can /and --- should/ still manually release resources also: in this particular example, --- the (lexical) scope of the registry is the entire server thread, so delaying --- releasing queries until we exit that scope will probably mean we hold on to --- resources for too long. The registry is only there as a fall-back. --- --- = 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: --- --- > withRegistry $ \registry -> --- > r <- allocate registry allocateResource releaseResource --- > fork $ .. 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 --- 'withRegistry', thereby deallocating @r@ -- leaving the thread to run with --- a now deallocated resource. --- --- It is /only/ safe for threads to use a given registry, and/or its registered --- resources, if the lifetime of those threads is tied to the lifetime of the --- registry. There would be no problem with the example above if the thread --- would be terminated when we exit the scope of 'withRegistry'. --- --- The 'forkThread' combinator provided by the registry therefore does two --- things: it allocates the thread as a resource in the registry, so that it can --- kill the thread when releasing all resources in the registry. It also records --- the thread ID in a set of known threads. Whenever the registry is accessed --- from a thread /not/ in this set, the registry throws a runtime exception, --- since such a thread might outlive the registry and hence its contents. The --- intention is that this guards against dangerous patterns like the one above. --- --- = Linking --- --- When thread A spawns thread B using 'withAsync', the lifetime of B is tied --- to the lifetime of A: --- --- > withAsync .. $ \threadB -> .. --- --- After all, when A exits the scope of the 'withAsync', thread B will be --- killed. The reverse is however not true: thread B can terminate before --- thread A. It is often useful for thread A to be able to declare a dependency --- on thread B: if B somehow fails, that is, terminates with an exception, we --- want that exception to be rethrown in thread A as well. A can achieve this --- by /linking/ to B: --- --- > withAsync .. $ \threadB -> do --- > link threadB --- > .. --- --- Linking a parent to a child is however of limited value if the lifetime of --- the child is not limited by the lifetime of the parent. For example, if A --- does --- --- > threadB <- async $ .. --- > link threadB --- --- and A terminates before B does, any exception thrown by B might be send to a --- thread that no longer exists. This is particularly problematic when we start --- chaining threads: if A spawns-and-links-to B which spawns-and-links-to C, and --- C throws an exception, perhaps the intention is that this gets rethrown to B, --- and then rethrown to A, terminating all three threads; however, if B has --- terminated before the exception is thrown, C will throw the exception to a --- non-existent thread and A is never notified. --- --- For this reason, the registry's 'linkToRegistry' combinator does not link the --- specified thread to the thread calling 'linkToRegistry', but rather to the --- thread that created the registry. After all, the lifetime of threads spawned --- with 'forkThread' can certainly exceed the lifetime of their parent threads, --- but the lifetime of /all/ threads spawned using the registry will be limited --- by the scope of that registry, and hence the lifetime of the thread that --- created it. So, when we call 'linkToRegistry', the exception will be thrown --- the thread that created the registry, which (if not caught) will cause that --- that to exit the scope of 'withRegistry', thereby terminating all threads in --- that registry. --- --- = Combining the registry and with-style allocation --- --- It is perfectly possible (indeed, advisable) to use 'bracket' and --- bracket-like allocation functions alongside the registry, but note that the --- usual caveats with 'bracket' and forking threads still applies. In --- particular, spawning threads inside the 'bracket' that make use of the --- bracketed resource is problematic; this is of course true whether or not a --- registry is used. --- --- In principle this also includes 'withAsync'; however, since 'withAsync' --- results in a thread that is not known to the registry, such a thread will not --- be able to use the registry (the registry would throw an unknown thread --- exception, as described above). For this purpose we provide 'withThread'; --- 'withThread' (as opposed to 'forkThread') should be used when a parent thread --- wants to handle exceptions in the child thread; see 'withThread' for --- detailed discussion. --- --- It is /also/ fine to includes nested calls to 'withRegistry'. Since the --- lifetime of such a registry (and all resources within) is tied to the thread --- calling 'withRegistry', which itself is tied to the "parent registry" in --- which it was created, this creates a hierarchy of registries. It is of course --- essential for compositionality that we should be able to create local --- 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. -data ResourceRegistry m = ResourceRegistry { - -- | Context in which the registry was created - registryContext :: !(Context m) - - -- | Registry state - , registryState :: !(StrictTVar m (RegistryState m)) - } - deriving (Generic) - -deriving instance IOLike m => NoThunks (ResourceRegistry m) - -{------------------------------------------------------------------------------- - Internal: registry state --------------------------------------------------------------------------------} - --- | The age of a resource --- --- Age here is represented by an meaningless number. The one and only property --- that matters is that the age of resource A that was successfully allocated --- before resource B was (in the same registry) will be greater than the age of --- resource B. --- --- For the current implementation, that property will be true unless the --- registry lives long enough to have contained 2^64 separately allocated --- resources. --- --- This data is not exposed by the 'ResourceRegistry' interface. -newtype Age = Age Word64 - deriving stock (Show) - deriving newtype (Eq, Ord) - deriving NoThunks via InspectHeapNamed "Age" Age - --- | The age of the first resource successfully allocated in a fresh registry -ageOfFirstResource :: Age -ageOfFirstResource = Age maxBound - --- | Map the age of the latest resource to be successfully allocated to the age --- of the next resource to be successfully allocated in the same registry -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 - , registryResources :: !(Map ResourceId (Resource m)) - - -- | Next available resource key - , registryNextKey :: !ResourceId - - -- | The age of each currently allocated resource - -- - -- We use a 'Bimap' so we can maintain the keys in sorted order by age, - -- which is necessary when closing the registry. - , registryAges :: !(Bimap ResourceId Age) - - -- | The age of the next resource - , registryNextAge :: !Age - - -- | Does the registry still accept new allocations? - -- - -- See 'RegistryClosedException' for discussion. - , registryStatus :: !RegistryStatus - } - deriving (Generic, NoThunks) - --- | The currently allocated keys in youngest-to-oldest order -getYoungestToOldest :: RegistryState m -> [ResourceId] -getYoungestToOldest = map snd . Bimap.toAscListR . registryAges - --- | Threads known to the registry --- --- This is the set of threads spawned using 'forkThread'. The lifetimes of all --- of these threads are limited by the lifetime of the registry. --- --- Does not include the thread ID of the thread that created the registry. After --- all, this thread may well outlive the registry (though the registry cannot --- outlive it). --- --- Invariant (informal): the set of registered threads is a subset of the --- registered resources ('registryResources'). (This invariant is temporarily --- broken when we start a new thread in 'forkThread' but will be re-established --- before that thread starts execution proper.) -newtype KnownThreads m = KnownThreads (Set (ThreadId m)) - deriving NoThunks via InspectHeapNamed "KnownThreads" (KnownThreads m) - --- | Status of the registry (open or closed) -data RegistryStatus = - RegistryOpen - - -- | We record the 'CallStack' to the call to 'close - | RegistryClosed !PrettyCallStack - deriving (Generic, NoThunks) - --- | Resource key --- --- Resource keys are tied to a particular registry. -data ResourceKey m = ResourceKey !(ResourceRegistry m) !ResourceId - deriving (Generic, NoThunks) - --- | Return the 'ResourceId' of a 'ResourceKey'. -resourceKeyId :: ResourceKey m -> ResourceId -resourceKeyId (ResourceKey _rr rid) = rid - --- | Resource ID --- --- This uniquifying data is not exposed by the 'ResourceRegistry' interface. -newtype ResourceId = ResourceId Int - deriving stock (Show, Eq, Ord) - deriving newtype (Enum, NoThunks) - --- | Information about a resource -data Resource m = Resource { - -- | Context in which the resource was created - resourceContext :: !(Context m) - - -- | Deallocate the resource - , resourceRelease :: !(Release m) - } - deriving (Generic, NoThunks) - --- | Release the resource, return 'True' when the resource was actually --- released, return 'False' when the resource was already released. --- --- If unsure, returning 'True' is always fine. -newtype Release m = Release (m Bool) - deriving NoThunks via OnlyCheckWhnfNamed "Release" (Release m) - -releaseResource :: Resource m -> m Bool -releaseResource Resource{resourceRelease = Release f} = f - -instance Show (Release m) where - show _ = "<>" - -{------------------------------------------------------------------------------- - Internal: pure functions on the registry state --------------------------------------------------------------------------------} - -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 f = do - status <- gets registryStatus - case status of - RegistryClosed closed -> return $ Left closed - RegistryOpen -> Right <$> f - --- | Allocate key for new resource -allocKey :: State (RegistryState m) (Either PrettyCallStack ResourceId) -allocKey = unlessClosed $ do - nextKey <- gets registryNextKey - modify $ \st -> st {registryNextKey = succ nextKey} - return nextKey - --- | Insert new resource -insertResource :: ResourceId - -> Resource m - -> State (RegistryState m) (Either PrettyCallStack ()) -insertResource key r = unlessClosed $ do - modify $ \st -> st { - registryResources = Map.insert key r (registryResources st) - , registryAges = Bimap.insert - key - (registryNextAge st) - (registryAges st) - , registryNextAge = nextYoungerAge (registryNextAge st) - } - --- | Remove resource from the registry (if it exists) -removeResource :: ResourceId -> State (RegistryState m) (Maybe (Resource m)) -removeResource key = state $ \st -> - let (mbResource, resources') = Map.updateLookupWithKey - (\_ _ -> Nothing) - key - (registryResources st) - - st' = st { - registryResources = resources' - , registryAges = Bimap.delete key (registryAges st) - } - in (mbResource, st') - --- | Insert thread into the set of known threads -insertThread :: IOLike m => ThreadId m -> State (RegistryState m) () -insertThread tid = - modify $ \st -> st { - registryThreads = modifyKnownThreads (Set.insert tid) $ - registryThreads st - } - --- | Remove thread from set of known threads -removeThread :: IOLike m => ThreadId m -> State (RegistryState m) () -removeThread tid = - modify $ \st -> st { - registryThreads = modifyKnownThreads (Set.delete tid) $ - registryThreads st - } - --- | Close the registry --- --- 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 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 rr f = - atomically $ stateTVar (registryState rr) (runState f) - --- | Attempt to allocate a resource in a registry which is closed --- --- When calling 'closeRegistry' (typically, leaving the scope of --- 'withRegistry'), all resources in the registry must be released. If a --- concurrent thread is still allocating resources, we end up with a race --- between the thread trying to allocate new resources and the registry trying --- to free them all. To avoid this, before releasing anything, the registry will --- record itself as closed. Any attempt by a concurrent thread to allocate a new --- resource will then result in a 'RegistryClosedException'. --- --- 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. -data RegistryClosedException = - forall m. IOLike m => RegistryClosedException { - -- | The context in which the registry was created - registryClosedRegistryContext :: !(Context m) - - -- | Callstack to the call to 'close' - -- - -- Note that 'close' can only be called from the same thread that - -- created the registry. - , registryClosedCloseCallStack :: !PrettyCallStack - - -- | Context of the call resulting in the exception - , registryClosedAllocContext :: !(Context m) - } - -deriving instance Show RegistryClosedException -instance Exception RegistryClosedException - -{------------------------------------------------------------------------------- - Creating and releasing the registry itself --------------------------------------------------------------------------------} - --- | Create a new registry --- --- You are strongly encouraged to use 'withRegistry' instead. --- Exported primarily for the benefit of tests. -unsafeNewRegistry :: (IOLike m, HasCallStack) => m (ResourceRegistry m) -unsafeNewRegistry = do - context <- captureContext - stateVar <- newTVarIO initState - return ResourceRegistry { - registryContext = context - , registryState = stateVar - } - where - initState :: RegistryState m - initState = RegistryState { - registryThreads = KnownThreads Set.empty - , registryResources = Map.empty - , registryNextKey = ResourceId 1 - , registryAges = Bimap.empty - , registryNextAge = ageOfFirstResource - , registryStatus = RegistryOpen - } - --- | Close the registry --- --- This can only be called from the same thread that created the registry. --- This is a no-op if the registry is already closed. --- --- This entire function runs with exceptions masked, so that we are not --- interrupted while we release all resources. --- --- Resources will be allocated from young to old, so that resources allocated --- later can safely refer to resources created earlier. --- --- The release functions are run in the scope of an exception handler, so that --- if releasing one resource throws an exception, we still attempt to release --- the other resources. Should we catch an exception whilst we close the --- registry, we will rethrow it after having attempted to release all resources. --- If there is more than one, we will pick a random one to rethrow, though we --- 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 rr = mask_ $ do - context <- captureContext - unless (contextThreadId context == contextThreadId (registryContext rr)) $ - throwIO $ ResourceRegistryClosedFromWrongThread { - resourceRegistryCreatedIn = registryContext rr - , resourceRegistryUsedIn = context - } - - -- Close the registry so that we cannot allocate any further resources - alreadyClosed <- updateState rr $ close (contextCallStack context) - case alreadyClosed of - Left _ -> - return () - Right keys -> do - -- At this point we have not /removed/ any elements from the map, - -- allowing concurrent threads to do their own cleanup of resources - -- (this may for instance be important if a thread deallocates its - -- resources in a particular order -- note that cancelling a thread - -- is a synchronous operation, so we will wait for it to finish - -- releasing its resources.) - -- /If/ a concurrent thread does some cleanup, then some of the calls - -- to 'release' that we do here might be no-ops. - void $ releaseResources rr keys release - --- | Helper for 'closeRegistry', 'releaseAll', and 'unsafeReleaseAll': release --- 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 rr sortedKeys releaser = do - (exs, mbContexts) <- fmap partitionEithers $ - forM sortedKeys $ try . releaser . ResourceKey rr - - case prioritize exs of - Nothing -> return (catMaybes mbContexts) - Just e -> throwIO e - where - prioritize :: [SomeException] -> Maybe SomeException - prioritize = - (\(asyncEx, otherEx) -> listToMaybe asyncEx <|> listToMaybe otherEx) - . first catMaybes - . unzip - . map (\e -> (asyncExceptionFromException e, e)) - --- | Create a new registry --- --- See documentation of 'ResourceRegistry' for a detailed discussion. -withRegistry :: (IOLike m, HasCallStack) => (ResourceRegistry m -> m a) -> m a -withRegistry = bracket unsafeNewRegistry closeRegistry - --- | Create a new private registry for use by a bracketed resource --- --- Use this combinator as a more specific and easier-to-maintain alternative to --- the following. --- --- > 'withRegistry' $ \rr -> --- > 'bracket' (newFoo rr) closeFoo $ \foo -> --- > (... rr does not occur in this scope ...) --- --- NB The scoped body can use `withRegistry` if it also needs its own, separate --- registry. --- --- Use this combinator to emphasize that the registry is private to (ie only --- used by and/or via) the bracketed resource and that it thus has nearly the --- same lifetime. This combinator ensures the following specific invariants --- regarding lifetimes and order of releases. --- --- o The registry itself is older than the bracketed resource. --- --- o The only registered resources older than the bracketed resource were --- allocated in the registry by the function that allocated the bracketed --- resource. --- --- o Because of the older resources, the bracketed resource is itself also --- registered in the registry; that's the only way we can be sure to release --- all resources in the right order. --- --- NB Because the registry is private to the resource, the @a@ type could save --- the handle to @registry@ and safely close the registry if the scoped body --- calls @closeA@ before the bracket ends. Though we have not used the type --- system to guarantee that the interface of the @a@ type cannot leak the --- registry to the body, this combinator does its part to keep the registry --- 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 newA closeA body = - withRegistry $ \registry -> do - (_key, a) <- allocate registry (\_key -> newA registry) closeA - body a - -{------------------------------------------------------------------------------- - Temporary registry --------------------------------------------------------------------------------} - --- | 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. --- --- When no exception is thrown before the end of 'runWithTempRegistry', the --- user must have transferred all the resources it allocated to their final --- state. This means that these resources don't have to be released by the --- temporary registry anymore, the final state is now in charge of releasing --- them. --- --- In case an exception is thrown before the end of 'runWithTempRegistry', --- /all/ resources allocated in the temporary registry will be released. --- --- Resources must be allocated using 'allocateTemp'. --- --- To make sure that the user doesn't forget to transfer a resource to the --- final state @st@, the user must pass a function to 'allocateTemp' that --- checks whether a given @st@ contains the resource, i.e., whether the --- resource was successfully transferred to its final destination. --- --- When no exception is thrown before the end of 'runWithTempRegistry', we --- check whether all allocated resources have been transferred to the final --- state @st@. If there's a resource that hasn't been transferred to the final --- state /and/ that hasn't be released or closed before (see the release --- function passed to 'allocateTemp'), a 'TempRegistryRemainingResource' --- exception will be thrown. --- --- For that reason, 'WithTempRegistry' is parameterised over the final state --- type @st@ and the given 'WithTempRegistry' action must return the final --- state. --- --- NOTE: we explicitly don't let 'runWithTempRegistry' return the final state, --- because the state /must/ have been stored somewhere safely, transferring --- the resources, before the temporary registry is closed. -runWithTempRegistry :: - (IOLike m, HasCallStack) - => WithTempRegistry st m (a, st) - -> m a -runWithTempRegistry m = withRegistry $ \rr -> do - varTransferredTo <- newTVarIO mempty - let tempRegistry = TempRegistry { - tempResourceRegistry = rr - , tempTransferredTo = varTransferredTo - } - (a, st) <- runReaderT (unWithTempRegistry m) tempRegistry - -- We won't reach this point if an exception is thrown, so we won't check - -- for remaining resources in that case. - -- - -- No need to mask here, whether we throw the async exception or - -- 'TempRegistryRemainingResource' doesn't matter. - transferredTo <- atomically $ readTVar varTransferredTo - untrackTransferredTo rr transferredTo st - - context <- captureContext - remainingResources <- releaseAllHelper rr context release - - whenJust (listToMaybe remainingResources) $ \remainingResource -> - throwIO $ TempRegistryRemainingResource { - tempRegistryContext = registryContext rr - , tempRegistryResource = remainingResource - } - return a - --- | Embed a self-contained 'WithTempRegistry' computation into a larger one. --- --- The internal 'WithTempRegistry' is effectively passed to --- 'runWithTempRegistry'. It therefore must have no dangling resources, for --- example. This is the meaning of /self-contained/ above. --- --- The key difference beyond 'runWithTempRegistry' is that the resulting --- composite resource is also guaranteed to be registered in the outer --- 'WithTempRegistry' computation's registry once the inner registry is closed. --- Combined with the following assumption, this establishes the invariant that --- all resources are (transitively) in a temporary registry. --- --- As the resource might require some implementation details to be closed, the --- function to close it will also be provided by the inner computation. --- --- ASSUMPTION: closing @res@ closes every resource contained in @innerSt@ --- --- NOTE: In the current implementation, there will be a brief moment where the --- inner registry still contains the inner computation's resources and also the --- outer registry simultaneously contains the new composite resource. If an --- async exception is received at that time, then the inner resources will be --- 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 - => WithTempRegistry innerSt m (a, innerSt, res) - -- ^ The embedded computation; see ASSUMPTION above - -> (res -> m Bool) - -- ^ How to free; same as for 'allocateTemp' - -> (st -> res -> Bool) - -- ^ How to check; same as for 'allocateTemp' - -> WithTempRegistry st m a -runInnerWithTempRegistry inner free isTransferred = do - outerTR <- WithTempRegistry ask - - lift $ runWithTempRegistry $ do - (a, innerSt, res) <- inner - - -- Allocate in the outer layer. - _ <- withFixedTempRegistry outerTR - $ allocateTemp (return res) free isTransferred - - -- TODO This point here is where an async exception could cause both the - -- inner resources to be closed and the outer resource to be closed later. - -- - -- If we want to do better than that, we'll need a variant of - -- '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. - pure (a, innerSt) - where - withFixedTempRegistry - :: TempRegistry st m - -> WithTempRegistry st m res - -> WithTempRegistry innerSt m res - withFixedTempRegistry env (WithTempRegistry (ReaderT f)) = - WithTempRegistry $ ReaderT $ \_ -> f env - --- | When 'runWithTempRegistry' exits successfully while there are still --- resources remaining in the temporary registry that haven't been transferred --- to the final state. -data TempRegistryException = - forall m. IOLike m => TempRegistryRemainingResource { - -- | The context in which the temporary registry was created. - tempRegistryContext :: !(Context m) - - -- | The context in which the resource was allocated that was not - -- transferred to the final state. - , tempRegistryResource :: !(Context m) - } - -deriving instance Show TempRegistryException -instance Exception TempRegistryException - --- | Given a final state, return the 'ResourceId's of the resources that have --- been /transferred to/ that state. -newtype TransferredTo st = TransferredTo { - runTransferredTo :: st -> Set ResourceId - } - deriving newtype (Semigroup, Monoid) - deriving NoThunks via OnlyCheckWhnfNamed "TransferredTo" (TransferredTo st) - --- | The environment used to run a 'WithTempRegistry' action. -data TempRegistry st m = TempRegistry { - tempResourceRegistry :: !(ResourceRegistry m) - , tempTransferredTo :: !(StrictTVar m (TransferredTo st)) - -- ^ Used as a @Writer@. - } - --- | An action with a temporary registry in scope, see 'runWithTempRegistry' --- for more details. --- --- The most important function to run in this monad is 'allocateTemp'. -newtype WithTempRegistry st m a = WithTempRegistry { - unWithTempRegistry :: ReaderT (TempRegistry st m) m a - } - deriving newtype (Functor, Applicative, Monad, MonadThrow, MonadCatch, MonadMask) - -instance MonadTrans (WithTempRegistry st) where - lift = WithTempRegistry . lift - -instance MonadState s m => MonadState s (WithTempRegistry st m) where - state = WithTempRegistry . state - --- | Untrack all the resources from the registry that have been transferred to --- the given state. --- --- Untracking a resource means removing it from the registry without releasing --- it. --- --- 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 - => ResourceRegistry m - -> TransferredTo st - -> st - -> m () -untrackTransferredTo rr transferredTo st = - updateState rr $ mapM_ removeResource rids - where - rids = runTransferredTo 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) - => m a - -- ^ Allocate the resource - -> (a -> m Bool) - -- ^ Release the resource, return 'True' when the resource was actually - -- released, return 'False' when the resource was already released. - -- - -- Note that it is safe to always return 'True' when unsure. - -> (st -> a -> Bool) - -- ^ Check whether the resource is in the given state - -> 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 - lift $ atomically $ modifyTVar varTransferredTo $ mappend $ - TransferredTo $ \st -> - if isTransferred st a - then Set.singleton (resourceKeyId key) - else Set.empty - return a - --- | Higher level API on top of 'runWithTempRegistry': modify the given @st@, --- allocating resources in the process that will be transferred to the --- returned @st@. -modifyWithTempRegistry :: - forall m st a. IOLike m - => m st -- ^ Get the state - -> (st -> ExitCase st -> m ()) -- ^ Store the new state - -> StateT st (WithTempRegistry st m) a -- ^ Modify the state - -> m a -modifyWithTempRegistry getSt putSt modSt = runWithTempRegistry $ - fst <$> generalBracket (lift getSt) transfer mutate - where - transfer :: st -> ExitCase (a, st) -> WithTempRegistry st m () - transfer initSt ec = lift $ putSt initSt (snd <$> ec) - - mutate :: st -> WithTempRegistry st m (a, st) - mutate = runStateT modSt - -{------------------------------------------------------------------------------- - Simple queries on the registry --------------------------------------------------------------------------------} - --- | The thread that created the registry -registryThread :: ResourceRegistry m -> ThreadId m -registryThread = contextThreadId . registryContext - --- | Number of currently allocated resources --- --- Primarily for the benefit of testing. -countResources :: IOLike m => ResourceRegistry m -> m Int -countResources rr = atomically $ aux <$> readTVar (registryState rr) - where - aux :: RegistryState m -> Int - aux = Map.size . registryResources - -{------------------------------------------------------------------------------- - Allocating resources --------------------------------------------------------------------------------} - --- | Allocate new resource --- --- The allocation function will be run with asynchronous exceptions masked. This --- 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 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 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 - case mKey of - Left closed -> - throwRegistryClosed rr context closed - Right key -> mask_ $ do - ma <- alloc key - case ma of - Left e -> return $ Left e - 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) - case inserted of - Left closed -> do - -- Despite the earlier check, it's possible that the registry - -- got closed after we allocated a new key but before we got a - -- chance to register the resource. In this case, we must - -- deallocate the resource again before throwing the exception. - void $ free a - throwRegistryClosed rr context closed - Right () -> - return $ Right (ResourceKey rr key, a) - where - mkResource :: Context m -> a -> Resource m - mkResource context a = Resource { - resourceContext = context - , resourceRelease = Release $ free a - } - -throwRegistryClosed :: IOLike m - => ResourceRegistry m - -> Context m - -> PrettyCallStack - -> m x -throwRegistryClosed rr context closed = throwIO RegistryClosedException { - registryClosedRegistryContext = registryContext rr - , registryClosedCloseCallStack = closed - , registryClosedAllocContext = context - } - --- | Release resource --- --- This deallocates the resource and removes it from the registry. It will be --- the responsibility of the caller to make sure that the resource is no longer --- used in any thread. --- --- The deallocation function is run with exceptions masked, so that we are --- guaranteed not to remove the resource from the registry without releasing it. --- --- 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 key@(ResourceKey rr _) = do - context <- captureContext - ensureKnownThread rr context - unsafeRelease key - --- | Unsafe version of 'release' --- --- The only difference between 'release' and 'unsafeRelease' is that the latter --- does not insist that it is called from a thread that is known to the --- registry. This is dangerous, because it implies that there is a thread with --- access to a resource which may be deallocated before that thread is --- terminated. Of course, we can't detect all such situations (when the thread --- merely uses a resource but does not allocate or release we can't tell), but --- normally when we /do/ detect this we throw an exception. --- --- 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 (ResourceKey rr rid) = do - mask_ $ do - mResource <- updateState rr $ removeResource rid - case mResource of - Nothing -> return Nothing - Just resource -> do - actuallyReleased <- releaseResource resource - return $ - if actuallyReleased - then Just (resourceContext resource) - else Nothing - --- | Release all resources in the 'ResourceRegistry' without closing. --- --- See 'closeRegistry' for more details. -releaseAll :: (IOLike m, HasCallStack) => ResourceRegistry m -> m () -releaseAll rr = do - context <- captureContext - unless (contextThreadId context == contextThreadId (registryContext rr)) $ - throwIO $ ResourceRegistryClosedFromWrongThread { - resourceRegistryCreatedIn = registryContext rr - , resourceRegistryUsedIn = context - } - void $ releaseAllHelper rr context release - --- | 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 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 rr context releaser = mask_ $ do - mKeys <- updateState rr $ unlessClosed $ gets getYoungestToOldest - case mKeys of - Left closed -> throwRegistryClosed rr context closed - Right keys -> releaseResources rr keys releaser - -{------------------------------------------------------------------------------- - Threads --------------------------------------------------------------------------------} - --- | Thread --- --- The internals of this type are not exported. -data Thread m a = IOLike m => Thread { - threadId :: !(ThreadId m) - , threadResourceId :: !ResourceId - , threadAsync :: !(Async m a) - , threadRegistry :: !(ResourceRegistry m) - } - deriving NoThunks via OnlyCheckWhnfNamed "Thread" (Thread m a) - --- | 'Eq' instance for 'Thread' compares 'threadId' only. -instance Eq (Thread m a) where - Thread{threadId = a} == Thread{threadId = b} = a == b - --- | Cancel a thread --- --- This is a synchronous operation: the thread will have terminated when this --- function returns. --- --- Uses 'uninterruptibleCancel' because that's what 'withAsync' does. -cancelThread :: IOLike m => Thread m a -> m () -cancelThread = uninterruptibleCancel . threadAsync - --- | Wait for thread to terminate and return its result. --- --- If the thread throws an exception, this will rethrow that exception. --- --- 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 -waitThread = wait . threadAsync - --- | Lift 'waitAny' to 'Thread' -waitAnyThread :: forall m a. IOLike 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 rr label body = snd <$> - allocate rr (\key -> mkThread key <$> async (body' key)) cancelThread - where - mkThread :: ResourceId -> Async m a -> Thread m a - mkThread rid child = Thread { - threadId = asyncThreadId child - , threadResourceId = rid - , threadAsync = child - , threadRegistry = rr - } - - body' :: ResourceId -> m a - body' rid = do - me <- myThreadId - labelThread me label - (registerThread me >> body) `finally` unregisterThread me rid - - -- Register the thread - -- - -- We must add the thread to the list of known threads before the thread - -- will start to use the registry. - registerThread :: ThreadId m -> m () - registerThread tid = updateState rr $ insertThread tid - - -- Unregister the thread - -- - -- Threads are the only kinds of resources that "deallocate themselves". - -- We remove the thread from the resources as well as the set of known - -- threads, so that these datastructures do not grow without bound. - -- - -- This runs with asynchronous exceptions masked (due to 'finally'), - -- though for the current implementation of 'unregisterThread' this - -- makes no difference. - unregisterThread :: ThreadId m -> ResourceId -> m () - unregisterThread tid rid = - updateState rr $ do - removeThread tid - void $ removeResource rid - --- | Bracketed version of 'forkThread' --- --- The analogue of 'withAsync' for the registry. --- --- Scoping thread lifetime using 'withThread' is important when a parent --- thread wants to link to a child thread /and handle any exceptions arising --- from the link/: --- --- > let handleLinkException :: ExceptionInLinkedThread -> m () --- > handleLinkException = .. --- > in handle handleLinkException $ --- > withThread registry codeInChild $ \child -> --- > .. --- --- instead of --- --- > handle handleLinkException $ do -- PROBABLY NOT CORRECT! --- > child <- forkThread registry codeInChild --- > .. --- --- where the parent may exit the scope of the exception handler before the child --- terminates. If the lifetime of the child cannot be limited to the lifetime of --- 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 --- registry. After all, in a pattern like --- --- > withRegistry $ \registry -> --- > .. --- > withAsync (.. registry ..) $ \async -> --- > .. --- --- the async will be cancelled when leaving the scope of 'withAsync' and so --- that reference to the registry, or indeed any of the resources inside the --- registry, is safe. However, the registry implements a sanity check that the --- registry is only used from known threads. This is useful: when a thread that --- is not known to the registry (in other words, whose lifetime is not tied to --- the lifetime of the registry) spawns a resource in that registry, that --- resource may well be deallocated before the thread terminates, leading to --- undefined and hard to debug behaviour (indeed, whether or not this results in --- problems may well depend on precise timing); an exception that is thrown when --- /allocating/ the resource is (more) deterministic and easier to debug. --- Unfortunately, it means that the above pattern is not applicable, as the --- thread spawned by 'withAsync' is not known to the registry, and so if it were --- to try to use the registry, the registry would throw an error (even though --- this pattern is actually safe). This situation is not ideal, but for now we --- merely provide an alternative to 'withAsync' that /does/ register the thread --- with the registry. --- --- 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 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 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 rr label body = do - t <- forkThread rr label body - -- There is no race condition here between the new thread throwing an - -- exception and the 'linkToRegistry': if the thread /already/ threw the - -- exception when we link it, the exception will be raised immediately - -- (see 'linkTo' for details). - linkToRegistry t - return t - -{------------------------------------------------------------------------------- - Check that registry is used from known thread --------------------------------------------------------------------------------} - -ensureKnownThread :: forall m. IOLike m - => ResourceRegistry m -> Context m -> m () -ensureKnownThread rr context = do - isKnown <- checkIsKnown - unless isKnown $ - throwIO $ ResourceRegistryUsedFromUntrackedThread { - resourceRegistryCreatedIn = registryContext rr - , resourceRegistryUsedIn = context - } - where - checkIsKnown :: m Bool - checkIsKnown - | contextThreadId context == contextThreadId (registryContext rr) = - return True - | otherwise = atomically $ do - KnownThreads ts <- registryThreads <$> readTVar (registryState rr) - return $ contextThreadId context `Set.member` ts - --- | Registry used from untracked threads --- --- If this exception is raised, it indicates a bug in the caller. -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 { - -- | Information about the context in which the registry was created - resourceRegistryCreatedIn :: !(Context m) - - -- | The context in which it was used - , resourceRegistryUsedIn :: !(Context m) - } - - -- | Registry closed from different threat than that created it - | forall m. IOLike m => ResourceRegistryClosedFromWrongThread { - -- | Information about the context in which the registry was created - resourceRegistryCreatedIn :: !(Context m) - - -- | The context in which it was used - , resourceRegistryUsedIn :: !(Context m) - } - -deriving instance Show ResourceRegistryThreadException -instance Exception ResourceRegistryThreadException - -{------------------------------------------------------------------------------- - Auxiliary: context --------------------------------------------------------------------------------} - -data Context m = IOLike m => Context { - -- | CallStack in which it was created - contextCallStack :: !PrettyCallStack - - -- | Thread that created the registry or resource - , contextThreadId :: !(ThreadId m) - } - --- Existential type; we can't use generics -instance NoThunks (Context m) where - showTypeOf _ = "Context" - wNoThunks ctxt (Context cs tid) = allNoThunks - [ noThunks ctxt cs - , noThunks ctxt (InspectHeapNamed @"ThreadId" tid) - ] - -deriving instance Show (Context m) - -captureContext :: IOLike m => HasCallStack => m (Context m) -captureContext = Context prettyCallStack <$> myThreadId 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 cf3d7b11b0..947ab3e927 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util/STM.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util/STM.hs @@ -27,12 +27,12 @@ module Ouroboros.Consensus.Util.STM ( 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 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 1ab6c62eed..95d1ba6835 100644 --- a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/ChainDB.hs +++ b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/ChainDB.hs @@ -13,6 +13,7 @@ module Test.Util.ChainDB ( import Control.Concurrent.Class.MonadSTM.Strict +import Control.ResourceRegistry (ResourceRegistry) import Control.Tracer (nullTracer) import Ouroboros.Consensus.Block.Abstract import Ouroboros.Consensus.Config @@ -34,7 +35,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/OracularClock.hs b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/HardFork/OracularClock.hs index e654baefce..e71b27e1d4 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/LogicalClock.hs b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/LogicalClock.hs index 3bf892527a..42e9ec12f2 100644 --- a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/LogicalClock.hs +++ b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/LogicalClock.hs @@ -25,13 +25,13 @@ module Test.Util.LogicalClock ( ) 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) 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 ae376efa31..ac49080a97 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 @@ -1,21 +1,26 @@ {-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MonoLocalBinds #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -Wno-orphans #-} module Test.Util.Orphans.NoThunks () where import Control.Concurrent.Class.MonadMVar -import Control.Concurrent.Class.MonadSTM.Strict.TVar.Checked +import Control.Concurrent.Class.MonadMVar.Strict +import Control.Concurrent.Class.MonadSTM.Strict 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 Ouroboros.Consensus.Util.MonadSTM.StrictSVar +import qualified Ouroboros.Consensus.Util.NormalForm.StrictMVar as NormalForm +import qualified Ouroboros.Consensus.Util.NormalForm.StrictTVar as NormalForm import System.FS.API.Types import System.FS.Sim.FsTree import System.FS.Sim.MockFS @@ -32,11 +37,13 @@ instance NoThunks a => NoThunks (StrictMVar (IOSim s) a) where aMay <- unsafeSTToIO $ lazyToStrictST $ inspectMVar (Proxy :: Proxy (IOSim s)) (toLazyMVar mvar) noThunks ctxt aMay -instance NoThunks a => NoThunks (StrictTVar (IOSim s) a) where +instance NoThunks (StrictMVar (IOSim s) a) => NoThunks (NormalForm.StrictMVar (IOSim s) a) where + showTypeOf _ = "StrictMVar IOSim" + wNoThunks ctxt mvar = wNoThunks ctxt (NormalForm.unsafeToUncheckedStrictMVar mvar) + +instance NoThunks (StrictTVar (IOSim s) a) => NoThunks (NormalForm.StrictTVar (IOSim s) a) where showTypeOf _ = "StrictTVar IOSim" - wNoThunks ctxt tvar = do - a <- unsafeSTToIO $ lazyToStrictST $ inspectTVar (Proxy :: Proxy (IOSim s)) $ toLazyTVar tvar - noThunks ctxt a + wNoThunks ctxt tv = wNoThunks ctxt (NormalForm.unsafeToUncheckedStrictTVar tv) {------------------------------------------------------------------------------- fs-sim diff --git a/ouroboros-consensus/test/consensus-test/Main.hs b/ouroboros-consensus/test/consensus-test/Main.hs index 9e1b408935..e609007823 100644 --- a/ouroboros-consensus/test/consensus-test/Main.hs +++ b/ouroboros-consensus/test/consensus-test/Main.hs @@ -10,7 +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.Versioned (tests) import Test.Tasty @@ -30,7 +29,6 @@ tests = , Test.Consensus.MiniProtocol.LocalStateQuery.Server.tests , Test.Consensus.Mempool.tests , Test.Consensus.Mempool.Fairness.tests - , Test.Consensus.ResourceRegistry.tests , Test.Consensus.Util.MonadSTM.NormalForm.tests , Test.Consensus.Util.Versioned.tests , testGroup "HardFork" [ 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 e82537b586..24ea723354 100644 --- a/ouroboros-consensus/test/consensus-test/Test/Consensus/BlockchainTime/Simple.hs +++ b/ouroboros-consensus/test/consensus-test/Test/Consensus/BlockchainTime/Simple.hs @@ -38,6 +38,8 @@ module Test.Consensus.BlockchainTime.Simple (tests) where import Control.Applicative (Alternative (..)) +import qualified Control.Concurrent.Class.MonadMVar.Strict as Strict +import qualified Control.Concurrent.Class.MonadSTM.Strict as Strict import Control.Monad (MonadPlus, when) import qualified Control.Monad.Class.MonadSTM.Internal as LazySTM import Control.Monad.Class.MonadTime @@ -46,6 +48,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 +56,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) @@ -390,6 +392,12 @@ deriving via AllowThunk (StrictSVar (OverrideDelay s) a) deriving via AllowThunk (StrictMVar (OverrideDelay s) a) instance NoThunks (StrictMVar (OverrideDelay s) a) +deriving via AllowThunk (Strict.StrictTVar (OverrideDelay s) a) + instance NoThunks (Strict.StrictTVar (OverrideDelay s) a) + +deriving via AllowThunk (Strict.StrictMVar (OverrideDelay s) a) + instance NoThunks (Strict.StrictMVar (OverrideDelay s) a) + instance MonadTimer.MonadDelay (OverrideDelay (IOSim s)) where threadDelay d = OverrideDelay $ ReaderT $ \schedule -> do -- Do the original delay. This is important, because otherwise this 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 a3f50fb0a7..322af9defb 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 6ec692e4d0..0905fc375f 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 as List (foldl', intercalate) @@ -103,7 +104,6 @@ import Ouroboros.Consensus.Storage.ChainDB.API import Ouroboros.Consensus.Util (lastMaybe, 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/ResourceRegistry.hs b/ouroboros-consensus/test/consensus-test/Test/Consensus/ResourceRegistry.hs deleted file mode 100644 index 1b698d1280..0000000000 --- a/ouroboros-consensus/test/consensus-test/Test/Consensus/ResourceRegistry.hs +++ /dev/null @@ -1,629 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DeriveTraversable #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# 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 --- --- * Fork a thread from some other thread --- * Terminate a thread --- * Have a thread crash --- * Collect all live threads --- --- 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 ((>=>)) -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 Data.Functor.Classes -import Data.Kind (Type) -import Data.List (delete, sort) -import Data.Map.Strict (Map) -import qualified Data.Map.Strict as Map -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 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.Util.QSM -import Test.Util.SOP -import Test.Util.ToExpr () - -tests :: TestTree -tests = testGroup "ResourceRegistry" [ - testProperty "sequential" prop_sequential - ] - -{------------------------------------------------------------------------------- - Mock implementaton --------------------------------------------------------------------------------} - --- | Mock thread IDs record thread pedigree --- --- > [t] top-level thread t --- > [t, t'] child t' of top-level thread t --- > [t, t', t''] child t'' of thread t', itself a child of t --- --- NOTE: All thread IDs will be unique. If both threads 1 and 2 spawn a child, --- they would be @[1,3]@ and @[2,4]@. -type MockThread = [Int] - --- | Threads and their subthreads --- --- Once created, threads are never removed from this map. Instead, when they are --- killed their 'alive' status is set to 'False'. -newtype MockThreads = MTs { mockThreadsMap :: Map Int MockState } - deriving (Show, Generic) - --- | State of a mock thread -data MockState = MS { - alive :: Bool - , kids :: MockThreads - } - deriving (Show, Generic) - --- | All known threads, and whether or not they are alive --- --- TODO: Perhaps it would be better to have an invariant that in 'MockThreads' --- threads must be recorded as dead if any of their parents are, rather than --- computing that here. -mockThreads :: MockThreads -> [(MockThread, Bool)] -mockThreads = go [] True - where - go :: [Int] -> Bool -> MockThreads -> [(MockThread, Bool)] - go prefix parentAlive = - concatMap aux . Map.toList . mockThreadsMap - where - aux :: (Int, MockState) -> [(MockThread, Bool)] - aux (tid, MS{..}) = - (t, parentAlive && alive) : go t alive' kids - where - t :: [Int] - t = prefix ++ [tid] - - alive' :: Bool - alive' = parentAlive && alive - -mockLiveThreads :: MockThreads -> [MockThread] -mockLiveThreads = map fst . filter snd . mockThreads - -alterThreadF :: forall m. MonadError Err m - => MockThread - -> (Maybe MockState -> m MockState) - -> MockThreads -> m MockThreads -alterThreadF [] _ _ = - error "alterThreadF: invalid thread" -alterThreadF [t] f (MTs m) = - MTs <$> Map.alterF (fmap Just . f) t m -alterThreadF thread@(t:ts) f (MTs m) = - MTs <$> Map.alterF (fmap Just . f') t m - where - f' :: Maybe MockState -> m MockState - f' Nothing = throwError $ ErrInvalidThread (show thread) - f' (Just ms) = (\kids' -> ms { kids = kids' }) <$> - alterThreadF ts f (kids ms) - --- Create thread with the given ID -mockFork :: MockThread -> MockThreads -> Except Err MockThreads -mockFork t = alterThreadF t $ \case - Just _ -> error "fork: thread already exists (bug in runMock)" - Nothing -> return newState - where - newState :: MockState - newState = MS { - alive = True - , kids = MTs Map.empty - } - -mockKill :: MockThread -> MockThreads -> Except Err MockThreads -mockKill t = alterThreadF t $ \case - Nothing -> throwError $ ErrInvalidThread (show t) - Just st -> return st { alive = False } - -data Mock = Mock { - nextId :: Int - , threads :: MockThreads - , links :: Map MockThread (Link MockThread) - } - deriving (Show, Generic) - -emptyMock :: Mock -emptyMock = Mock { - nextId = 1 - , threads = MTs Map.empty - , links = Map.empty - } - -{------------------------------------------------------------------------------- - Commands --------------------------------------------------------------------------------} - --- | Should we link a new thread to its parent? --- --- If yes, we need some information about that parent. -data Link a = LinkFromParent a | DontLink - deriving (Show, Functor, Generic) - -data Cmd t = - -- | Fork a new top-level thread - -- - -- We don't allow linking here, because we don't want an exception in one - -- of these threads to kill the thread running the tests. - Fork - - -- | Fork a child thread - | ForkFrom t (Link ()) - - -- | Cause a thread to terminate normally - | Terminate t - - -- | Cause a thread to terminate abnormally - | Crash t - - -- | Get all live threads - | LiveThreads - deriving (Show, Functor, Foldable, Traversable, Generic) - -data Success t = - Unit () - | Spawned t - | Threads [t] - deriving (Show, Eq, Functor, Foldable, Traversable) - -data Err = - ErrTimeout - | ErrInvalidThread String - deriving (Show, Eq) - -newtype Resp t = Resp (Either Err (Success t)) - deriving (Show, Eq, Functor, Foldable, Traversable) - -{------------------------------------------------------------------------------- - "Up-to" comparison for responses - - This is used in 'postcondition'. --------------------------------------------------------------------------------} - -normalize :: Resp MockThread -> Resp MockThread -normalize (Resp r) = Resp $ aux <$> r - where - aux :: Success MockThread -> Success MockThread - aux (Unit ()) = Unit () - aux (Spawned t) = Spawned t - aux (Threads ts) = Threads (sort ts) - -{------------------------------------------------------------------------------- - Run against the mock implementation --------------------------------------------------------------------------------} - -runMock :: Cmd MockThread -> Mock -> (Resp MockThread, Mock) -runMock cmd m@Mock{..} = - case runExcept (go cmd) of - Left err -> (Resp (Left err), m) - Right (success, m') -> (Resp (Right success), m') - where - go :: Cmd MockThread -> Except Err (Success MockThread, Mock) - go Fork = createThread DontLink [nextId] - go (ForkFrom t linked) = createThread (const t <$> linked) (t ++ [nextId]) - go (Terminate t) = (\x -> (Unit (), m { threads = x })) <$> mockKill t threads - go (Crash t) = (\x -> (Unit (), m { threads = x })) <$> killAll t threads - go LiveThreads = return (Threads $ mockLiveThreads threads, m) - - createThread :: Link MockThread -- Thread to link to (if any) - -> MockThread -> Except Err (Success MockThread, Mock) - createThread shouldLink t = do - threads' <- mockFork t threads - return ( - Spawned t - , m { nextId = succ nextId - , threads = threads' - , links = Map.insert t shouldLink links - } - ) - - killAll :: MockThread -> MockThreads -> Except Err MockThreads - killAll t = - mockKill t >=> killParent (Map.findWithDefault DontLink t links) - where - killParent :: Link MockThread -> MockThreads -> Except Err MockThreads - killParent DontLink = return - killParent (LinkFromParent t') = killAll t' - -{------------------------------------------------------------------------------- - Run in IO (possibly simulated) --------------------------------------------------------------------------------} - -data TestThread m = TestThread { - -- | The underlying 'Thread' - testThread :: Thread m () - - -- | Parent thread this thread is linked to (if any) - , threadLinked :: Link (TestThread m) - - -- | Send the thread instructions (see 'ThreadInstr') - , threadComms :: TQueue m (QueuedInstr m) - } - --- | Instructions to a thread --- --- The type argument indicates the result of the instruction -data ThreadInstr m :: Type -> Type where - -- | Have the thread spawn a child thread - ThreadFork :: Link () -> ThreadInstr m (TestThread m) - - -- | Have the thread terminate normally - ThreadTerminate :: ThreadInstr m () - - -- | Raise an exception in the thread - ThreadCrash :: ThreadInstr m () - --- | 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 TestThread{..} instr = do - result <- uncheckedNewEmptyMVar - atomically $ writeTQueue threadComms (QueuedInstr instr result) - takeMVar result - -instance (IOLike m) => Show (TestThread m) where - show TestThread{..} = "" - -instance (IOLike m) => Eq (TestThread m) where - (==) = (==) `on` (threadId . testThread) - --- | Create a new thread in the given registry --- --- 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 - => StrictTVar m [TestThread m] - -> ResourceRegistry m - -> Link (TestThread m) - -> m (TestThread m) -newThread alive parentReg = \shouldLink -> do - comms <- atomically $ newTQueue - spawned <- uncheckedNewEmptyMVar - - thread <- forkThread parentReg "newThread" $ - withRegistry $ \childReg -> - threadBody childReg spawned comms - case shouldLink of - LinkFromParent _ -> linkToRegistry thread - DontLink -> return () - - let testThread :: TestThread m - testThread = TestThread { - testThread = thread - , threadLinked = shouldLink - , threadComms = comms - } - - -- Make sure to register thread before starting it - atomically $ modifyTVar alive (testThread:) - putMVar spawned testThread - return testThread - where - threadBody :: ResourceRegistry m - -> StrictMVar m (TestThread m) - -> TQueue m (QueuedInstr m) - -> m () - threadBody childReg spawned comms = do - us <- readMVar spawned - loop us `finally` (atomically $ modifyTVar alive (delete us)) - where - loop :: TestThread m -> m () - loop us = do - QueuedInstr instr result <- atomically $ readTQueue comms - case instr of - ThreadFork linked -> do - child <- newThread alive childReg (const us <$> linked) - putMVar result child - loop us - ThreadTerminate -> do - putMVar result () - ThreadCrash -> do - putMVar result () - error "crashing" - -runIO :: forall m. (IOLike m, MonadTimer m) - => StrictTVar m [TestThread m] - -> ResourceRegistry m - -> Cmd (TestThread m) -> m (Resp (TestThread m)) -runIO alive reg cmd = catchEx $ timeout 1 $ - case cmd of - Fork -> - Spawned <$> newThread alive reg DontLink - ForkFrom thread shouldLink -> do - Spawned <$> runInThread thread (ThreadFork shouldLink) - Terminate thread -> do - runInThread thread ThreadTerminate - Unit <$> waitForTermination thread - Crash thread -> do - runInThread thread ThreadCrash - Unit <$> waitForTermination thread - LiveThreads -> - atomically $ Threads <$> readTVar alive - where - catchEx :: m (Maybe (Success a)) -> m (Resp a) - catchEx = fmap (Resp . maybe (Left ErrTimeout) Right) - - -- For the thread and all of its linked parents to have terminated - waitForTermination :: TestThread m -> m () - waitForTermination t = do - result <- try $ waitThread (testThread t) - case (result, threadLinked t) of - (Left (_ :: SomeException), LinkFromParent t') -> - waitForTermination t' - _otherwise -> - return () - -{------------------------------------------------------------------------------- - QSM wrappers --------------------------------------------------------------------------------} - -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) - -{------------------------------------------------------------------------------- - Relate model to IO --------------------------------------------------------------------------------} - --- TODO: Use RefEnv? -type Refs m r = [(Reference (TestThread m) r, MockThread)] - -(!) :: (Eq k, Show k) => [(k, a)] -> k -> a -env ! r = case lookup r env of - Just a -> a - Nothing -> error $ "Unknown reference: " ++ show r - -data Model m r = Model Mock (Refs m r) - deriving (Show, Generic) - -initModel :: Model m r -initModel = Model emptyMock [] - -{------------------------------------------------------------------------------- - Events --------------------------------------------------------------------------------} - -toMock :: forall m f r. (Functor f, Eq1 r, Show1 r, IOLike m) - => Model m r -> At m f r -> f MockThread -toMock (Model _ hs) (At fr) = (hs !) <$> fr - -step :: (Eq1 r, Show1 r, IOLike m) - => Model m r -> At m Cmd r -> (Resp MockThread, Mock) -step m@(Model mock _) c = runMock (toMock m c) mock - -data Event m r = Event { - before :: Model m r - , cmd :: At m Cmd r - , after :: Model m r - , mockResp :: Resp MockThread - } - -lockstep :: (Eq1 r, Show1 r, IOLike m) - => Model m r - -> At m Cmd r - -> At m Resp r - -> Event m r -lockstep m@(Model _ hs) c (At resp) = Event { - before = m - , cmd = c - , after = Model mock' (hs <> hs') - , mockResp = resp' - } - where - (resp', mock') = step m c - hs' = zip (newHandles resp) (newHandles resp') - - newHandles :: Resp r -> [r] - newHandles (Resp (Left _)) = [] - newHandles (Resp (Right (Unit ()))) = [] - newHandles (Resp (Right (Spawned t))) = [t] - newHandles (Resp (Right (Threads _))) = [] - -{------------------------------------------------------------------------------- - Generator --------------------------------------------------------------------------------} - -generator :: forall m. Model m Symbolic -> Maybe (Gen (At m Cmd Symbolic)) -generator (Model _ hs) = Just $ QC.oneof $ concat [ - withoutHandle - , if null hs then [] else withHandle (QC.elements (map fst hs)) - ] - where - withoutHandle :: [Gen (At m Cmd Symbolic)] - withoutHandle = [ - fmap At $ return Fork - , fmap At $ return LiveThreads - ] - - withHandle :: Gen (Reference (TestThread m) Symbolic) - -> [Gen (At m Cmd Symbolic)] - withHandle pickThread = [ - fmap At $ Terminate <$> pickThread - , fmap At $ Crash <$> pickThread - , fmap At $ ForkFrom <$> pickThread <*> genLink - ] - - genLink :: Gen (Link ()) - genLink = aux <$> QC.arbitrary - where - aux :: Bool -> Link () - aux True = LinkFromParent () - aux False = DontLink - -shrinker :: Model m Symbolic -> At m Cmd Symbolic -> [At m Cmd Symbolic] -shrinker _ _ = [] - -{------------------------------------------------------------------------------- - QSM required instances --------------------------------------------------------------------------------} - -instance SOP.Generic (Cmd t) -instance SOP.HasDatatypeInfo (Cmd t) - -deriving instance Generic1 (At m Cmd) -deriving instance Generic1 (At m Resp) - -instance CommandNames (At m Cmd) where - cmdName (At cmd) = constrName cmd - cmdNames _ = constrNames (Proxy @(Cmd ())) - -instance Rank2.Foldable (At m Cmd) -instance Rank2.Functor (At m Cmd) -instance Rank2.Traversable (At m Cmd) - -instance Rank2.Foldable (At m Resp) - -instance ToExpr MockState -instance ToExpr MockThreads -instance ToExpr Mock -instance ToExpr (Link MockThread) -instance ToExpr (Model IO Concrete) - -instance (IOLike m) => ToExpr (TestThread m) where - toExpr = defaultExprViaShow - -{------------------------------------------------------------------------------- - QSM toplevel --------------------------------------------------------------------------------} - -semantics :: (IOLike m, MonadTimer m, Typeable m) - => StrictTVar m [TestThread m] - -> ResourceRegistry m - -> At m Cmd Concrete -> m (At m Resp Concrete) -semantics alive reg (At c) = - (At . fmap reference) <$> - runIO alive reg (concrete <$> c) - -transition :: (Eq1 r, Show1 r, IOLike 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) - => Model m Symbolic -> At m Cmd Symbolic -> Logic -precondition (Model mock hs) (At c) = - forAll (toList c) checkRef - where - checkRef :: Reference (TestThread m) Symbolic -> Logic - checkRef r = - case lookup r hs of - Nothing -> Bot - Just r' -> r' `member` mockLiveThreads (threads mock) - -postcondition :: (IOLike m) - => Model m Concrete - -> At m Cmd Concrete - -> At m Resp Concrete - -> Logic -postcondition m c r = - normalize (toMock (after e) r) .== normalize (mockResp e) - where - e = lockstep m c r - -symbolicResp :: (IOLike m, Typeable m) - => Model m Symbolic - -> At m Cmd Symbolic - -> GenSym (At m Resp Symbolic) -symbolicResp m c = At <$> traverse (const genSym) resp - where - (resp, _mock') = step m c - -sm :: (IOLike m, MonadTimer m, Typeable m) - => StrictTVar m [TestThread m] - -> ResourceRegistry m - -> StateMachine (Model m) (At m Cmd) m (At m Resp) -sm alive reg = StateMachine { - initModel = initModel - , transition = transition - , precondition = precondition - , postcondition = postcondition - , invariant = Nothing - , generator = generator - , shrinker = shrinker - , semantics = semantics alive reg - , mock = symbolicResp - , cleanup = noCleanup - } - -prop_sequential :: QC.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 [] - reg <- liftIO $ unsafeNewRegistry - let sm' = sm alive reg - (hist, _model, res) <- runCommands sm' cmds - prettyCommands sm' hist - $ checkCommandNames cmds - $ res QC.=== Ok - -unused :: a -unused = error "not used during command generation" - -{------------------------------------------------------------------------------- - For running things from ghci --------------------------------------------------------------------------------} - -_forkCount :: QSM.Commands (At IO Cmd) (At IO Resp) -_forkCount = example (sm unused unused) $ do - run' $ At $ Fork - run' $ At $ LiveThreads - -_forkKillCount :: QSM.Commands (At IO Cmd) (At IO Resp) -_forkKillCount = example (sm unused unused) $ do - [t] <- run $ At $ Fork - run' $ At $ Terminate t - run' $ At $ LiveThreads - -_forkFromKillCount :: QSM.Commands (At IO Cmd) (At IO Resp) -_forkFromKillCount = example (sm unused unused) $ do - [t] <- run $ At $ Fork - run' $ At $ ForkFrom t DontLink - run' $ At $ Terminate t - run' $ At $ LiveThreads - -_invalidForkFrom :: QSM.Commands (At IO Cmd) (At IO Resp) -_invalidForkFrom = example (sm unused unused) $ do - [t] <- run $ At $ Fork - run' $ At $ Terminate t - run' $ At $ ForkFrom t DontLink diff --git a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/FollowerPromptness.hs b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/FollowerPromptness.hs index fa854c28e7..5b224712c9 100644 --- a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/FollowerPromptness.hs +++ b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/FollowerPromptness.hs @@ -21,6 +21,7 @@ module Test.Ouroboros.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/Iterator.hs b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/Iterator.hs index a471052775..53e407f376 100644 --- a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/Iterator.hs +++ b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/Iterator.hs @@ -16,6 +16,7 @@ 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,7 +34,6 @@ 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 diff --git a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/StateMachine.hs b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/StateMachine.hs index d15a581636..2eacc254b7 100644 --- a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/StateMachine.hs +++ b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/StateMachine.hs @@ -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 @@ -131,7 +132,6 @@ 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) diff --git a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/Unit.hs b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/Unit.hs index b81b9d4761..5a58f41015 100644 --- a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/Unit.hs +++ b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/Unit.hs @@ -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,8 +41,6 @@ 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 qualified Ouroboros.Network.AnchoredFragment as AF import Ouroboros.Network.Block (ChainUpdate (..), Point, blockPoint) import qualified Ouroboros.Network.Mock.Chain as Mock diff --git a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ImmutableDB/StateMachine.hs b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ImmutableDB/StateMachine.hs index 1427c5330f..bcd8cfb738 100644 --- a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ImmutableDB/StateMachine.hs +++ b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ImmutableDB/StateMachine.hs @@ -47,6 +47,7 @@ module Test.Ouroboros.Storage.ImmutableDB.StateMachine ( import Control.Concurrent.Class.MonadSTM.Strict (newTMVar) import Control.Monad (forM_, void) +import Control.ResourceRegistry import Data.Bifunctor (first) import Data.ByteString.Lazy (ByteString) import Data.Coerce (Coercible, coerce) @@ -76,7 +77,6 @@ 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) diff --git a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/VolatileDB/StateMachine.hs b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/VolatileDB/StateMachine.hs index 088f952bdf..3fea8dd89b 100644 --- a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/VolatileDB/StateMachine.hs +++ b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/VolatileDB/StateMachine.hs @@ -34,6 +34,7 @@ module Test.Ouroboros.Storage.VolatileDB.StateMachine ( import Control.Concurrent.Class.MonadSTM.Strict (newTMVar) import Control.Monad (forM_, void) +import Control.ResourceRegistry import Data.Bifunctor (first) import Data.ByteString.Lazy (ByteString) import Data.Functor.Classes @@ -55,7 +56,6 @@ 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 diff --git a/scripts/docs/prologue.haddock b/scripts/docs/prologue.haddock index 46d247ad91..6e605f8323 100644 --- a/scripts/docs/prologue.haddock +++ b/scripts/docs/prologue.haddock @@ -54,11 +54,6 @@ implementation of consensus. * "Ouroboros.Consensus.MiniProtocol.ChainSync.Client" -* Utilities: - - * "Ouroboros.Consensus.Util.ResourceRegistry" - - == Consensus Components The following [C4 Component Diagram](https://c4model.com/) provides a high-level